compiler: de-lhs typecheck/
authorAustin Seipp <austin@well-typed.com>
Wed, 3 Dec 2014 18:46:17 +0000 (12:46 -0600)
committerAustin Seipp <austin@well-typed.com>
Wed, 3 Dec 2014 19:52:28 +0000 (13:52 -0600)
Signed-off-by: Austin Seipp <austin@well-typed.com>
46 files changed:
compiler/typecheck/FamInst.hs [moved from compiler/typecheck/FamInst.lhs with 88% similarity]
compiler/typecheck/FunDeps.hs [moved from compiler/typecheck/FunDeps.lhs with 94% similarity]
compiler/typecheck/Inst.hs [moved from compiler/typecheck/Inst.lhs with 88% similarity]
compiler/typecheck/TcAnnotations.hs [moved from compiler/typecheck/TcAnnotations.lhs with 92% similarity]
compiler/typecheck/TcArrows.hs [moved from compiler/typecheck/TcArrows.lhs with 86% similarity]
compiler/typecheck/TcBinds.hs [moved from compiler/typecheck/TcBinds.lhs with 97% similarity]
compiler/typecheck/TcCanonical.hs [moved from compiler/typecheck/TcCanonical.lhs with 93% similarity]
compiler/typecheck/TcClassDcl.hs [moved from compiler/typecheck/TcClassDcl.lhs with 93% similarity]
compiler/typecheck/TcDefaults.hs [moved from compiler/typecheck/TcDefaults.lhs with 96% similarity]
compiler/typecheck/TcDeriv.hs [moved from compiler/typecheck/TcDeriv.lhs with 97% similarity]
compiler/typecheck/TcEnv.hs [moved from compiler/typecheck/TcEnv.lhs with 89% similarity]
compiler/typecheck/TcEnv.hs-boot [new file with mode: 0644]
compiler/typecheck/TcEnv.lhs-boot [deleted file]
compiler/typecheck/TcErrors.hs [moved from compiler/typecheck/TcErrors.lhs with 97% similarity]
compiler/typecheck/TcEvidence.hs [moved from compiler/typecheck/TcEvidence.lhs with 95% similarity]
compiler/typecheck/TcExpr.hs [moved from compiler/typecheck/TcExpr.lhs with 92% similarity]
compiler/typecheck/TcExpr.hs-boot [moved from compiler/typecheck/TcExpr.lhs-boot with 84% similarity]
compiler/typecheck/TcFlatten.hs [moved from compiler/typecheck/TcFlatten.lhs with 94% similarity]
compiler/typecheck/TcForeign.hs [moved from compiler/typecheck/TcForeign.lhs with 92% similarity]
compiler/typecheck/TcGenDeriv.hs [moved from compiler/typecheck/TcGenDeriv.lhs with 94% similarity]
compiler/typecheck/TcGenGenerics.hs [moved from compiler/typecheck/TcGenGenerics.lhs with 97% similarity]
compiler/typecheck/TcHsSyn.hs [moved from compiler/typecheck/TcHsSyn.lhs with 95% similarity]
compiler/typecheck/TcHsType.hs [moved from compiler/typecheck/TcHsType.lhs with 96% similarity]
compiler/typecheck/TcInstDcls.hs [moved from compiler/typecheck/TcInstDcls.lhs with 97% similarity]
compiler/typecheck/TcInteract.hs [moved from compiler/typecheck/TcInteract.lhs with 99% similarity]
compiler/typecheck/TcMType.hs [moved from compiler/typecheck/TcMType.lhs with 89% similarity]
compiler/typecheck/TcMatches.hs [moved from compiler/typecheck/TcMatches.lhs with 95% similarity]
compiler/typecheck/TcMatches.hs-boot [moved from compiler/typecheck/TcMatches.lhs-boot with 95% similarity]
compiler/typecheck/TcPat.hs [moved from compiler/typecheck/TcPat.lhs with 95% similarity]
compiler/typecheck/TcPatSyn.hs [moved from compiler/typecheck/TcPatSyn.lhs with 93% similarity]
compiler/typecheck/TcPatSyn.hs-boot [moved from compiler/typecheck/TcPatSyn.lhs-boot with 95% similarity]
compiler/typecheck/TcRnDriver.hs [moved from compiler/typecheck/TcRnDriver.lhs with 95% similarity]
compiler/typecheck/TcRnMonad.hs [moved from compiler/typecheck/TcRnMonad.lhs with 88% similarity]
compiler/typecheck/TcRnTypes.hs [moved from compiler/typecheck/TcRnTypes.lhs with 93% similarity]
compiler/typecheck/TcRules.hs [moved from compiler/typecheck/TcRules.lhs with 98% similarity]
compiler/typecheck/TcSMonad.hs [moved from compiler/typecheck/TcSMonad.lhs with 95% similarity]
compiler/typecheck/TcSimplify.hs [moved from compiler/typecheck/TcSimplify.lhs with 98% similarity]
compiler/typecheck/TcSplice.hs [moved from compiler/typecheck/TcSplice.lhs with 94% similarity]
compiler/typecheck/TcSplice.hs-boot [moved from compiler/typecheck/TcSplice.lhs-boot with 98% similarity]
compiler/typecheck/TcTyClsDecls.hs [moved from compiler/typecheck/TcTyClsDecls.lhs with 96% similarity]
compiler/typecheck/TcTyDecls.hs [moved from compiler/typecheck/TcTyDecls.lhs with 94% similarity]
compiler/typecheck/TcType.hs [moved from compiler/typecheck/TcType.lhs with 93% similarity]
compiler/typecheck/TcType.hs-boot [moved from compiler/typecheck/TcType.lhs-boot with 70% similarity]
compiler/typecheck/TcUnify.hs [moved from compiler/typecheck/TcUnify.lhs with 95% similarity]
compiler/typecheck/TcUnify.hs-boot [moved from compiler/typecheck/TcUnify.lhs-boot with 91% similarity]
compiler/typecheck/TcValidity.hs [moved from compiler/typecheck/TcValidity.lhs with 92% similarity]

similarity index 88%
rename from compiler/typecheck/FamInst.lhs
rename to compiler/typecheck/FamInst.hs
index 08b7e9d..3a16ff0 100644 (file)
@@ -1,6 +1,5 @@
-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}
-
similarity index 94%
rename from compiler/typecheck/FunDeps.lhs
rename to compiler/typecheck/FunDeps.hs
index e636d5b..65767fa 100644 (file)
@@ -1,13 +1,13 @@
-%
-(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}
-
-
-
similarity index 88%
rename from compiler/typecheck/Inst.lhs
rename to compiler/typecheck/Inst.hs
index c737d62..a059c50 100644 (file)
@@ -1,11 +1,11 @@
-%
-(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}
similarity index 92%
rename from compiler/typecheck/TcAnnotations.lhs
rename to compiler/typecheck/TcAnnotations.hs
index cbd19cf..ca04569 100644 (file)
@@ -1,10 +1,10 @@
-%
-(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
similarity index 86%
rename from compiler/typecheck/TcArrows.lhs
rename to compiler/typecheck/TcArrows.hs
index a879e16..f1546b4 100644 (file)
@@ -1,10 +1,10 @@
-%
-(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}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Commands
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
--- See Note [Arrow overview]      
-type CmdType    = (CmdArgType, TcTauType)    -- cmd_type 
+-- See Note [Arrow overview]
+type CmdType    = (CmdArgType, TcTauType)    -- cmd_type
 type CmdArgType = TcTauType                  -- carg_type, a nested tuple
 
 data CmdEnv
@@ -114,7 +113,7 @@ mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
 mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
 
 ---------------------------------------
-tcCmdTop :: CmdEnv 
+tcCmdTop :: CmdEnv
          -> LHsCmdTop Name
          -> CmdType
          -> TcM (LHsCmdTop TcId)
@@ -145,7 +144,7 @@ tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty
 
 tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)
   = addErrCtxt (cmdCtxt in_cmd) $ do
-      (scrut', scrut_ty) <- tcInferRho scrut 
+      (scrut', scrut_ty) <- tcInferRho scrut
       matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
       return (HsCmdCase scrut' matches')
   where
@@ -206,8 +205,8 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
         ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) }
   where
        -- Before type-checking f, use the environment of the enclosing
-       -- proc for the (-<) case.  
-       -- Local bindings, inside the enclosing proc, are not in scope 
+       -- proc for the (-<) case.
+       -- Local bindings, inside the enclosing proc, are not in scope
        -- inside f.  In the higher-order case (-<<), they are.
     select_arrow_scope tc = case ho_app of
         HsHigherOrderApp -> tc
@@ -235,7 +234,7 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
 -- ------------------------------
 -- D;G |-a (\x.cmd) : (t,stk) --> res
 
-tc_cmd env 
+tc_cmd env
        (HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))], mg_origin = origin }))
        (cmd_stk, res_ty)
   = addErrCtxt (pprMatchInCtxt match_ctxt match)        $
@@ -271,7 +270,7 @@ tc_cmd env
 
 tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty)
   = do  { co <- unifyType unitTy cmd_stk  -- Expecting empty argument stack
-        ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty 
+        ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
         ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) }
 
 
@@ -289,7 +288,7 @@ tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty)
 --      ----------------------------------------------
 --      D; G |-a  (| e c1 ... cn |)  :  stk --> t
 
-tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty)    
+tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
         ; let e_ty = mkForAllTy alphaTyVar $   -- We use alphaTyVar for 'w'
@@ -313,27 +312,26 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty)
 -- This is where expressions that aren't commands get rejected
 
 tc_cmd _ cmd _
-  = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), 
+  = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd),
                       ptext (sLit "was found where an arrow command was expected")])
 
 
 matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
-matchExpectedCmdArgs 0 ty 
+matchExpectedCmdArgs 0 ty
   = return (mkTcNomReflCo ty, [], ty)
 matchExpectedCmdArgs n ty
-  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty  
+  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty
        ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2
        ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Stmts
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 --------------------------------
 --      Mdo-notation
 -- The distinctive features here are
@@ -369,7 +367,7 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
                    zipWithM tcCheckId tup_names tup_elt_tys
 
         ; thing <- thing_inside res_ty
-                -- NB:  The rec_ids for the recursive things 
+                -- NB:  The rec_ids for the recursive things
                 --      already scope over this part. This binding may shadow
                 --      some of them with polymorphic things with the same Name
                 --      (see note [RecStmt] in HsExpr)
@@ -396,32 +394,28 @@ tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType)
 tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
                         ; rhs' <- tcCmd env rhs (unitTy, ty)
                         ; return (rhs', ty) }
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Helpers
-%*                                                                      *
-%************************************************************************
-
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkPairTy :: Type -> Type -> Type
 mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
 
 arrowTyConKind :: Kind          --  *->*->*
 arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Errors
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 cmdCtxt :: HsCmd Name -> SDoc
 cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd
-\end{code}
similarity index 97%
rename from compiler/typecheck/TcBinds.lhs
rename to compiler/typecheck/TcBinds.hs
index 05fed32..79f630e 100644 (file)
@@ -1,10 +1,10 @@
-%
-(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
+
 \section[TcBinds]{TcBinds}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
 
 module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
@@ -62,14 +62,13 @@ import Control.Monad
 import Data.List (partition)
 
 #include "HsVersions.h"
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Type-checking bindings}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
 it needs to know something about the {\em usage} of the things bound,
@@ -154,8 +153,8 @@ Then we get
                                  fm = \ys:[a] -> ...fm...
                                in
                                fm
+-}
 
-\begin{code}
 tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
 -- The TcGblEnv contains the new tcg_binds and tcg_spects
 -- The TcLclEnv has an extended type envt for the new bindings
@@ -257,9 +256,7 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
         Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcSymCo $ mkTcUnbranchedAxInstCo Representational ax [x,ty]
         Nothing       -> panic "The dictionary for `IP` is not a newtype?"
 
-
-\end{code}
-
+{-
 Note [Implicit parameter untouchables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We add the type variables in the types of the implicit parameters
@@ -296,9 +293,8 @@ and will give a 'wrongThingErr' as a result.  But the lookup of A won't fail.
 
 The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in
 tcTyVar, doesn't look inside the TcTyThing.
+-}
 
-
-\begin{code}
 tcValBinds :: TopLevelFlag
            -> [(RecFlag, LHsBinds Name)] -> [LSig Name]
            -> TcM thing
@@ -771,8 +767,8 @@ completeTheta inferred_theta
                       <+> pprTheta inferred_diff
               , if suppress_hint then empty else pts_hint
               , typeSigCtxt (idName poly_id) sig ]
-\end{code}
 
+{-
 Note [Validity of inferred types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We need to check inferred type for validity, in case it uses language
@@ -829,9 +825,8 @@ Notice that the impedence matcher may do defaulting.  See Trac #7173.
 It also cleverly does an ambiguity check; for example, rejecting
    f :: F a -> a
 where F is a non-injective type function.
+-}
 
-
-\begin{code}
 type PragFun = Name -> [LSig Name]
 
 mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
@@ -1069,8 +1064,8 @@ recoveryCode binder_names sig_fn
 
 forall_a_a :: TcType
 forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
-\end{code}
 
+{-
 Note [SPECIALISE pragmas]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 There is no point in a SPECIALISE pragma for a non-overloaded function:
@@ -1092,11 +1087,11 @@ When (!:) is specialised it becomes non-recursive, and can usefully
 be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
 for a non-overloaded function.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{tcMonoBind}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
 The signatures have been dealt with already.
@@ -1122,8 +1117,8 @@ Note that
 should not typecheck because
        case id of { (f :: forall a. a->a) -> f }
 will not typecheck.
+-}
 
-\begin{code}
 tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes
                         -- i.e. the binders are mentioned in their RHSs, and
                         --      we are not rescued by a type signature
@@ -1272,15 +1267,13 @@ getMonoBindInfo tc_binds
   where
     get_info (TcFunBind info _ _ _)  rest = info : rest
     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
-\end{code}
-
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Signatures
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Type signatures are tricky.  See Note [Signature skolems] in TcType
 
@@ -1358,8 +1351,8 @@ If a type signaure is wrong, fail immediately:
 ToDo: this means we fall over if any type sig
 is wrong (eg at the top level of the module),
 which is over-conservative
+-}
 
-\begin{code}
 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun, [TcTyVar])
 tcTySigs hs_sigs
   = checkNoErrs $   -- See Note [Fail eagerly on bad signatures]
@@ -1603,19 +1596,18 @@ strictBindErr flavour unlifted_bndrs binds
   where
     msg | unlifted_bndrs = ptext (sLit "bindings for unlifted types")
         | otherwise      = ptext (sLit "bang-pattern or unboxed-tuple bindings")
-\end{code}
 
+{-
 Note [Binding scoped type variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection[TcBinds-errors]{Error contexts and messages}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-
-\begin{code}
 -- This one is called on LHS, when pat and grhss are both Name
 -- and on RHS, when pat is TcId and grhss is still Name
 patMonoBindsCtxt :: (OutputableBndr id, Outputable body) => LPat id -> GRHSs Name body -> SDoc
@@ -1631,5 +1623,3 @@ typeSigCtxt name (TcSigInfo { sig_id = _id, sig_tvs = tvs
   = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name) <> colon
         , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts)
                   (mkSigmaTy (map snd tvs) theta tau)) ]
-
-\end{code}
similarity index 93%
rename from compiler/typecheck/TcCanonical.lhs
rename to compiler/typecheck/TcCanonical.hs
index f6d9d20..dc782c1 100644 (file)
@@ -1,4 +1,3 @@
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcCanonical( canonicalize ) where
@@ -25,14 +24,13 @@ import VarSet
 
 import Util
 import BasicTypes
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
-%*                      The Canonicaliser                               *
-%*                                                                      *
-%************************************************************************
+{-
+************************************************************************
+*                                                                      *
+*                      The Canonicaliser                               *
+*                                                                      *
+************************************************************************
 
 Note [Canonicalization]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -117,10 +115,7 @@ not rewritten by subst, they remain canonical and hence we will not
 attempt to solve them from the EvBinds. If on the other hand they did
 get rewritten and are now non-canonical they will still not match the
 EvBinds, so we are again good.
-
-
-
-\begin{code}
+-}
 
 -- Top-level canonicalization
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -162,16 +157,15 @@ canEvNC ev
       EqPred ty1 ty2    -> traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)   >> canEqNC    ev ty1 ty2
       TuplePred tys     -> traceTcS "canEvNC:tup" (ppr tys)             >> canTuple   ev tys
       IrredPred {}      -> traceTcS "canEvNC:irred" (ppr (ctEvPred ev)) >> canIrred   ev
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
-%*                      Tuple Canonicalization
-%*                                                                      *
-%************************************************************************
+{-
+************************************************************************
+*                                                                      *
+*                      Tuple Canonicalization
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 canTuple :: CtEvidence -> [PredType] -> TcS (StopOrContinue Ct)
 canTuple ev tys
   = do { traceTcS "can_pred" (text "TuplePred!")
@@ -179,15 +173,15 @@ canTuple ev tys
              xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..]
        ; xCtEvidence ev (XEvTerm tys xcomp xdecomp)
        ; stopWith ev "Decomposed tuple constraint" }
-\end{code}
 
-%************************************************************************
-%*                                                                      *
-%*                      Class Canonicalization
-%*                                                                      *
-%************************************************************************
+{-
+************************************************************************
+*                                                                      *
+*                      Class Canonicalization
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 canClass, canClassNC
    :: CtEvidence
    -> Class -> [Type] -> TcS (StopOrContinue Ct)
@@ -224,8 +218,8 @@ emitSuperclasses ct@(CDictCan { cc_ev = ev , cc_tyargs = xis_new, cc_class = cls
       -- superclasses to be executed if deferred to runtime!
       ; continueWith ct }
 emitSuperclasses _ = panic "emit_superclasses of non-class!"
-\end{code}
 
+{-
 Note [Adding superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Since dictionaries are canonicalized only once in their lifetime, the
@@ -288,8 +282,8 @@ If we were to be adding the superclasses during simplification we'd get:
 While looks exactly like our original constraint. If we add the superclass again we'd loop.
 By adding superclasses definitely only once, during canonicalisation, this situation can't
 happen.
+-}
 
-\begin{code}
 newSCWorkFromFlavored :: CtEvidence -> Class -> [Xi] -> TcS ()
 -- Returns superclasses, see Note [Adding superclasses]
 newSCWorkFromFlavored flavor cls xis
@@ -325,17 +319,15 @@ is_improvement_pty ty = go (classifyPredType ty)
                             where (_,fundeps) = classTvsFds cls
     go (TuplePred ts)       = any is_improvement_pty ts
     go (IrredPred {})       = True -- Might have equalities after reduction?
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
-%*                      Irreducibles canonicalization
-%*                                                                      *
-%************************************************************************
+{-
+************************************************************************
+*                                                                      *
+*                      Irreducibles canonicalization
+*                                                                      *
+************************************************************************
+-}
 
-
-\begin{code}
 canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
 -- Precondition: ty not a tuple and no other evidence form
 canIrred old_ev
@@ -369,26 +361,26 @@ canHole ev occ hole_sort
                                                                , cc_hole = hole_sort })
                                      ; stopWith new_ev "Emit insoluble hole" }
            Stop ev s -> return (Stop ev s) } -- Found a cached copy; won't happen
-\end{code}
 
-%************************************************************************
-%*                                                                      *
-%*        Equalities
-%*                                                                      *
-%************************************************************************
+{-
+************************************************************************
+*                                                                      *
+*        Equalities
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 canEqNC :: CtEvidence -> Type -> Type -> TcS (StopOrContinue Ct)
 canEqNC ev ty1 ty2 = can_eq_nc ev ty1 ty1 ty2 ty2
 
-can_eq_nc, can_eq_nc' 
-   :: CtEvidence 
-   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp 
-   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp 
+can_eq_nc, can_eq_nc'
+   :: CtEvidence
+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
    -> TcS (StopOrContinue Ct)
 
 can_eq_nc ev ty1 ps_ty1 ty2 ps_ty2
-  = do { traceTcS "can_eq_nc" $ 
+  = do { traceTcS "can_eq_nc" $
          vcat [ ppr ev, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]
        ; can_eq_nc' ev ty1 ps_ty1 ty2 ps_ty2 }
 
@@ -422,16 +414,16 @@ can_eq_nc' ev ty1@(LitTy l1) _ (LitTy l2) _
          setEvBind (ctev_evar ev) (EvCoercion (mkTcNomReflCo ty1))
        ; stopWith ev "Equal LitTy" }
 
--- Decomposable type constructor applications 
+-- Decomposable type constructor applications
 -- Synonyms and type functions (which are not decomposable)
--- have already been dealt with 
+-- have already been dealt with
 can_eq_nc' ev (TyConApp tc1 tys1) _ (TyConApp tc2 tys2) _
   | isDecomposableTyCon tc1
   , isDecomposableTyCon tc2
   = canDecomposableTyConApp ev tc1 tys1 tc2 tys2
 
 can_eq_nc' ev (TyConApp tc1 _) ps_ty1 (FunTy {}) ps_ty2
-  | isDecomposableTyCon tc1 
+  | isDecomposableTyCon tc1
       -- The guard is important
       -- e.g.  (x -> y) ~ (F x y) where F has arity 1
       --       should not fail, but get the app/app case
@@ -441,7 +433,7 @@ can_eq_nc' ev (FunTy s1 t1) _ (FunTy s2 t2) _
   = canDecomposableTyConAppOK ev funTyCon [s1,t1] [s2,t2]
 
 can_eq_nc' ev (FunTy {}) ps_ty1 (TyConApp tc2 _) ps_ty2
-  | isDecomposableTyCon tc2 
+  | isDecomposableTyCon tc2
   = canEqFailure ev ps_ty1 ps_ty2
 
 can_eq_nc' ev s1@(ForAllTy {}) _ s2@(ForAllTy {}) _
@@ -503,12 +495,12 @@ can_eq_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2
           else
      do { (xi_t1, co_t1) <- flatten fmode t1
              -- We flatten t1 as well so that (xi_s1 xi_t1) is well-kinded
-             -- If we form (xi_s1 t1) that might (appear) ill-kinded, 
+             -- If we form (xi_s1 t1) that might (appear) ill-kinded,
              -- and then crash in a call to typeKind
         ; let xi1 = mkAppTy xi_s1 xi_t1
               co1 = mkTcAppCo co_s1 co_t1
         ; traceTcS "can_eq_app 3" $ vcat [ ppr ev, ppr xi1, ppr co1 ]
-        ; mb_ct <- rewriteEqEvidence ev swapped xi1 ps_ty2 
+        ; mb_ct <- rewriteEqEvidence ev swapped xi1 ps_ty2
                                      co1 (mkTcNomReflCo ps_ty2)
         ; traceTcS "can_eq_app 4" $ vcat [ ppr ev, ppr xi1, ppr co1 ]
         ; case mb_ct of
@@ -526,7 +518,7 @@ can_eq_flat_app ev swapped s1 t1 ps_ty1 ty2 ps_ty2
   | otherwise
   = unSwap swapped (canEqFailure ev) ps_ty1 ps_ty2
   where
-    decompose_it (s1,t1) (s2,t2) 
+    decompose_it (s1,t1) (s2,t2)
       = do { let xevcomp [x,y] = EvCoercion (mkTcAppCo (evTermCoercion x) (evTermCoercion y))
                  xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen
                  xevdecomp x = let xco = evTermCoercion x
@@ -571,18 +563,18 @@ canEqFailure ev ty1 ty2
            ContinueWith new_ev -> do { emitInsoluble (mkNonCanonical new_ev)
                                      ; stopWith new_ev "Definitely not equal" }
            Stop ev s -> pprPanic "canEqFailure" (s $$ ppr ev $$ ppr ty1 $$ ppr ty2) }
-\end{code}
 
+{-
 Note [Canonicalising type applications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Given (s1 t1) ~ ty2, how should we proceed?
-The simple things is to see if ty2 is of form (s2 t2), and 
+The simple things is to see if ty2 is of form (s2 t2), and
 decompose.  By this time s1 and s2 can't be saturated type
-function applications, because those have been dealt with 
-by an earlier equation in can_eq_nc, so it is always sound to 
+function applications, because those have been dealt with
+by an earlier equation in can_eq_nc, so it is always sound to
 decompose.
 
-However, over-eager decomposition gives bad error messages 
+However, over-eager decomposition gives bad error messages
 for things like
    a b ~ Maybe c
    e f ~ p -> q
@@ -590,14 +582,14 @@ Suppose (in the first example) we already know a~Array.  Then if we
 decompose the application eagerly, yielding
    a ~ Maybe
    b ~ c
-we get an error        "Can't match Array ~ Maybe", 
+we get an error        "Can't match Array ~ Maybe",
 but we'd prefer to get "Can't match Array b ~ Maybe c".
 
 So instead can_eq_app flattens s1.  If flattening does something, it
-rewrites, and goes round can_eq_nc again.  If flattening 
+rewrites, and goes round can_eq_nc again.  If flattening
 does nothing, then (at least with our present state of knowledge)
 we can only decompose, and that is what can_eq_flat_app attempts
-to do. 
+to do.
 
 Note [Make sure that insolubles are fully rewritten]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -630,15 +622,14 @@ As this point we have an insoluble constraint, like Int~Bool.
    case we don't want to get two (or more) error messages by
    generating two (or more) insoluble fundep constraints from the same
    class constraint.
+-}
 
-
-\begin{code}
-canCFunEqCan :: CtEvidence 
+canCFunEqCan :: CtEvidence
              -> TyCon -> [TcType]   -- LHS
              -> TcTyVar             -- RHS
              -> TcS (StopOrContinue Ct)
--- ^ Canonicalise a CFunEqCan.  We know that 
---     the arg types are already flat, 
+-- ^ Canonicalise a CFunEqCan.  We know that
+--     the arg types are already flat,
 -- and the RHS is a fsk, which we must *not* substitute.
 -- So just substitute in the LHS
 canCFunEqCan ev fn tys fsk
@@ -695,7 +686,7 @@ canEqTyVar2 :: DynFlags
             -> TcType       -- nrhs
             -> TcCoercion   -- nrhs ~ orhs
             -> TcS (StopOrContinue Ct)
--- LHS is an inert type variable, 
+-- LHS is an inert type variable,
 -- and RHS is fully rewritten, but with type synonyms
 -- preserved as much as possible
 
@@ -713,7 +704,7 @@ canEqTyVar2 dflags ev swapped tv1 xi2 co2
              k2 = typeKind xi2'
        ; case mb of
             Stop ev s -> return (Stop ev s)
-            ContinueWith new_ev 
+            ContinueWith new_ev
                 | k2 `isSubKind` k1
                 -- Establish CTyEqCan kind invariant
                 -- Reorientation has done its best, but the kinds might
@@ -854,8 +845,8 @@ incompatibleKind new_ev s1 k1 s2 k2   -- See Note [Equalities with incompatible
   where
     loc = ctEvLoc new_ev
     kind_co_loc = setCtLocOrigin loc (KindEqOrigin s1 s2 (ctLocOrigin loc))
-\end{code}
 
+{-
 Note [Canonical orientation for tyvar/tyvar equality constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we have a ~ b where both 'a' and 'b' are TcTyVars, which way
@@ -1033,4 +1024,4 @@ not contain the variable from the LHS.  In particular, given
 we first try expanding each of the ti to types which no longer contain
 a.  If this turns out to be impossible, we next try expanding F
 itself, and so on.  See Note [Occurs check expansion] in TcType
-
+-}
similarity index 93%
rename from compiler/typecheck/TcClassDcl.lhs
rename to compiler/typecheck/TcClassDcl.hs
index 769167f..719c2f3 100644 (file)
@@ -1,11 +1,11 @@
-%
-(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
+
 
 Typechecking class declarations
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcClassDcl ( tcClassSigs, tcClassDecl2,
@@ -45,9 +45,8 @@ import BooleanFormula
 import Util
 
 import Control.Monad
-\end{code}
-
 
+{-
 Dictionary handling
 ~~~~~~~~~~~~~~~~~~~
 Every class implicitly declares a new data type, corresponding to dictionaries
@@ -81,13 +80,13 @@ Now DictTy in Type is just a form of type synomym:
 Death to "ExpandingDicts".
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Type-checking the class op signatures
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcClassSigs :: Name                  -- Name of the class
             -> [LSig Name]
             -> LHsBinds Name
@@ -131,16 +130,15 @@ tcClassSigs clas sigs def_methods
     tc_gen_sig (op_names, gen_hs_ty)
       = do { gen_op_ty <- tcClassSigType gen_hs_ty
            ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Class Declarations
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcClassDecl2 :: LTyClDecl Name          -- The class declaration
              -> TcM (LHsBinds Id)
 
@@ -282,9 +280,7 @@ tcClassMinimalDef _clas sigs op_info
     defMindef = mkAnd [ mkVar name
                       | (name, NoDM, _) <- op_info
                       , not (startsWithUnderscore (getOccName name)) ]
-\end{code}
 
-\begin{code}
 instantiateMethod :: Class -> Id -> [TcType] -> TcType
 -- Take a class operation, say
 --      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
@@ -343,8 +339,8 @@ findMinimalDef = firstJusts . map toMinimalDef
     toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
     toMinimalDef (L _ (MinimalSig bf)) = Just (fmap unLoc bf)
     toMinimalDef _                     = Nothing
-\end{code}
 
+{-
 Note [Polymorphic methods]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -372,13 +368,13 @@ and wrap it in a let, thus
 This makes the error messages right.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Error messages
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcMkDeclCtxt :: TyClDecl Name -> SDoc
 tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
                       ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
@@ -427,4 +423,3 @@ warningMinimalDefIncomplete mindef
   = vcat [ ptext (sLit "The MINIMAL pragma does not require:")
          , nest 2 (pprBooleanFormulaNice mindef)
          , ptext (sLit "but there is no default implementation.") ]
-\end{code}
similarity index 96%
rename from compiler/typecheck/TcDefaults.lhs
rename to compiler/typecheck/TcDefaults.hs
index 0153e5a..c9ce0f6 100644 (file)
@@ -1,10 +1,10 @@
-%
-(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[TcDefaults]{Typechecking \tr{default} declarations}
+-}
 
-\begin{code}
 module TcDefaults ( tcDefaults ) where
 
 import HsSyn
@@ -21,9 +21,7 @@ import SrcLoc
 import Data.Maybe
 import Outputable
 import FastString
-\end{code}
 
-\begin{code}
 tcDefaults :: [LDefaultDecl Name]
            -> TcM (Maybe [Type])    -- Defaulting types to heave
                                     -- into Tc monad for later use
@@ -98,5 +96,3 @@ badDefaultTy :: Type -> [Class] -> SDoc
 badDefaultTy ty deflt_clss
   = hang (ptext (sLit "The default type") <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
        2 (foldr1 (\a b -> a <+> ptext (sLit "or") <+> b) (map (quotes. ppr) deflt_clss))
-\end{code}
-
similarity index 97%
rename from compiler/typecheck/TcDeriv.lhs
rename to compiler/typecheck/TcDeriv.hs
index 76b8423..d52a721 100644 (file)
@@ -1,11 +1,11 @@
-%
-(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
+
 
 Handles @deriving@ clauses on @data@ declarations.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcDeriv ( tcDeriving ) where
@@ -64,13 +64,13 @@ import Pair
 
 import Control.Monad
 import Data.List
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Overview
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Overall plan
 ~~~~~~~~~~~~
@@ -80,9 +80,8 @@ Overall plan
 2.  Infer the missing contexts for the InferTheta's
 
 3.  Add the derived bindings, generating InstInfos
+-}
 
-
-\begin{code}
 -- DerivSpec is purely  local to this module
 data DerivSpec theta = DS { ds_loc     :: SrcSpan
                           , ds_name    :: Name           -- DFun name
@@ -108,8 +107,8 @@ data DerivSpec theta = DS { ds_loc     :: SrcSpan
 
         -- ds_newtype = True  <=> Generalised Newtype Deriving (GND)
         --              False <=> Vanilla deriving
-\end{code}
 
+{-
 Example:
 
      newtype instance T [a] = MkT (Tree a) deriving( C s )
@@ -120,8 +119,8 @@ Example:
      DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
         , ds_tc = :RTList, ds_tc_args = [a]
         , ds_newtype = True }
+-}
 
-\begin{code}
 type DerivContext = Maybe ThetaType
    -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
    -- Just theta <=> Standalone deriving: context supplied by programmer
@@ -185,9 +184,8 @@ instance Outputable EarlyDerivSpec where
 
 instance Outputable PredOrigin where
   ppr (PredOrigin ty _) = ppr ty -- The origin is not so interesting when debugging
-\end{code}
-
 
+{-
 Inferring missing contexts
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -342,13 +340,13 @@ See Trac #3221.  Consider
 Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
 both of them.  So we gather defs/uses from deriving just like anything else.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
             -> [LInstDecl Name]  -- All instance declarations
             -> [LDerivDecl Name] -- All stand-alone deriving declarations
@@ -490,8 +488,8 @@ renameDeriv is_boot inst_infos bagBinds
                                           , ib_extensions = exts
                                           , ib_derived = sa }
               ; return (inst_info { iBinds = binds' }, fvs) }
-\end{code}
 
+{-
 Note [Newtype deriving and unused constructors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this (see Trac #1954):
@@ -511,15 +509,15 @@ So we want to signal a user of the data constructor 'MkP'.
 This is the reason behind the (Maybe Name) part of the return type
 of genInst.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 From HsSyn to DerivSpec
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
+-}
 
-\begin{code}
 makeDerivSpecs :: Bool
                -> [LTyClDecl Name]
                -> [LInstDecl Name]
@@ -606,8 +604,8 @@ deriveFamInst decl@(DataFamInstDecl
            concatMapM (deriveTyData True tvs' fam_tc pats') preds }
 
 deriveFamInst _ = return []
-\end{code}
 
+{-
 Note [Finding the LHS patterns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When kind polymorphism is in play, we need to be careful.  Here is
@@ -626,9 +624,8 @@ So CmpInterval is kind-polymorphic, but the data instance is not
 Hence, when deriving the type patterns in deriveFamInst, we must kind
 check the RHS (the data constructor 'Starting c') as well as the LHS,
 so that we correctly see the instantiation to *.
+-}
 
-
-\begin{code}
 ------------------------------------------------------------------
 deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec]
 -- Standalone deriving declarations
@@ -809,8 +806,8 @@ derivePolyKindedTypeable is_instance cls cls_tys _tvs tc tc_args
                           (classArgsErr cls cls_tys)
 
        ; mkPolyKindedTypeableEqn cls tc }
-\end{code}
 
+{-
 Note [Unify kinds in deriving]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider (Trac #8534)
@@ -865,9 +862,8 @@ When deriving Functor for P, we unify k to *, but we then want
 an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
 and similarly for C.  Notice the modified kind of x, both at binding
 and occurrence sites.
+-}
 
-
-\begin{code}
 mkEqnHelp :: Maybe OverlapMode
           -> [TyVar]
           -> Class -> [Type]
@@ -921,8 +917,8 @@ mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta
                          tycon tc_args rep_tc rep_tc_args mtheta }
   where
      bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
-\end{code}
 
+{-
 Note [Looking up family instances for deriving]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 tcLookupFamInstExact is an auxiliary lookup wrapper which requires
@@ -982,13 +978,13 @@ write it out
 See Note [Eta reduction for data family axioms] in TcInstDcls.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Deriving data types
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkDataTypeEqn :: DynFlags
               -> Maybe OverlapMode
               -> [Var]                  -- Universally quantified type variables in the instance
@@ -1159,8 +1155,8 @@ inferConstraints cls inst_tys rep_tc rep_tc_args
       = [mkPredOrigin DerivOrigin (mkClassPred cls [ty]) | ty <- rep_tc_args]
       | otherwise
       = []
-\end{code}
 
+{-
 Note [Getting base classes]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Functor and Typeable are defined in package 'base', and that is not available
@@ -1210,8 +1206,8 @@ GHC uses the same heuristic for figuring out the class context that it uses for
 Eq in the case of *-kinded classes, and for Functor in the case of
 * -> *-kinded classes. That may not be optimal or even wrong. But in such
 cases, standalone deriving can still be used.
+-}
 
-\begin{code}
 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism
@@ -1478,8 +1474,8 @@ new_dfun_name clas tycon        -- Just a simple wrapper
 
 badCon :: DataCon -> SDoc -> SDoc
 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
-\end{code}
 
+{-
 Note [Check that the type variable is truly universal]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For Functor, Foldable, Traversable, we must check that the *last argument*
@@ -1527,13 +1523,13 @@ a context for the Data instances:
         instance Typable a => Data (T a) where ...
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Deriving newtypes
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [Var] -> Class
              -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
              -> DerivContext
@@ -1706,8 +1702,8 @@ mkNewTypeEqn dflags overlap_mode tvs
                   , ppUnless ats_ok ats_msg ]
         eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
         ats_msg   = ptext (sLit "the class has associated types")
-\end{code}
 
+{-
 Note [Recursive newtypes]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Newtype deriving works fine, even if the newtype is recursive.
@@ -1738,11 +1734,11 @@ is because the derived instance uses `coerce`, which must satisfy its
 `Coercible` constraint. This is different than other deriving scenarios,
 where we're sure that the resulting instance will type-check.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
 terms, which is the final correct RHS for the corresponding original
@@ -1757,8 +1753,8 @@ The (k,TyVarTy tv) pairs in a solution are canonically
 ordered by sorting on type varible, tv, (major key) and then class, k,
 (minor key)
 \end{itemize}
+-}
 
-\begin{code}
 inferInstanceContexts :: [DerivSpec ThetaOrigin] -> TcM [DerivSpec ThetaType]
 
 inferInstanceContexts [] = return []
@@ -1835,16 +1831,15 @@ extendLocalInstEnv dfuns thing_inside
       ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
              env'      = env { tcg_inst_env = inst_env' }
       ; setGblEnv env' thing_inside }
-\end{code}
-
 
+{-
 ***********************************************************************************
 *                                                                                 *
 *            Simplify derived constraints
 *                                                                                 *
 ***********************************************************************************
+-}
 
-\begin{code}
 simplifyDeriv :: PredType
               -> [TyVar]
               -> ThetaOrigin      -- Wanted
@@ -1890,8 +1885,8 @@ simplifyDeriv pred tvs theta
 
        ; let min_theta = mkMinimalBySCs (bagToList good)
        ; return (substTheta subst_skol min_theta) }
-\end{code}
 
+{-
 Note [Overlap and deriving]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider some overlapping instances:
@@ -1969,11 +1964,11 @@ The bottom line
 Allow constraints which consist only of type variables, with no repeats.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 After all the trouble to figure out the required context for the
 derived instance declarations, all that's left is to chug along to
@@ -2030,8 +2025,8 @@ possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
 the renamer.  What a great hack!
 \end{itemize}
+-}
 
-\begin{code}
 -- Generate the InstInfo for the required instance paired with the
 --   *representation* tycon for that instance,
 -- plus any auxiliary bindings required
@@ -2113,8 +2108,8 @@ getDataConFixityFun tc
   where
     name = tyConName tc
     doc = ptext (sLit "Data con fixities for") <+> ppr name
-\end{code}
 
+{-
 Note [Bindings for Generalised Newtype Deriving]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -2136,13 +2131,13 @@ representation type.
 See the paper "Safe zero-cost coercions for Hsakell".
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 derivingNullaryErr :: MsgDoc
 derivingNullaryErr = ptext (sLit "Cannot derive instances for nullary classes")
 
@@ -2182,4 +2177,3 @@ standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"
 derivInstCtxt :: PredType -> MsgDoc
 derivInstCtxt pred
   = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
-\end{code}
similarity index 89%
rename from compiler/typecheck/TcEnv.lhs
rename to compiler/typecheck/TcEnv.hs
index c4a3f2f..9414dcb 100644 (file)
@@ -1,8 +1,5 @@
-%
-% (c) The University of Glasgow 2006
-%
+-- (c) The University of Glasgow 2006
 
-\begin{code}
 {-# LANGUAGE CPP, FlexibleInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -11,28 +8,28 @@ module TcEnv(
 
         -- Instance environment, and InstInfo type
         InstInfo(..), iDFunId, pprInstInfoDetails,
-        simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, 
+        simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
         InstBindings(..),
 
         -- Global environment
         tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
         tcExtendGlobalValEnv,
-        tcLookupLocatedGlobal, tcLookupGlobal, 
+        tcLookupLocatedGlobal, tcLookupGlobal,
         tcLookupField, tcLookupTyCon, tcLookupClass,
         tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
         tcLookupLocatedClass, tcLookupAxiom,
-        
+
         -- Local environment
         tcExtendKindEnv, tcExtendKindEnv2,
-        tcExtendTyVarEnv, tcExtendTyVarEnv2, 
+        tcExtendTyVarEnv, tcExtendTyVarEnv2,
         tcExtendLetEnv,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendIdEnv3,
         tcExtendIdBndrs, tcExtendGhciIdEnv,
 
-        tcLookup, tcLookupLocated, tcLookupLocalIds, 
-        tcLookupId, tcLookupTyVar, 
-        tcLookupLcl_maybe, 
+        tcLookup, tcLookupLocated, tcLookupLocalIds,
+        tcLookupId, tcLookupTyVar,
+        tcLookupLcl_maybe,
         getScopedTyVarBinds, getInLocalScope,
         wrongThingErr, pprBinders,
 
@@ -51,7 +48,7 @@ module TcEnv(
         tcGetGlobalTyVars, zapLclTypeEnv,
 
         -- Template Haskell stuff
-        checkWellStaged, tcMetaTy, thLevel, 
+        checkWellStaged, tcMetaTy, thLevel,
         topIdLvl, isBrackStage,
 
         -- New Ids
@@ -67,7 +64,7 @@ import IfaceEnv
 import TcRnMonad
 import TcMType
 import TcType
-import TcIface  
+import TcIface
 import PrelNames
 import TysWiredIn
 import Id
@@ -99,20 +96,19 @@ import Util
 import Maybes( MaybeErr(..) )
 import Data.IORef
 import Data.List
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
-%*                      tcLookupGlobal                                  *
-%*                                                                      *
-%************************************************************************
+{-
+************************************************************************
+*                                                                      *
+*                      tcLookupGlobal                                  *
+*                                                                      *
+************************************************************************
 
 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
 unless you know that the SrcSpan in the monad is already set to the
 span of the Name.
+-}
 
-\begin{code}
 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
 -- c.f. IfaceEnvEnv.tcIfaceGlobal
 tcLookupLocatedGlobal name
@@ -215,14 +211,14 @@ tcLookupInstance :: Class -> [Type] -> TcM ClsInst
 tcLookupInstance cls tys
   = do { instEnv <- tcGetInstEnvs
        ; case lookupUniqueInstEnv instEnv cls tys of
-           Left err             -> failWithTc $ ptext (sLit "Couldn't match instance:") <+> err 
-           Right (inst, tys) 
+           Left err             -> failWithTc $ ptext (sLit "Couldn't match instance:") <+> err
+           Right (inst, tys)
              | uniqueTyVars tys -> return inst
              | otherwise        -> failWithTc errNotExact
        }
   where
     errNotExact = ptext (sLit "Not an exact match (i.e., some variables get instantiated)")
-    
+
     uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map extractTyVar tys)
       where
         extractTyVar (TyVarTy tv) = tv
@@ -236,23 +232,20 @@ tcGetInstEnvs = do { eps <- getEps
                    ; return (InstEnvs { ie_global  = eps_inst_env eps
                                       , ie_local   = tcg_inst_env env
                                       , ie_visible = tcg_visible_orphan_mods env }) }
-\end{code}
 
-\begin{code}
 instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
     lookupThing = tcLookupGlobal
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Extending the global environment
-%*                                                                      *
-%************************************************************************
-
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
--- Use this to update the global type env 
+-- Use this to update the global type env
 -- It updates both  * the normal tcg_type_env field
 --                  * the tcg_type_env_var field seen by interface files
 setGlobalTypeEnv tcg_env new_type_env
@@ -285,7 +278,7 @@ tcExtendGlobalEnv things thing_inside
 
 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
   -- Same deal as tcExtendGlobalEnv, but for Ids
-tcExtendGlobalValEnv ids thing_inside 
+tcExtendGlobalValEnv ids thing_inside
   = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
 
 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
@@ -293,19 +286,18 @@ tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
 -- Just like tcExtendGlobalEnv, except the argument is a list of pairs
 tcExtendRecEnv gbl_stuff thing_inside
  = do  { tcg_env <- getGblEnv
-       ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff 
+       ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
        ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
        ; setGblEnv tcg_env' thing_inside }
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{The local environment}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcLookupLocated :: Located Name -> TcM TcTyThing
 tcLookupLocated = addLocM tcLookup
 
@@ -329,9 +321,9 @@ tcLookupTyVar name
            _           -> pprPanic "tcLookupTyVar" (ppr name) }
 
 tcLookupId :: Name -> TcM Id
--- Used when we aren't interested in the binding level, nor refinement. 
+-- Used when we aren't interested in the binding level, nor refinement.
 -- The "no refinement" part means that we return the un-refined Id regardless
--- 
+--
 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
 tcLookupId name = do
     thing <- tcLookup name
@@ -343,11 +335,11 @@ tcLookupId name = do
 tcLookupLocalIds :: [Name] -> TcM [TcId]
 -- We expect the variables to all be bound, and all at
 -- the same level as the lookup.  Only used in one place...
-tcLookupLocalIds ns 
+tcLookupLocalIds ns
   = do { env <- getLclEnv
        ; return (map (lookup (tcl_env env)) ns) }
   where
-    lookup lenv name 
+    lookup lenv name
         = case lookupNameEnv lenv name of
                 Just (ATcId { tct_id = id }) ->  id
                 _ -> pprPanic "tcLookupLocalIds" (ppr name)
@@ -356,9 +348,7 @@ getInLocalScope :: TcM (Name -> Bool)
   -- Ids only
 getInLocalScope = do { lcl_env <- getLclTypeEnv
                      ; return (`elemNameEnv` lcl_env) }
-\end{code}
 
-\begin{code}
 tcExtendKindEnv2 :: [(Name, TcTyThing)] -> TcM r -> TcM r
 -- Used only during kind checking, for TcThings that are
 --      AThing or APromotionErr
@@ -404,8 +394,8 @@ getScopedTyVarBinds :: TcM [(Name, TcTyVar)]
 getScopedTyVarBinds
   = do  { lcl_env <- getLclEnv
         ; return [(name, tv) | ATyVar name tv <- nameEnvElts (tcl_env lcl_env)] }
-\end{code}
 
+{-
 Note [Initialising the type environment for GHCi]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 tcExtendGhciIdEnv extends the local type environemnt with GHCi
@@ -443,8 +433,8 @@ Note especially that
        well.  We are just shadowing them here to deal with the global tyvar
        stuff.  That's why we can simply drop the External-Name ones; they
        will be found in the global envt
+-}
 
-\begin{code}
 tcExtendGhciIdEnv :: [TyThing] -> TcM a -> TcM a
 -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
 -- See Note [Initialising the type environment for GHCi]
@@ -471,13 +461,13 @@ tcExtendLetEnv top_lvl closed ids thing_inside
           tcExtendIdBndrs [TcIdBndr id top_lvl | id <- ids] thing_inside }
 
 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
-tcExtendIdEnv ids thing_inside 
+tcExtendIdEnv ids thing_inside
   = tcExtendIdEnv2 [(idName id, id) | id <- ids] $
-    tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids] 
+    tcExtendIdBndrs [TcIdBndr id NotTopLevel | id <- ids]
     thing_inside
 
 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
-tcExtendIdEnv1 name id thing_inside 
+tcExtendIdEnv1 name id thing_inside
   = tcExtendIdEnv2 [(name,id)] $
     tcExtendIdBndrs [TcIdBndr id NotTopLevel]
     thing_inside
@@ -587,16 +577,15 @@ zapLclTypeEnv thing_inside
                            , tcl_rdr = emptyLocalRdrEnv
                            , tcl_tyvars = tvs_var }
        ; updLclEnv upd thing_inside }
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Rules}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
         -- Just pop the new rules into the EPS and envt resp
         -- All the rules come from an interface file, not source
@@ -607,16 +596,15 @@ tcExtendRules lcl_rules thing_inside
       ; let
           env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
       ; setGblEnv env' thing_inside }
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Meta level
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 checkWellStaged :: SDoc         -- What the stage check is for
                 -> ThLevel      -- Binding level (increases inside brackets)
                 -> ThLevel      -- Use stage
@@ -630,32 +618,32 @@ checkWellStaged pp_thing bind_lvl use_lvl
 
   | otherwise                   -- Badly staged
   = failWithTc $                -- E.g.  \x -> $(f x)
-    ptext (sLit "Stage error:") <+> pp_thing <+> 
+    ptext (sLit "Stage error:") <+> pp_thing <+>
         hsep   [ptext (sLit "is bound at stage") <+> ppr bind_lvl,
                 ptext (sLit "but used at stage") <+> ppr use_lvl]
 
 stageRestrictionError :: SDoc -> TcM a
 stageRestrictionError pp_thing
-  = failWithTc $ 
+  = failWithTc $
     sep [ ptext (sLit "GHC stage restriction:")
         , nest 2 (vcat [ pp_thing <+> ptext (sLit "is used in a top-level splice or annotation,")
                        , ptext (sLit "and must be imported, not defined locally")])]
 
 topIdLvl :: Id -> ThLevel
--- Globals may either be imported, or may be from an earlier "chunk" 
+-- Globals may either be imported, or may be from an earlier "chunk"
 -- (separated by declaration splices) of this module.  The former
 --  *can* be used inside a top-level splice, but the latter cannot.
 -- Hence we give the former impLevel, but the latter topLevel
 -- E.g. this is bad:
 --      x = [| foo |]
 --      $( f x )
--- By the time we are prcessing the $(f x), the binding for "x" 
+-- By the time we are prcessing the $(f x), the binding for "x"
 -- will be in the global env, not the local one.
 topIdLvl id | isLocalId id = outerLevel
             | otherwise    = impLevel
 
 tcMetaTy :: Name -> TcM Type
--- Given the name of a Template Haskell data type, 
+-- Given the name of a Template Haskell data type,
 -- return the type
 -- E.g. given the name "Expr" return the type "Expr"
 tcMetaTy tc_name = do
@@ -665,16 +653,15 @@ tcMetaTy tc_name = do
 isBrackStage :: ThStage -> Bool
 isBrackStage (Brack {}) = True
 isBrackStage _other     = False
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
-                 getDefaultTys                                                                          
-%*                                                                      *
-%************************************************************************
+{-
+************************************************************************
+*                                                                      *
+                 getDefaultTys
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcGetDefaultTys :: TcM ([Type], -- Default types
                         (Bool,  -- True <=> Use overloaded strings
                          Bool)) -- True <=> Use extended defaulting rules
@@ -682,9 +669,9 @@ tcGetDefaultTys
   = do  { dflags <- getDynFlags
         ; let ovl_strings = xopt Opt_OverloadedStrings dflags
               extended_defaults = xopt Opt_ExtendedDefaultRules dflags
-                                        -- See also Trac #1974 
+                                        -- See also Trac #1974
               flags = (ovl_strings, extended_defaults)
-    
+
         ; mb_defaults <- getDeclaredDefaultTys
         ; case mb_defaults of {
            Just tys -> return (tys, flags) ;
@@ -703,13 +690,13 @@ tcGetDefaultTys
   where
     opt_deflt True  ty = [ty]
     opt_deflt False _  = []
-\end{code}
 
+{-
 Note [Default unitTy]
 ~~~~~~~~~~~~~~~~~~~~~
 In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
 try when defaulting.  This has very little real impact, except in the following case.
-Consider: 
+Consider:
         Text.Printf.printf "hello"
 This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
 want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
@@ -718,11 +705,11 @@ and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
 () to the list of defaulting types.  See Trac #1200.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{The InstInfo type}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The InstInfo type summarises the information in an instance declaration
 
@@ -733,8 +720,8 @@ But local instance decls includes
         - derived ones
         - generic ones
 as well as explicit user written ones.
+-}
 
-\begin{code}
 data InstInfo a
   = InstInfo {
       iSpec   :: ClsInst,        -- Includes the dfun id.  Its forall'd type
@@ -787,27 +774,27 @@ simpleInstInfoTyCon :: InstInfo a -> TyCon
   -- Gets the type constructor for a simple instance declaration,
   -- i.e. one of the form       instance (...) => C (T a b c) where ...
 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
-\end{code}
 
+{-
 Make a name for the dict fun for an instance decl.  It's an *external*
 name, like otber top-level names, and hence must be made with newGlobalBinder.
+-}
 
-\begin{code}
 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
 newDFunName clas tys loc
   = do  { is_boot <- tcIsHsBootOrSig
         ; mod     <- getModule
-        ; let info_string = occNameString (getOccName clas) ++ 
+        ; let info_string = occNameString (getOccName clas) ++
                             concatMap (occNameString.getDFunTyKey) tys
         ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
         ; newGlobalBinder mod dfun_occ loc }
-\end{code}
 
+{-
 Make a name for the representation tycon of a family instance.  It's an
 *external* name, like other top-level names, and hence must be made with
 newGlobalBinder.
+-}
 
-\begin{code}
 newFamInstTyConName :: Located Name -> [Type] -> TcM Name
 newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
 
@@ -818,22 +805,22 @@ newFamInstAxiomName loc name branches
 mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
 mk_fam_inst_name adaptOcc loc tc_name tyss
   = do  { mod   <- getModule
-        ; let info_string = occNameString (getOccName tc_name) ++ 
+        ; let info_string = occNameString (getOccName tc_name) ++
                             intercalate "|" ty_strings
         ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
         ; newGlobalBinder mod (adaptOcc occ) loc }
   where
     ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
-\end{code}
 
+{-
 Stable names used for foreign exports and annotations.
 For stable names, the name must be unique (see #1533).  If the
 same thing has several stable Ids based on it, the
 top-level bindings generated must not have the same name.
 Hence we create an External name (doesn't change), and we
 append a Unique to the string right here.
+-}
 
-\begin{code}
 mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
 mkStableIdFromString str sig_ty loc occ_wrapper = do
     uniq <- newUnique
@@ -846,9 +833,7 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do
 
 mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
 mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
-\end{code}
 
-\begin{code}
 mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
               => String -> String -> m FastString
 mkWrapperName what nameBase
@@ -878,15 +863,15 @@ spurious ABI change (#4012).
 The wrapper counter has to be per-module, not global, so that the number we end
 up using is not dependent on the modules compiled before the current one.
 -}
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Errors}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 pprBinders :: [Name] -> SDoc
 -- Used in error messages
 -- Use quotes for a single one; they look a bit "busy" for several
@@ -894,13 +879,13 @@ pprBinders [bndr] = quotes (ppr bndr)
 pprBinders bndrs  = pprWithCommas ppr bndrs
 
 notFound :: Name -> TcM TyThing
-notFound name 
+notFound name
   = do { lcl_env <- getLclEnv
        ; let stage = tcl_th_ctxt lcl_env
        ; case stage of   -- See Note [Out of scope might be a staging error]
            Splice {} -> stageRestrictionError (quotes (ppr name))
            _ -> failWithTc $
-                vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> 
+                vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+>
                      ptext (sLit "is not in scope during type checking, but it passed the renamer"),
                      ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl_env)]
                        -- Take case: printing the whole gbl env can
@@ -911,14 +896,14 @@ notFound name
        }
 
 wrongThingErr :: String -> TcTyThing -> Name -> TcM a
--- It's important that this only calls pprTcTyThingCategory, which in 
+-- It's important that this only calls pprTcTyThingCategory, which in
 -- turn does not look at the details of the TcTyThing.
 -- See Note [Placeholder PatSyn kinds] in TcBinds
 wrongThingErr expected thing name
-  = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> 
+  = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
                 ptext (sLit "used as a") <+> text expected)
-\end{code}
 
+{-
 Note [Out of scope might be a staging error]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -930,3 +915,4 @@ But in fact the type checker processes types first, so 'x' won't even be
 in the type envt when we look for it in $(foo x).  So inside splices we
 report something missing from the type env as a staging error.
 See Trac #5752 and #5795.
+-}
diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot
new file mode 100644 (file)
index 0000000..4d291e2
--- /dev/null
@@ -0,0 +1,6 @@
+{-
+>module TcEnv where
+>import TcRnTypes
+>
+>tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
+-}
diff --git a/compiler/typecheck/TcEnv.lhs-boot b/compiler/typecheck/TcEnv.lhs-boot
deleted file mode 100644 (file)
index 4f25cee..0000000
+++ /dev/null
@@ -1,4 +0,0 @@
->module TcEnv where
->import TcRnTypes
->
->tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
\ No newline at end of file
similarity index 97%
rename from compiler/typecheck/TcErrors.lhs
rename to compiler/typecheck/TcErrors.hs
index c8406df..6409d6d 100644 (file)
@@ -1,4 +1,3 @@
-\begin{code}
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
 
 module TcErrors(
@@ -46,13 +45,13 @@ import ListSetOps       ( equivClasses )
 import Control.Monad    ( when )
 import Data.Maybe
 import Data.List        ( partition, mapAccumL, zip4, nub, sortBy )
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \section{Errors and contexts}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 ToDo: for these error messages, should we note the location as coming
 from the insts, or just whatever seems to be around in the monad just
@@ -94,8 +93,8 @@ It does this by keeping track of which errors correspond to which coercion
 in TcErrors. TcErrors.reportTidyWanteds does not print the errors
 and does not fail if -fdefer-type-errors is on, so that we can continue
 compilation. The errors are turned into warnings in `reportUnsolved`.
+-}
 
-\begin{code}
 reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
 reportUnsolved wanted
   = do { binds_var <- newTcEvBinds
@@ -186,8 +185,8 @@ data ReportErrCtxt
                                     --          don't issue any more errors/warnings
                                     -- See Note [Suppressing error messages]
       }
-\end{code}
 
+{-
 Note [Suppressing error messages]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The cec_suppress flag says "don't report any errors.  Instead, just create
@@ -198,9 +197,8 @@ Specifically (see reportWanteds)
   * If there are any insolubles (eg Int~Bool), here or in a nested implication,
     then suppress errors from the flat constraints here.  Sometimes the
     flat-constraint errors are a knock-on effect of the insolubles.
+-}
 
-
-\begin{code}
 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
 reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
                                  , ic_wanted = wanted, ic_binds = evb
@@ -491,8 +489,8 @@ getUserGivens (CEC {cec_encl = ctxt})
     | Implic { ic_given = givens, ic_env = env
              , ic_no_eqs = no_eqs, ic_info = info } <- ctxt
     , not (null givens) ]
-\end{code}
 
+{-
 Note [Always warn with -fdefer-type-errors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When -fdefer-type-errors is on we warn about *all* type errors, even
@@ -559,13 +557,13 @@ And now we have a problem as we will generate an equality b ~ b' and fail to
 solve it.
 
 
-%************************************************************************
-%*                  *
+************************************************************************
+*                  *
                 Irreducible predicate errors
-%*                  *
-%************************************************************************
+*                  *
+************************************************************************
+-}
 
-\begin{code}
 mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 mkIrredErr ctxt cts
   = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1
@@ -621,14 +619,13 @@ mkIPErr ctxt cts
               , nest 2 (pprTheta preds) ]
         | otherwise
         = couldNotDeduce givens (preds, orig)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Equality errors
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Inaccessible code]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -647,8 +644,8 @@ Here the second equation is unreachable. The original constraint
 the *signature* (Trac #7293).  So, for Given errors we replace the
 env (and hence src-loc) on its CtLoc with that from the immediately
 enclosing implication.
+-}
 
-\begin{code}
 mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 -- Don't have multiple equality errors from the same location
 -- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
@@ -671,7 +668,7 @@ mkEqErr1 ctxt ct
        ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
        ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
        ; dflags <- getDynFlags
-       ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig) 
+       ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig)
        ; mkEqErr_help dflags (ctxt {cec_tidy = env1})
                       (wanted_msg $$ binds_msg)
                       ct is_oriented ty1 ty2 }
@@ -988,8 +985,8 @@ sameOccExtra ty1 ty2
          pkg = modulePackageKey mod
          mod = nameModule nm
          loc = nameSrcSpan nm
-\end{code}
 
+{-
 Note [Suggest adding a type signature]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The OutsideIn algorithm rejects GADT programs that don't have a principal
@@ -1040,13 +1037,13 @@ so mkTyFunInfoMsg adds:
 Warn of loopy local equalities that were dropped.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                  Type-class errors
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 mkDictErr ctxt cts
   = ASSERT( not (null cts) )
@@ -1134,7 +1131,7 @@ mk_dict_err fam_envs ctxt (ct, (matches, unifiers, safe_haskell))
 
     add_to_ctxt_fixes has_ambig_tvs
       | not has_ambig_tvs && all_tyvars
-      , (orig:origs) <- usefulContext ctxt pred 
+      , (orig:origs) <- usefulContext ctxt pred
       = [sep [ ptext (sLit "add") <+> pprParendType pred
                <+> ptext (sLit "to the context of")
              , nest 2 $ ppr_skol orig $$
@@ -1346,8 +1343,8 @@ quickFlattenTy (TyConApp tc tys)
          ; v <- newMetaTyVar (TauTv False) (typeKind (TyConApp tc funtys))
          ; flat_resttys <- mapM quickFlattenTy resttys
          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
-\end{code}
 
+{-
 Note [Flattening in error message generation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider (C (Maybe (F x))), where F is a type function, and we have
@@ -1380,8 +1377,8 @@ The reason may be that the kinds don't match up.  Typically you'll get
 more useful information, but not when it's as a result of ambiguity.
 This test suggests -fprint-explicit-kinds when all the ambiguous type
 variables are kind variables.
+-}
 
-\begin{code}
 mkAmbigMsg :: Ct -> (Bool, SDoc)
 mkAmbigMsg ct
   | null ambig_tkvs = (False, empty)
@@ -1498,7 +1495,7 @@ relevantBindings want_filtering ctxt ct
                                  <+> ppr (getSrcLoc id)))]
                   new_seen = tvs_seen `unionVarSet` id_tvs
 
-            ; if (want_filtering && not opt_PprStyle_Debug 
+            ; if (want_filtering && not opt_PprStyle_Debug
                                  && id_tvs `disjointVarSet` ct_tvs)
                        -- We want to filter out this binding anyway
                        -- so discard it silently
@@ -1530,22 +1527,22 @@ warnDefaulting wanteds default_ty
                                 <+> quotes (ppr default_ty))
                             2 ppr_wanteds
        ; setCtLoc loc $ warnTc warn_default warn_msg }
-\end{code}
 
+{-
 Note [Runtime skolems]
 ~~~~~~~~~~~~~~~~~~~~~~
 We want to give a reasonably helpful error message for ambiguity
 arising from *runtime* skolems in the debugger.  These
 are created by in RtClosureInspect.zonkRTTIType.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                  Error from the canonicaliser
          These ones are called *during* constraint simplification
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 solverDepthErrorTcS :: SubGoalCounter -> CtEvidence -> TcM a
 solverDepthErrorTcS cnt ev
   = setCtLoc loc $
@@ -1564,5 +1561,3 @@ solverDepthErrorTcS cnt ev
     msg CountTyFunApps =
         vcat [ ptext (sLit "Type function application stack overflow; size =") <+> int value
              , ptext (sLit "Use -ftype-function-depth=N to increase stack size to N") ]
-\end{code}
-
similarity index 95%
rename from compiler/typecheck/TcEvidence.lhs
rename to compiler/typecheck/TcEvidence.hs
index 83f6596..5e4f4e8 100644 (file)
@@ -1,8 +1,5 @@
-%
-% (c) The University of Glasgow 2006
-%
+-- (c) The University of Glasgow 2006
 
-\begin{code}
 {-# LANGUAGE CPP, DeriveDataTypeable #-}
 
 module TcEvidence (
@@ -57,9 +54,8 @@ import qualified Data.Data as Data
 import Outputable
 import FastString
 import Data.IORef( IORef )
-\end{code}
-
 
+{-
 Note [TcCoercions]
 ~~~~~~~~~~~~~~~~~~
 | TcCoercions are a hack used by the typechecker. Normally,
@@ -95,8 +91,8 @@ differences
   * TcAxiomInstCo has a [TcCoercion] parameter, and not a [Type] parameter.
     This differs from the formalism, but corresponds to AxiomInstCo (see
     [Coercion axioms applied to coercions]).
+-}
 
-\begin{code}
 data TcCoercion
   = TcRefl Role TcType
   | TcTyConAppCo Role TyCon [TcCoercion]
@@ -247,9 +243,7 @@ mkTcCoVarCo ipv = TcCoVarCo ipv
   -- the constraint solver does not substitute in the types of
   -- evidence variables as it goes.  In any case, the optimisation
   -- will be done in the later zonking phase
-\end{code}
 
-\begin{code}
 tcCoercionKind :: TcCoercion -> Pair Type
 tcCoercionKind co = go co
   where
@@ -342,11 +336,9 @@ coVarsOfTcCo tc_co
 
     get_bndrs :: Bag EvBind -> VarSet
     get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet
-\end{code}
 
-Pretty printing
+-- Pretty printing
 
-\begin{code}
 instance Outputable TcCoercion where
   ppr = pprTcCo
 
@@ -424,17 +416,15 @@ ppr_forall_co p ty
     (tvs,  rho) = split1 [] ty
     split1 tvs (TcForAllCo tv ty) = split1 (tv:tvs) ty
     split1 tvs ty                 = (reverse tvs, ty)
-\end{code}
-
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                   HsWrapper
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 data HsWrapper
   = WpHole                      -- The identity coercion
 
@@ -477,14 +467,14 @@ c <.> WpHole = c
 c1 <.> c2    = c1 `WpCompose` c2
 
 mkWpFun :: HsWrapper -> HsWrapper -> TcType -> TcType -> HsWrapper
-mkWpFun WpHole       WpHole       _  _  = WpHole 
+mkWpFun WpHole       WpHole       _  _  = WpHole
 mkWpFun WpHole       (WpCast co2) t1 _  = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2)
 mkWpFun (WpCast co1) WpHole       _  t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2))
 mkWpFun (WpCast co1) (WpCast co2) _  _  = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2)
 mkWpFun co1          co2          t1 t2 = WpFun co1 co2 t1 t2
 
 mkWpCast :: TcCoercion -> HsWrapper
-mkWpCast co 
+mkWpCast co
   | isTcReflCo co = WpHole
   | otherwise     = ASSERT2(tcCoercionRole co == Representational, ppr co)
                     WpCast co
@@ -523,16 +513,15 @@ idHsWrapper = WpHole
 isIdHsWrapper :: HsWrapper -> Bool
 isIdHsWrapper WpHole = True
 isIdHsWrapper _      = False
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                   Evidence bindings
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 data TcEvBinds
   = TcEvBinds           -- Mutable evidence bindings
        EvBindsVar       -- Mutable because they are updated "later"
@@ -609,8 +598,8 @@ data EvLit
   = EvNum Integer
   | EvStr FastString
     deriving( Data.Data, Data.Typeable)
-\end{code}
 
+{-
 Note [Coercion evidence terms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A "coercion evidence term" takes one of these forms
@@ -699,14 +688,8 @@ The story for kind `Symbol` is analogous:
   * class KnownSymbol
   * newtype SSymbol
   * Evidence: EvLit (EvStr n)
+-}
 
-
-
-
-
-
-
-\begin{code}
 mkEvCast :: EvTerm -> TcCoercion -> EvTerm
 mkEvCast ev lco
   | ASSERT2(tcCoercionRole lco == Representational, (vcat [ptext (sLit "Coercion of wrong role passed to mkEvCast:"), ppr ev, ppr lco]))
@@ -742,16 +725,15 @@ evVarsOfTerm (EvLit _)            = emptyVarSet
 
 evVarsOfTerms :: [EvTerm] -> VarSet
 evVarsOfTerms = mapUnionVarSet evVarsOfTerm
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                   Pretty printing
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 instance Outputable HsWrapper where
   ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
 
@@ -766,7 +748,7 @@ pprHsWrapper doc wrap
     -- False <=> appears as body of let or lambda
     help it WpHole             = it
     help it (WpCompose f1 f2)  = help (help it f2) f1
-    help it (WpFun f1 f2 t1 _) = add_parens $ ptext (sLit "\\(x") <> dcolon <> ppr t1 <> ptext (sLit ").") <+> 
+    help it (WpFun f1 f2 t1 _) = add_parens $ ptext (sLit "\\(x") <> dcolon <> ppr t1 <> ptext (sLit ").") <+>
                                               help (\_ -> it True <+> help (\_ -> ptext (sLit "x")) f1 True) f2 False
     help it (WpCast co)   = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
                                               <+> pprParendTcCo co)]
@@ -809,5 +791,3 @@ instance Outputable EvTerm where
 instance Outputable EvLit where
   ppr (EvNum n) = integer n
   ppr (EvStr s) = text (show s)
-\end{code}
-
similarity index 92%
rename from compiler/typecheck/TcExpr.lhs
rename to compiler/typecheck/TcExpr.hs
index a1d9b6a..763be05 100644 (file)
@@ -1,10 +1,11 @@
+{-
 c%
-(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
+
 \section[TcExpr]{Typecheck an expression}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
@@ -64,15 +65,15 @@ import Class(classTyCon)
 import Data.Function
 import Data.List
 import qualified Data.Set as Set
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Main wrappers}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcPolyExpr, tcPolyExprNC
          :: LHsExpr Name        -- Expression to type check
          -> TcSigmaType         -- Expected type (could be a polytype)
@@ -137,16 +138,15 @@ tcHole occ res_ty
                            , cc_hole = ExprHole }
       ; emitInsoluble can
       ; tcWrapResult (HsVar ev) ty res_ty }
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         tcExpr: the main expression typechecker
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty     -- Sanity check
                 = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
@@ -222,7 +222,7 @@ tcExpr (ExprWithTySig expr sig_ty wcs) res_ty
 
                   -- Remember to extend the lexical type-variable environment
                   -- See Note [More instantiated than scoped] in TcBinds
-               tcExtendTyVarEnv2 
+               tcExtendTyVarEnv2
                   [(n,tv) | (Just n, tv) <- findScopedTyVars sig_ty sig_tc_ty skol_tvs] $
 
                tcMonoExprNC expr res_ty
@@ -243,14 +243,13 @@ tcExpr (HsType ty) _
         -- same parser parses *patterns*.
 tcExpr (HsUnboundVar v) res_ty
   = tcHole (rdrNameOcc v) res_ty
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Infix operators and sections
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Left sections]
 ~~~~~~~~~~~~~~~~~~~~
@@ -295,9 +294,8 @@ with a kind error.  It seems more uniform to treat 'seq' as it it
 was a language construct.
 
 See Note [seqId magic] in MkId, and
+-}
 
-
-\begin{code}
 tcExpr (OpApp arg1 op fix arg2) res_ty
   | (L loc (HsVar op_name)) <- op
   , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
@@ -422,15 +420,15 @@ tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
         ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
   where
     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Let, case, if, do
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcExpr (HsLet binds expr) res_ty
   = do  { (binds', expr') <- tcLocalBinds binds $
                              tcMonoExpr expr res_ty
@@ -488,8 +486,8 @@ tcExpr (HsDo do_or_lc stmts _) res_ty
 tcExpr (HsProc pat cmd) res_ty
   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
         ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
-\end{code}
 
+{-
 Note [Rebindable syntax for if]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The rebindable syntax for 'if' uses the most flexible possible type
@@ -507,13 +505,13 @@ to support expressions like this:
               else "No value"
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Record construction and update
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
   = do  { data_con <- tcLookupDataCon con_name
 
@@ -529,8 +527,8 @@ tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
         ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
         ; return $ mkHsWrapCo co_res $
           RecordCon (L loc con_id) con_expr rbinds' }
-\end{code}
 
+{-
 Note [Type of a record update]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The main complication with RecordUpd is that we need to explicitly
@@ -631,8 +629,8 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
   * in_inst_tys, out_inst_tys have same length, and instantiate the
         *representation* tycon of the data cons.  In Note [Data
         family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
+-}
 
-\begin{code}
 tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
   = ASSERT( notNull upd_fld_names )
     do  {
@@ -756,17 +754,17 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
                                             , not (fld `elem` upd_fld_names)]
                       , (tv1,tv) <- tvs1 `zip` tvs      -- Discards existentials in tvs
                       , tv `elemVarSet` fixed_tvs ]
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Arithmetic sequences                    e.g. [a,b..]
         and their parallel-array counterparts   e.g. [: a,b.. :]
 
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcExpr (ArithSeq _ witness seq) res_ty
   = tcArithSeq witness seq res_ty
 
@@ -795,45 +793,42 @@ tcExpr (PArrSeq _ _) _
   = panic "TcExpr.tcExpr: Infinite parallel array!"
     -- the parser shouldn't have generated it and the renamer shouldn't have
     -- let it through
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Template Haskell
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcExpr (HsSpliceE is_ty splice)  res_ty
   = ASSERT( is_ty )   -- Untyped splices are expanded by the renamer
    tcSpliceExpr splice res_ty
 
 tcExpr (HsBracket brack)         res_ty = tcTypedBracket   brack res_ty
 tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Catch-all
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
   -- Include ArrForm, ArrApp, which shouldn't appear at all
   -- Also HsTcBracketOut, HsQuasiQuoteE
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Arithmetic sequences [a..b] etc
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType
            -> TcM (HsExpr TcId)
 
@@ -880,15 +875,15 @@ arithSeqEltType (Just fl) res_ty
        ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty)
        ; (coi, elt_ty) <- matchExpectedListTy list_ty
        ; return (coi, elt_ty, Just fl') }
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Applications
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
       -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
 
@@ -996,9 +991,8 @@ tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
                                        ; tcWrapResult expr rho res_ty }
 tcSyntaxOp _ other         _      = pprPanic "tcSyntaxOp" (ppr other)
-\end{code}
-
 
+{-
 Note [Push result type in]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Unify with expected result before type-checking the args so that the
@@ -1024,13 +1018,13 @@ the signature is propagated into MkQ's argument. With the check
 in the other order, the extra signature in f2 is reqd.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                  tcInferId
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
 tcCheckId name res_ty
   = do { (expr, actual_res_ty) <- tcInferId name
@@ -1126,8 +1120,8 @@ srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId
 srcSpanPrimLit dflags span
     = HsLit (HsStringPrim "" (unsafeMkByteString
                              (showSDocOneLine dflags (ppr span))))
-\end{code}
 
+{-
 Note [Adding the implicit parameter to 'assert']
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The typechecker transforms (assert e1 e2) to (assertError "Foo.hs:27"
@@ -1162,8 +1156,8 @@ Usually that coercion is hidden inside the wrappers for
 constructors of F [Int] but here we have to do it explicitly.
 
 It's all grotesquely complicated.
+-}
 
-\begin{code}
 tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name
       -> TcRhoType -> TcM (HsExpr TcId)
 -- (seq e1 e2) :: res_ty
@@ -1213,16 +1207,15 @@ tcTagToEnum loc fun_name arg res_ty
       = hang (ptext (sLit "Bad call to tagToEnum#")
                <+> ptext (sLit "at type") <+> ppr ty)
            2 what
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                  Template Haskell checks
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 checkThLocalId :: Id -> TcM ()
 #ifndef GHCI  /* GHCI and TH is off */
 --------------------------------------
@@ -1291,8 +1284,8 @@ polySpliceErr :: Id -> SDoc
 polySpliceErr id
   = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
 #endif /* GHCI */
-\end{code}
 
+{-
 Note [Lifting strings]
 ~~~~~~~~~~~~~~~~~~~~~~
 If we see $(... [| s |] ...) where s::String, we don't want to
@@ -1312,11 +1305,11 @@ which show up as ATcIds rather than AGlobals.  So we need to check for
 naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Record bindings}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Game plan for record bindings
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1333,9 +1326,8 @@ For each binding field = value
    the expected argument type.
 
 This extends OK when the field types are universally quantified.
+-}
 
-
-\begin{code}
 tcRecordBinds
         :: DataCon
         -> [TcType]     -- Expected type for each field
@@ -1403,16 +1395,17 @@ checkMissingFields data_con rbinds
                           field_strs
 
     field_strs = dataConStrictMarks data_con
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Errors and contexts}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Boring and alphabetical:
-\begin{code}
+-}
+
 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
 
@@ -1516,8 +1509,8 @@ badFieldsUpd rbinds data_cons
       map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
 
     countTrue = length . filter id
-\end{code}
 
+{-
 Note [Finding the conflicting fields]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we have
@@ -1528,20 +1521,20 @@ and we see a record update
 Then we'd like to find the smallest subset of fields that no
 constructor has all of.  Here, say, {a0,b0}, or {a0,b1}, etc.
 We don't really want to report that no constructor has all of
-{a0,a1,b0,b1}, because when there are hundreds of fields it's 
+{a0,a1,b0,b1}, because when there are hundreds of fields it's
 hard to see what was really wrong.
 
 We may need more than two fields, though; eg
-  data T = A { x,y :: Int, v::Int } 
-          | B { y,z :: Int, v::Int } 
+  data T = A { x,y :: Int, v::Int }
+          | B { y,z :: Int, v::Int }
           | C { z,x :: Int, v::Int }
 with update
    r { x=e1, y=e2, z=e3 }, we
 
 Finding the smallest subset is hard, so the code here makes
-a decent stab, no more.  See Trac #7989. 
+a decent stab, no more.  See Trac #7989.
+-}
 
-\begin{code}
 naughtyRecordSel :: TcId -> SDoc
 naughtyRecordSel sel_id
   = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
@@ -1569,4 +1562,3 @@ missingFields con fields
         <+> pprWithCommas ppr fields
 
 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
-\end{code}
similarity index 84%
rename from compiler/typecheck/TcExpr.lhs-boot
rename to compiler/typecheck/TcExpr.hs-boot
index 378a012..acd5d8a 100644 (file)
@@ -1,21 +1,20 @@
-\begin{code}
 module TcExpr where
 import HsSyn    ( HsExpr, LHsExpr )
 import Name     ( Name )
 import TcType   ( TcType, TcRhoType, TcSigmaType )
 import TcRnTypes( TcM, TcId, CtOrigin )
 
-tcPolyExpr :: 
+tcPolyExpr ::
           LHsExpr Name
        -> TcSigmaType
        -> TcM (LHsExpr TcId)
 
-tcMonoExpr, tcMonoExprNC :: 
+tcMonoExpr, tcMonoExprNC ::
           LHsExpr Name
        -> TcRhoType
        -> TcM (LHsExpr TcId)
 
-tcInferRho, tcInferRhoNC :: 
+tcInferRho, tcInferRhoNC ::
           LHsExpr Name
        -> TcM (LHsExpr TcId, TcRhoType)
 
@@ -25,4 +24,3 @@ tcSyntaxOp :: CtOrigin
            -> TcM (HsExpr TcId)
 
 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
-\end{code}
similarity index 94%
rename from compiler/typecheck/TcFlatten.lhs
rename to compiler/typecheck/TcFlatten.hs
index 8c20752..10adc94 100644 (file)
@@ -1,4 +1,3 @@
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcFlatten(
@@ -29,9 +28,8 @@ import Util
 import Bag
 import FastString
 import Control.Monad( when )
-\end{code}
-
 
+{-
 Note [The flattening story]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 * A CFunEqCan is either of form
@@ -306,12 +304,12 @@ Current story: we don't generate these derived constraints.  We could, but
 we'd want to make them very weak, so we didn't get the Int~Bool complaint.
 
 
-%************************************************************************
-%*                                                                      *
-%*                  Other notes (Oct 14)
+************************************************************************
+*                                                                      *
+*                  Other notes (Oct 14)
       I have not revisted these, but I didn't want to discard them
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 
 Try: rewrite wanted with wanted only for fmvs (not all meta-tyvars)
@@ -326,12 +324,12 @@ skol ~ untch, must re-orieint to untch ~ skol, so that we can use it to rewrite.
 
 
 
-%************************************************************************
-%*                                                                      *
-%*                  Examples
+************************************************************************
+*                                                                      *
+*                  Examples
      Here is a long series of examples I had to work through
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Simple20
 ~~~~~~~~
@@ -343,7 +341,7 @@ axiom F [a] = [F a]
  [G] [F a] ~ fsk  (nc)
 -->
  [G] F a ~ fsk2
- [G] fsk ~ [fsk2] 
+ [G] fsk ~ [fsk2]
  [G] fsk ~ a
 -->
  [G] F a ~ fsk2
@@ -450,7 +448,7 @@ indexed-types/should_fail/GADTwrong1
   work item fsk ~ ()
 
 Surely the work item should rewrite to () ~ ()?  Well, maybe not;
-it'a very special case.  More generally, our givens look like 
+it'a very special case.  More generally, our givens look like
 F a ~ Int, where (F a) is not reducible.
 
 
@@ -480,7 +478,7 @@ wanteds with wanteds.
 Then we go into a loop when normalise the work-item, because we
 use rewriteOrSame on the argument of V.
 
-Conclusion: Don't make canRewrite context specific; instead use 
+Conclusion: Don't make canRewrite context specific; instead use
 [W] a ~ ty to rewrite a wanted iff 'a' is a unification variable.
 
 
@@ -518,11 +516,11 @@ wanteds, we will
   [W] Int ~ Bool
 
 
-%************************************************************************
-%*                                                                      *
-%*           The main flattening functions
-%*                                                                      *
-%************************************************************************
+************************************************************************
+*                                                                      *
+*           The main flattening functions
+*                                                                      *
+************************************************************************
 
 Note [Flattening]
 ~~~~~~~~~~~~~~~~~~~~
@@ -563,8 +561,8 @@ so when the flattener encounters one, it first asks whether its
 transitive expansion contains any type function applications.  If so,
 it expands the synonym and proceeds; if not, it simply returns the
 unexpanded synonym.
+-}
 
-\begin{code}
 data FlattenEnv
   = FE { fe_mode :: FlattenMode
        , fe_ev   :: CtEvidence }
@@ -580,8 +578,8 @@ data FlattenMode  -- Postcondition for all three: inert wrt the type substitutio
                            --   (but under type constructors is ok e.g. [F a])
 
   | FM_SubstOnly           -- See Note [Flattening under a forall]
-\end{code}
 
+{-
 Note [Lazy flattening]
 ~~~~~~~~~~~~~~~~~~~~~~
 The idea of FM_Avoid mode is to flatten less aggressively.  If we have
@@ -607,8 +605,8 @@ other examples where lazy flattening caused problems.
 Bottom line: FM_Avoid is unused for now (Nov 14).
 Note: T5321Fun got faster when I disabled FM_Avoid
       T5837 did too, but it's pathalogical anyway
+-}
 
-\begin{code}
 -- Flatten a bunch of types all at once.
 flattenMany :: FlattenEnv -> [Type] -> TcS ([Xi], [TcCoercion])
 -- Coercions :: Xi ~ Type
@@ -649,7 +647,7 @@ flatten fmode (FunTy ty1 ty2)
 
 flatten fmode (TyConApp tc tys)
 
-  -- Expand type synonyms that mention type families 
+  -- Expand type synonyms that mention type families
   -- on the RHS; see Note [Flattening synonyms]
   | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
   , let expanded_ty = mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys'
@@ -690,8 +688,8 @@ flattenTyConApp :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion)
 flattenTyConApp fmode tc tys
   = do { (xis, cos) <- flattenMany fmode tys
        ; return (mkTyConApp tc xis, mkTcTyConAppCo Nominal tc cos) }
-\end{code}
 
+{-
 Note [Flattening synonyms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Not expanding synonyms aggressively improves error messages, and
@@ -727,13 +725,13 @@ because now the 'b' has escaped its scope.  We'd have to flatten to
        (a ~ forall b. fsk b, forall b. F a b ~ fsk b)
 and we have not begun to think about how to make that work!
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
              Flattening a type-family application
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 flattenFamApp, flattenExactFamApp, flattenExactFamApp_fully
   :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion)
   --   flattenFamApp            can be over-saturated
@@ -802,19 +800,19 @@ flattenExactFamApp_fully fmode tc tys
 
                    ; traceTcS "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr fsk $$ ppr ev)
                    ; return (mkTyVarTy fsk, mkTcSymCo (ctEvCoercion ev) `mkTcTransCo` ret_co) } }
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Flattening a type variable
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 flattenTyVar :: FlattenEnv -> TcTyVar -> TcS (Xi, TcCoercion)
 -- "Flattening" a type variable means to apply the substitution to it
--- The substitution is actually the union of 
---     * the unifications that have taken place (either before the 
+-- The substitution is actually the union of
+--     * the unifications that have taken place (either before the
 --       solver started, or in TcInteract.solveByUnification)
 --     * the CTyEqCans held in the inert set
 --
@@ -882,8 +880,8 @@ flattenTyVarFinal ctxt_ev tv
              kind_fmode = FE { fe_ev = ctxt_ev, fe_mode = FM_SubstOnly }
        ; (new_knd, _kind_co) <- flatten kind_fmode kind
        ; return (Left (setVarType tv new_knd)) }
-\end{code}
 
+{-
 Note [Applying the inert substitution]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The inert CTyEqCans (a ~ ty), inert_eqs, can be treated as a
@@ -990,9 +988,8 @@ is an example; all the constraints here are Givens
 Because the incoming given rewrites all the inert givens, we get more and
 more duplication in the inert set.  But this really only happens in pathalogical
 casee, so we don't care.
+-}
 
-
-\begin{code}
 eqCanRewrite :: CtEvidence -> CtEvidence -> Bool
 -- Very important function!
 -- See Note [eqCanRewrite]
@@ -1007,8 +1004,8 @@ canRewriteOrSame (CtWanted {})  (CtWanted {})  = True
 canRewriteOrSame (CtWanted {})  (CtDerived {}) = True
 canRewriteOrSame (CtDerived {}) (CtDerived {}) = True
 canRewriteOrSame _ _ = False
-\end{code}
 
+{-
 Note [eqCanRewrite]
 ~~~~~~~~~~~~~~~~~~~
 (eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form
@@ -1037,11 +1034,11 @@ canRewriteOrSame is similar but
  * works for all kinds of constraints, not just CTyEqCans
 See the call sites for explanations.
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
              Unflattening
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 An unflattening example:
     [W] F a ~ alpha
@@ -1049,9 +1046,8 @@ flattens to
     [W] F a ~ fmv   (CFunEqCan)
     [W] fmv ~ alpha (CTyEqCan)
 We must solve both!
+-}
 
-
-\begin{code}
 unflatten :: Cts -> Cts -> TcS Cts
 unflatten tv_eqs funeqs
  = do { dflags   <- getDynFlags
@@ -1160,8 +1156,8 @@ tryFill dflags tv rhs ev
 
            _ ->  -- Occurs check
                  return False } }
-\end{code}
 
+{-
 Note [Unflatten using funeqs first]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     [W] G a ~ Int
@@ -1178,4 +1174,4 @@ unsolved constraints.  The flat form will be
     fmv1 ~ fmv2    (CTyEqCan)
 
 Flatten using the fun-eqs first.
-
+-}
similarity index 92%
rename from compiler/typecheck/TcForeign.lhs
rename to compiler/typecheck/TcForeign.hs
index 73b3b1c..b387162 100644 (file)
@@ -1,7 +1,7 @@
-%
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1998
+
 \section[TcForeign]{Typechecking \tr{foreign} declarations}
 
 A foreign declaration is used to either give an externally
@@ -10,8 +10,8 @@ give a Haskell function an external calling interface. Either way,
 the range of argument and result types these functions can accommodate
 is restricted to what the outside world understands (read C), and this
 module checks to see if a foreign declaration has got a legal type.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcForeign
@@ -62,9 +62,7 @@ import FastString
 import Hooks
 
 import Control.Monad
-\end{code}
 
-\begin{code}
 -- Defines a binding
 isForeignImport :: LForeignDecl name -> Bool
 isForeignImport (L _ (ForeignImport _ _ _ _)) = True
@@ -74,8 +72,8 @@ isForeignImport _                             = False
 isForeignExport :: LForeignDecl name -> Bool
 isForeignExport (L _ (ForeignExport _ _ _ _)) = True
 isForeignExport _                             = False
-\end{code}
 
+{-
 Note [Don't recur in normaliseFfiType']
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 normaliseFfiType' is the workhorse for normalising a type used in a foreign
@@ -107,8 +105,8 @@ IO and FunPtr. Thus, this is not an onerous burden.
 If we ever want to lift this restriction, we would need to make 'go' take
 the target role as a parameter. This wouldn't be hard, but it's a complication
 not yet necessary and so is not yet implemented.
+-}
 
-\begin{code}
 -- normaliseFfiType takes the type from an FFI declaration, and
 -- evaluates any type synonyms, type functions, and newtypes. However,
 -- we are only allowed to look through newtypes if the constructor is
@@ -142,7 +140,7 @@ normaliseFfiType' env ty0 = go initRecTc ty0
                    --   Here, we don't reject the type for being recursive.
                    -- If this is a recursive newtype then it will normally
                    -- be rejected later as not being a valid FFI type.
-        = do { rdr_env <- getGlobalRdrEnv 
+        = do { rdr_env <- getGlobalRdrEnv
              ; case checkNewtypeFFI rdr_env tc of
                  Nothing  -> nothing
                  Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs
@@ -152,7 +150,7 @@ normaliseFfiType' env ty0 = go initRecTc ty0
         , (co, ty) <- normaliseTcApp env Representational tc tys
         , not (isReflCo co)
         = do (co', ty', gres) <- go rec_nts ty
-             return (mkTransCo co co', ty', gres)  
+             return (mkTransCo co co', ty', gres)
 
         | otherwise
         = nothing -- see Note [Don't recur in normaliseFfiType']
@@ -186,18 +184,18 @@ normaliseFfiType' env ty0 = go initRecTc ty0
          -- See Note [Don't recur in normaliseFfiType']
 
 checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
-checkNewtypeFFI rdr_env tc 
+checkNewtypeFFI rdr_env tc
   | Just con <- tyConSingleDataCon_maybe tc
   , [gre] <- lookupGRE_Name rdr_env (dataConName con)
   = Just gre    -- See Note [Newtype constructor usage in foreign declarations]
   | otherwise
   = Nothing
-\end{code}
 
+{-
 Note [Newtype constructor usage in foreign declarations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 GHC automatically "unwraps" newtype constructors in foreign import/export
-declarations.  In effect that means that a newtype data constructor is 
+declarations.  In effect that means that a newtype data constructor is
 used even though it is not mentioned expclitly in the source, so we don't
 want to report it as "defined but not used" or "imported but not used".
 eg     newtype D = MkD Int
@@ -205,30 +203,30 @@ eg     newtype D = MkD Int
 Here 'MkD' us used.  See Trac #7408.
 
 GHC also expands type functions during this process, so it's not enough
-just to look at the free variables of the declaration.  
+just to look at the free variables of the declaration.
 eg     type instance F Bool = D
        foreign import bar :: F Bool -> IO ()
 Here again 'MkD' is used.
 
 So we really have wait until the type checker to decide what is used.
 That's why tcForeignImports and tecForeignExports return a (Bag GRE)
-for the newtype constructors they see. Then TcRnDriver can add them 
+for the newtype constructors they see. Then TcRnDriver can add them
 to the module's usages.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Imports}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)
 tcForeignImports decls
   = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)
 
 tcForeignImports' :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt)
--- For the (Bag GlobalRdrElt) result, 
+-- For the (Bag GlobalRdrElt) result,
 -- see Note [Newtype constructor usage in foreign declarations]
 tcForeignImports' decls
   = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
@@ -256,11 +254,9 @@ tcFImport (L dloc fo@(ForeignImport (L nloc nm) hs_ty _ imp_decl))
        ; let fi_decl = ForeignImport (L nloc id) undefined (mkSymCo norm_co) imp_decl'
        ; return (id, L dloc fi_decl, gres) }
 tcFImport d = pprPanic "tcFImport" (ppr d)
-\end{code}
 
+-- ------------ Checking types for foreign import ----------------------
 
------------- Checking types for foreign import ----------------------
-\begin{code}
 tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
 
 tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
@@ -294,7 +290,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
       checkCg checkCOrAsmOrLlvmOrInterp
       cconv' <- checkCConv cconv
       case arg_tys of           -- The first arg must be Ptr or FunPtr
-        []                -> 
+        []                ->
           addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "At least one argument expected")))
         (arg1_ty:arg_tys) -> do
           dflags <- getDynFlags
@@ -349,15 +345,15 @@ checkMissingAmpersand dflags arg_tys res_ty
   = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr"))
   | otherwise
   = return ()
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Exports}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcForeignExports :: [LForeignDecl Name]
                  -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)
 tcForeignExports decls =
@@ -365,7 +361,7 @@ tcForeignExports decls =
 
 tcForeignExports' :: [LForeignDecl Name]
                  -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt)
--- For the (Bag GlobalRdrElt) result, 
+-- For the (Bag GlobalRdrElt) result,
 -- see Note [Newtype constructor usage in foreign declarations]
 tcForeignExports' decls
   = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
@@ -397,11 +393,9 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec)
     id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
     return (mkVarBind id rhs, ForeignExport (L loc id) undefined norm_co spec', gres)
 tcFExport d = pprPanic "tcFExport" (ppr d)
-\end{code}
 
------------- Checking argument types for foreign export ----------------------
+-- ------------ Checking argument types for foreign export ----------------------
 
-\begin{code}
 tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
 tcCheckFEType sig_ty (CExport (L l (CExportStatic str cconv)) src) = do
     checkCg checkCOrAsmOrLlvm
@@ -415,17 +409,15 @@ tcCheckFEType sig_ty (CExport (L l (CExportStatic str cconv)) src) = do
       -- the structure of the foreign type.
     (_, t_ty) = tcSplitForAllTys sig_ty
     (arg_tys, res_ty) = tcSplitFunTys t_ty
-\end{code}
-
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Miscellaneous}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 ------------ Checking argument types for foreign import ----------------------
 checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM ()
 checkForeignArgs pred tys = mapM_ go tys
@@ -437,7 +429,7 @@ checkForeignArgs pred tys = mapM_ go tys
 --    (IO t) or (t) , and that t satisfies the given predicate.
 -- When calling this function, any newtype wrappers (should) have been
 -- already dealt with by normaliseFfiType.
--- 
+--
 -- We also check that the Safe Haskell condition of FFI imports having
 -- results in the IO monad holds.
 --
@@ -478,11 +470,9 @@ mustBeIO = False
 checkSafe, noCheckSafe :: Bool
 checkSafe   = True
 noCheckSafe = False
-\end{code}
 
-Checking a supported backend is in use
+-- Checking a supported backend is in use
 
-\begin{code}
 checkCOrAsmOrLlvm :: HscTarget -> Validity
 checkCOrAsmOrLlvm HscC    = IsValid
 checkCOrAsmOrLlvm HscAsm  = IsValid
@@ -508,11 +498,9 @@ checkCg check = do
         case check target of
           IsValid      -> return ()
           NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)
-\end{code}
 
-Calling conventions
+-- Calling conventions
 
-\begin{code}
 checkCConv :: CCallConv -> TcM CCallConv
 checkCConv CCallConv    = return CCallConv
 checkCConv CApiConv     = return CApiConv
@@ -531,11 +519,9 @@ checkCConv JavaScriptCallConv = do dflags <- getDynFlags
                                        then return JavaScriptCallConv
                                        else do addErrTc (text "The `javascript' calling convention is unsupported on this platform")
                                                return JavaScriptCallConv
-\end{code}
 
-Warnings
+-- Warnings
 
-\begin{code}
 check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()
 check IsValid _             = return ()
 check (NotValid doc) err_fn = addErrTc (err_fn doc)
@@ -560,4 +546,3 @@ foreignDeclCtxt :: ForeignDecl Name -> SDoc
 foreignDeclCtxt fo
   = hang (ptext (sLit "When checking declaration:"))
        2 (ppr fo)
-\end{code}
similarity index 94%
rename from compiler/typecheck/TcGenDeriv.lhs
rename to compiler/typecheck/TcGenDeriv.hs
index 13d8e83..57adb1c 100644 (file)
@@ -1,7 +1,8 @@
+{-
     %
-(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
+
 
 TcGenDeriv: Generating derived instance declarations
 
@@ -9,8 +10,8 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the
 ``official'' interface to deriving-related things.
 
 This is where we do all the grimy bindings' generation.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 
@@ -70,9 +71,7 @@ import StaticFlags( opt_PprStyle_Debug )
 import ListSetOps ( assocMaybe )
 import Data.List  ( partition, intersperse )
 import Data.Maybe ( isNothing )
-\end{code}
 
-\begin{code}
 type BagDerivStuff = Bag DerivStuff
 
 data AuxBindSpec
@@ -93,15 +92,15 @@ data DerivStuff     -- Please add this auxiliary stuff
   -- New top-level auxiliary bindings
   | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
   | DerivInst (InstInfo RdrName)                -- New, auxiliary instances
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Top level function
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
                 -> (LHsBinds RdrName, BagDerivStuff)
 genDerivedBinds dflags fix_env clas loc tycon
@@ -143,13 +142,13 @@ canDeriveAnyClass dflags _tycon clas =
         (not (getUnique clas `elem` standardClassKeys) `orElse` "")
       -- 2) Opt_DeriveAnyClass is on
      <> (xopt Opt_DeriveAnyClass dflags `orElse` "Try enabling DeriveAnyClass")
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Eq instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Here are the heuristics for the code we generate for @Eq@. Let's
 assume we have a data type with some (possibly zero) nullary data
@@ -201,8 +200,8 @@ tycon, we generate:
 However, that requires that (Ord <whatever>) was put in the context
 for the instance decl, which it probably wasn't, so the decls
 produced don't get through the typechecker.
+-}
 
-\begin{code}
 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Eq_binds loc tycon
   = (method_binds, aux_binds)
@@ -261,13 +260,13 @@ gen_Eq_binds loc tycon
           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
           where
             nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Ord instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Generating Ord instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -330,8 +329,8 @@ binary result, something like this:
 
 So for sufficiently small types (few constructors, or all nullary)
 we generate all methods; for large ones we just use 'compare'.
+-}
 
-\begin{code}
 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
 
 ------------
@@ -549,15 +548,13 @@ nlConWildPat :: DataCon -> LPat RdrName
 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
                                    (RecCon (HsRecFields { rec_flds = []
                                                         , rec_dotdot = Nothing })))
-\end{code}
-
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Enum instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @Enum@ can only be derived for enumeration types.  For a type
 \begin{verbatim}
@@ -593,8 +590,8 @@ instance ... Enum (Foo ...) where
 \end{verbatim}
 
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
+-}
 
-\begin{code}
 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Enum_binds loc tycon
   = (method_binds, aux_binds)
@@ -666,15 +663,15 @@ gen_Enum_binds loc tycon
       = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
           untag_Expr tycon [(a_RDR, ah_RDR)] $
           (nlHsVarApps intDataCon_RDR [ah_RDR])
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Bounded instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Bounded_binds loc tycon
   | isEnumerationTyCon tycon
@@ -701,13 +698,13 @@ gen_Bounded_binds loc tycon
                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
     max_bound_1con = mkHsVarBind loc maxBound_RDR $
                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Ix instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Deriving @Ix@ is only possible for enumeration types and
 single-constructor types.  We deal with them in turn.
@@ -760,8 +757,8 @@ For a single-constructor type (NB: this includes all tuples), e.g.,
 \end{verbatim}
 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 (p.~147).
+-}
 
-\begin{code}
 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Ix_binds loc tycon
@@ -876,13 +873,13 @@ gen_Ix_binds loc tycon
           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
       where
         in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Read instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Example
 
@@ -949,8 +946,8 @@ Rather we want
 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
 These instances are also useful for Read (Either Int Emp), where
 we want to be able to parse (Left 3) just fine.
+-}
 
-\begin{code}
 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Read_binds get_fixity loc tycon
@@ -1087,14 +1084,13 @@ gen_Read_binds get_fixity loc tycon
                  = ident_h_pat lbl_str
                  where
                    lbl_str = occNameString (getOccName lbl)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Show instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Example
 
@@ -1118,8 +1114,8 @@ Example
     up_prec  = 5    -- Precedence of :^:
     app_prec = 10   -- Application has precedence one more than
                     -- the most tightly-binding operator
+-}
 
-\begin{code}
 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Show_binds get_fixity loc tycon
@@ -1213,9 +1209,7 @@ isSym (c : _) = startsVarSym c || startsConSym c
 
 mk_showString_app :: String -> LHsExpr RdrName
 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
-\end{code}
 
-\begin{code}
 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
 getPrec is_infix get_fixity nm
   | not is_infix   = appPrecedence
@@ -1233,14 +1227,13 @@ getPrecedence get_fixity nm
           -- NB: the Report says that associativity is not taken
           --     into account for either Read or Show; hence we
           --     ignore associativity here
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Typeable (new)}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 From the data type
 
@@ -1253,8 +1246,8 @@ we generate
                                                 <pkg> <module> "T") []
 
 We are passed the Typeable2 class as well as T
+-}
 
-\begin{code}
 gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon
                    -> (LHsBinds RdrName, BagDerivStuff)
 gen_Typeable_binds dflags loc tycon
@@ -1283,15 +1276,13 @@ gen_Typeable_binds dflags loc tycon
     int64
       | wORD_SIZE dflags == 4 = HsWord64Prim "" . fromIntegral
       | otherwise             = HsWordPrim "" . fromIntegral
-\end{code}
-
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Data instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 From the data type
 
@@ -1320,9 +1311,8 @@ we generate
 
     dataCast1 = gcast1   -- If T :: * -> *
     dataCast2 = gcast2   -- if T :: * -> * -> *
+-}
 
-
-\begin{code}
 gen_Data_binds :: DynFlags
                -> SrcSpan
                -> TyCon                 -- For data families, this is the
@@ -1512,18 +1502,16 @@ ltDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<##" )
 leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")
 gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )
 geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
-\end{code}
-
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                         Functor instances
 
  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
 
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 For the data type:
 
@@ -1600,8 +1588,8 @@ lambda functions by producing a meta level function. But the function to
 be mapped, `f`, is a function on the code level, not on the meta level,
 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
 It is better to produce too many lambdas than to eta expand, see ticket #7436.
+-}
 
-\begin{code}
 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Functor_binds loc tycon
   = (unitBag fmap_bind, emptyBag)
@@ -1637,14 +1625,14 @@ gen_Functor_binds loc tycon
                   -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
     match_for_con = mkSimpleConMatch $
         \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
-\end{code}
 
+{-
 Utility functions related to Functor deriving.
 
 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
 This function works like a fold: it makes a value of type 'a' in a bottom up way.
+-}
 
-\begin{code}
 -- Generic traversal for Functor deriving
 data FFoldType a      -- Describes how to fold over a Type in a functor like way
    = FT { ft_triv    :: a                   -- Does not contain variable
@@ -1763,17 +1751,16 @@ mkSimpleTupleCase match_for_con sort insides x = do
     let con = tupleCon sort (length insides)
     match <- match_for_con [] con insides
     return $ nlHsCase x [match]
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                         Foldable instances
 
  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
 
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Deriving Foldable instances works the same way as Functor instances,
 only Foldable instances are not possible for function types at all.
@@ -1791,8 +1778,8 @@ The cases are:
 
 Note that the arguments to the real foldr function are the wrong way around,
 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
+-}
 
-\begin{code}
 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Foldable_binds loc tycon
   = (listToBag [foldr_bind, foldMap_bind], emptyBag)
@@ -1840,16 +1827,14 @@ gen_Foldable_binds loc tycon
             [] -> mempty_Expr
             xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
 
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                         Traversable instances
 
  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Again, Traversable is much like Functor and Foldable.
 
@@ -1866,8 +1851,8 @@ Note that the generated code is not as efficient as it could be. For instance:
 
 gives the function: traverse f (T x y) = T <$> pure x <*> f y
 instead of:         traverse f (T x y) = T x <$> f y
+-}
 
-\begin{code}
 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 gen_Traversable_binds loc tycon
   = (unitBag traverse_bind, emptyBag)
@@ -1901,13 +1886,13 @@ gen_Traversable_binds loc tycon
     mkApCon con []     = nlHsApps pure_RDR [con]
     mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
        where appAp x y = nlHsApps ap_RDR [x,y]
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                      Newtype-deriving instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 We take every method in the original instance and `coerce` it to fit
 into the derived instance. We need a type annotation on the argument
@@ -1915,8 +1900,8 @@ to `coerce` to make it obvious what instantiation of the method we're
 coercing from.
 
 See #8503 for more discussion.
+-}
 
-\begin{code}
 mkCoerceClassMethEqn :: Class   -- the class being derived
                      -> [TyVar] -- the tvs in the instance head
                      -> [Type]  -- instance head parameters (incl. newtype)
@@ -1966,13 +1951,13 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
 
     nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName
     nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 \begin{verbatim}
 data Foo ... = ...
@@ -1984,8 +1969,8 @@ maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
 
 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
 fiddling around.
+-}
 
-\begin{code}
 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
 genAuxBindSpec loc (DerivCon2Tag tycon)
   = (mk_FunBind loc rdr_name eqns,
@@ -2076,16 +2061,15 @@ mkParentType tc
   = case tyConFamInst_maybe tc of
        Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
        Just (fam_tc,tys) -> mkTyConApp fam_tc tys
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Utility bits for generating bindings}
-%*                                                                      *
-%************************************************************************
-
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mk_FunBind :: SrcSpan -> RdrName
            -> [([LPat RdrName], LHsExpr RdrName)]
            -> LHsBind RdrName
@@ -2106,9 +2090,7 @@ mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
               then [mkMatch [] (error_Expr str) emptyLocalBinds]
               else matches
    str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
-\end{code}
 
-\begin{code}
 box_if_necy :: String           -- The class involved
             -> TyCon            -- The tycon involved
             -> LHsExpr RdrName  -- The argument
@@ -2172,9 +2154,7 @@ eq_Expr tycon ty a b
     | otherwise               = genPrimOpApp a prim_eq b
  where
    (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
-\end{code}
 
-\begin{code}
 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
 untag_Expr _ [] expr = expr
 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
@@ -2246,9 +2226,7 @@ genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
 
 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
-\end{code}
 
-\begin{code}
 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
     :: RdrName
 a_RDR           = mkVarUnqual (fsLit "a")
@@ -2324,8 +2302,8 @@ mkAuxBinderName parent occ_fun
 
     parent_uniq = nameUnique parent
     parent_occ  = nameOccName parent
-\end{code}
 
+{-
 Note [Auxiliary binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 We often want to make a top-level auxiliary binding.  E.g. for comparison we haev
@@ -2347,3 +2325,4 @@ OccName we generate for the new binding.
 In the past we used mkDerivedRdrName name occ_fun, which made an original name
 But:  (a) that does not work well for standalone-deriving either
       (b) an unqualified name is just fine, provided it can't clash with user code
+-}
similarity index 97%
rename from compiler/typecheck/TcGenGenerics.lhs
rename to compiler/typecheck/TcGenGenerics.hs
index 5bb0862..b4f9ae0 100644 (file)
@@ -1,11 +1,11 @@
-%
-(c) The University of Glasgow 2011
-%
+{-
+(c) The University of Glasgow 2011
+
 
 The deriving code for the Generic class
 (equivalent to the code in TcGenDeriv, for other classes)
+-}
 
-\begin{code}
 {-# LANGUAGE CPP, ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 
@@ -48,13 +48,13 @@ import Util
 import Control.Monad (mplus,forM)
 
 #include "HsVersions.h"
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Bindings for the new generic deriving mechanism}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 For the generic representation we need to generate:
 \begin{itemize}
@@ -62,8 +62,8 @@ For the generic representation we need to generate:
 \item A Rep type instance
 \item Many auxiliary datatypes and instances for them (for the meta-information)
 \end{itemize}
+-}
 
-\begin{code}
 gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module
                  -> TcM (LHsBinds RdrName, FamInst)
 gen_Generic_binds gk tc metaTyCons mod = do
@@ -178,15 +178,15 @@ metaTyConsToDerivStuff tc metaDts =
 
       return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts)
                `unionBags` listToBag (d_mkInst : c_mkInst ++ concat s_mkInst)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Generating representation types}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 get_gen1_constrained_tys :: TyVar -> Type -> [Type]
 -- called by TcDeriv.inferConstraints; generates a list of types, each of which
 -- must be a Functor in order for the Generic1 instance to work.
@@ -396,15 +396,14 @@ canDoGenerics1 rep_tc tc_args =
     wrong_arg   = text "applies a type to an argument involving the last parameter"
                $$ text "but the applied type is not of kind * -> *"
 
-\end{code}
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Generating the RHS of a generic default method}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 type US = Int   -- Local unique supply, just a plain Int
 type Alt = (LPat RdrName, LHsExpr RdrName)
 
@@ -882,5 +881,3 @@ foldBal' _  x []  = x
 foldBal' _  _ [y] = y
 foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
                     in foldBal' op x a `op` foldBal' op x b
-
-\end{code}
similarity index 95%
rename from compiler/typecheck/TcHsSyn.lhs
rename to compiler/typecheck/TcHsSyn.hs
index 4d4484c..8ad8fe2 100644 (file)
@@ -1,14 +1,14 @@
-%
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1996-1998
-%
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1996-1998
+
 
 TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
 
 This module is an extension of @HsSyn@ syntax, for use in the type
 checker.
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcHsSyn (
@@ -61,17 +61,18 @@ import Util
 #if __GLASGOW_HASKELL__ < 709
 import Data.Traversable ( traverse )
 #endif
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
 then something is wrong.
-\begin{code}
+-}
+
 hsLPatType :: OutPat Id -> Type
 hsLPatType (L _ pat) = hsPatType pat
 
@@ -114,11 +115,9 @@ hsLitType (HsInteger _ _ ty) = ty
 hsLitType (HsRat _ ty)       = ty
 hsLitType (HsFloatPrim _)    = floatPrimTy
 hsLitType (HsDoublePrim _)   = doublePrimTy
-\end{code}
 
-Overloaded literals. Here mainly because it uses isIntTy etc
+-- Overloaded literals. Here mainly because it uses isIntTy etc
 
-\begin{code}
 shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr TcId)
 shortCutLit dflags (HsIntegral src i) ty
   | isIntTy ty  && inIntRange  dflags i = Just (HsLit (HsInt src i))
@@ -150,13 +149,13 @@ hsOverLitName :: OverLitVal -> Name
 hsOverLitName (HsIntegral {})   = fromIntegerName
 hsOverLitName (HsFractional {}) = fromRationalName
 hsOverLitName (HsIsString {})   = fromStringName
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 The rest of the zonking is done *after* typechecking.
 The main zonking pass runs over the bindings
@@ -174,8 +173,8 @@ all occurrences of that Id point to the common zonked copy
 
 It's all pretty boring stuff, because HsSyn is such a large type, and
 the environment manipulation is tiresome.
+-}
 
-\begin{code}
 type UnboundTyVarZonker = TcTyVar-> TcM Type
         -- How to zonk an unbound type variable
         -- Note [Zonking the LHS of a RULE]
@@ -290,10 +289,7 @@ zonkTyBndrX env tv
   = do { ki <- zonkTcTypeToType env (tyVarKind tv)
        ; let tv' = mkTyVar (tyVarName tv) ki
        ; return (extendTyZonkEnv1 env tv', tv') }
-\end{code}
-
 
-\begin{code}
 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
 zonkTopExpr e = zonkExpr emptyZonkEnv e
 
@@ -523,15 +519,15 @@ zonkLTcSpecPrags env ps
     zonk_prag (L loc (SpecPrag id co_fn inl))
         = do { (_, co_fn') <- zonkCoFn env co_fn
              ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 zonkMatchGroup :: ZonkEnv
                -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
                -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
@@ -563,15 +559,15 @@ zonkGRHSs env zBody (GRHSs grhss binds) = do
                return (GRHS new_guarded new_rhs)
     new_grhss <- mapM (wrapLocM zonk_grhs) grhss
     return (GRHSs new_grhss new_binds)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
 zonkLExpr  :: ZonkEnv -> LHsExpr TcId   -> TcM (LHsExpr Id)
 zonkExpr   :: ZonkEnv -> HsExpr TcId    -> TcM (HsExpr Id)
@@ -999,16 +995,15 @@ mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b)
 mapIPNameTc _ (Left x)  = return (Left x)
 mapIPNameTc f (Right x) = do r <- f x
                              return (Right r)
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[BackSubst-Pats]{Patterns}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
 -- Extend the environment as we go, because it's possible for one
 -- pattern to bind something that is used in another (inside or
@@ -1144,16 +1139,15 @@ zonkPats env []         = return (env, [])
 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
                              ; (env', pats') <- zonkPats env1 pats
                              ; return (env', pat':pats') }
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection[BackSubst-Foreign]{Foreign exports}
-%*                                                                      *
-%************************************************************************
-
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
 zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
 
@@ -1162,9 +1156,7 @@ zonkForeignExport env (ForeignExport i _hs_ty co spec) =
    return (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec)
 zonkForeignExport _ for_imp
   = return for_imp     -- Foreign imports don't need zonking
-\end{code}
 
-\begin{code}
 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
 zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
 
@@ -1202,9 +1194,7 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
                     -- DV: used to be return (env,v) but that is plain
                     -- wrong because we may need to go inside the kind
                     -- of v and zonk there!
-\end{code}
 
-\begin{code}
 zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
 zonkVects env = mapM (wrapLocM (zonkVect env))
 
@@ -1227,15 +1217,15 @@ zonkVect _ (HsVectClassIn _) = panic "TcHsSyn.zonkVect: HsVectClassIn"
 zonkVect _env (HsVectInstOut i)
   = return $ HsVectInstOut i
 zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
               Constraints and evidence
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
 zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v )
                                     return (EvId (zonkIdOcc env v))
@@ -1294,13 +1284,13 @@ zonkEvBind env (EvBind var term)
                   -> return (EvBind var' (EvCoercion (mkTcReflCo r ty1)))
            _other -> do { term' <- zonkEvTerm env term
                         ; return (EvBind var' term') } }
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                          Zonking types
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [Zonking the LHS of a RULE]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1362,8 +1352,8 @@ use Refl on the right, ignoring the actual coercion on the RHS.
 
 This can have a very big effect, because the constraint solver sometimes does go
 to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf Trac #5030)
+-}
 
-\begin{code}
 zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
 zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
   | isTcTyVar tv
@@ -1485,4 +1475,3 @@ zonkTcCoToCo env co
                                      ; cs' <- mapM go cs
                                      ; return (TcAxiomRuleCo co ts' cs')
                                      }
-\end{code}
similarity index 96%
rename from compiler/typecheck/TcHsType.lhs
rename to compiler/typecheck/TcHsType.hs
index 62611a3..44ba79b 100644 (file)
@@ -1,10 +1,10 @@
-%
-(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
+
 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcHsType (
@@ -70,9 +70,8 @@ import Util
 import Data.Maybe( isNothing )
 import Control.Monad ( unless, when, zipWithM )
 import PrelNames( ipClassName, funTyConKey, allNameStrings )
-\end{code}
-
 
+{-
         ----------------------------
                 General notes
         ----------------------------
@@ -149,13 +148,13 @@ knot around type declarations with ARecThing, so that the fault-in code can get
 the TyCon being defined.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
               Check types AND do validity checking
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type
   -- NB: it's important that the foralls that come from the top-level
   --     HsForAllTy in hs_ty occur *first* in the returned type.
@@ -231,22 +230,22 @@ tcHsVectInst ty
        ; return (cls, arg_tys) }
   | otherwise
   = failWithTc $ ptext (sLit "Malformed instance type")
-\end{code}
 
+{-
         These functions are used during knot-tying in
         type and class declarations, when we have to
         separate kind-checking, desugaring, and validity checking
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
             The main kind checker: no validity checks here
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
         First a couple of simple wrappers for kcHsType
+-}
 
-\begin{code}
 tcClassSigType :: LHsType Name -> TcM Type
 tcClassSigType lhs_ty@(L _ hs_ty)
   = addTypeCtxt lhs_ty $
@@ -305,14 +304,14 @@ tcCheckHsTypeAndGen hs_ty kind
        ; kvs <- zonkTcTypeAndFV ty
        ; kvs <- kindGeneralize kvs
        ; return (mkForAllTys kvs ty) }
-\end{code}
 
+{-
 Like tcExpr, tc_hs_type takes an expected kind which it unifies with
 the kind it figures out. When we don't know what kind to expect, we use
 tc_lhs_type_fresh, to first create a new meta kind variable and use that as
 the expected kind.
+-}
 
-\begin{code}
 tc_infer_lhs_type :: LHsType Name -> TcM (TcType, TcKind)
 tc_infer_lhs_type ty =
   do { kv <- newMetaKindVar
@@ -428,7 +427,7 @@ tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind@(EK exp_k
   = traceTc "tc_hs_type tuple" (ppr hs_tys) >>
     tc_tuple hs_ty tup_sort hs_tys exp_kind
   | otherwise
-  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys) 
+  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)
        ; (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys
        ; kinds <- mapM zonkTcKind kinds
            -- Infer each arg type separately, because errors can be
@@ -692,8 +691,8 @@ aThingErr :: String -> Name -> b
 -- do *kind* checking; and in that case it ignores the type
 -- returned. Which is a good thing since it may not be available yet!
 aThingErr str x = pprPanic "AThing evaluated unexpectedly" (text str <+> ppr x)
-\end{code}
 
+{-
 Note [Zonking inside the knot]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we are checking the argument types of a data constructor.  We
@@ -723,8 +722,8 @@ look at the TyCon or Class involved.
 
 This is horribly delicate.  I hate it.  A good example of how
 delicate it is can be seen in Trac #7903.
+-}
 
-\begin{code}
 mkNakedTyConApp :: TyCon -> [Type] -> Type
 -- Builds a TyConApp
 --   * without being strict in TyCon,
@@ -772,8 +771,8 @@ zonkSigType ty
     go (ForAllTy tv ty) = do { tv' <- zonkTcTyVarBndr tv
                              ; ty' <- go ty
                              ; return (ForAllTy tv' ty') }
-\end{code}
 
+{-
 Note [Body kind of a forall]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The body of a forall is usually a type, but in principle
@@ -890,8 +889,8 @@ want to default it to '*', not to AnyK.
 
 Help functions for type applications
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-}
 
-\begin{code}
 addTypeCtxt :: LHsType Name -> TcM a -> TcM a
         -- Wrap a context around only if we want to show that contexts.
         -- Omit invisble ones and ones user's won't grok
@@ -899,15 +898,14 @@ addTypeCtxt (L _ ty) thing
   = addErrCtxt doc thing
   where
     doc = ptext (sLit "In the type") <+> quotes (ppr ty)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Type-variable binders
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
+*                                                                      *
+************************************************************************
+-}
 
 mkKindSigVar :: Name -> TcM KindVar
 -- Use the specified name; don't clone it
@@ -1030,8 +1028,8 @@ kindGeneralize tkvs
                 -- When typechecking the body of the bracket, we typecheck $t to a
                 -- unification variable 'alpha', with no biding forall.  We don't
                 -- want to kind-quantify it!
-\end{code}
 
+{-
 Note [Kind generalisation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 We do kind generalisation only at the outer level of a type signature.
@@ -1066,8 +1064,8 @@ which the type checker will then instantiate, and instantiate does not
 look through unification variables!
 
 Hence using zonked_kinds when forming tvs'.
+-}
 
-\begin{code}
 --------------------
 -- getInitialKind has made a suitably-shaped kind for the type or class
 -- Unpack it, and attribute those kinds to the type variables
@@ -1179,8 +1177,8 @@ badKindSig :: Kind -> SDoc
 badKindSig kind
  = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind"))
         2 (ppr kind)
-\end{code}
 
+{-
 Note [Avoid name clashes for associated data types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider    class C a b where
@@ -1198,11 +1196,11 @@ important only to get nice-looking output when doing ":info C" in GHCi.
 It isn't essential for correctness.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
                 Scoped type variables
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 
 tcAddScopedTyVars is used for scoped type variables added by pattern
@@ -1236,8 +1234,8 @@ Historical note:
            we unify with it too early and checkSigTyVars barfs
            Instead you have to pass in a fresh ty var, and unify
            it with expected_ty afterwards
+-}
 
-\begin{code}
 tcHsPatSigType :: UserTypeCtxt
                -> HsWithBndrs Name (LHsType Name) -- The type signature
                -> TcM ( Type                      -- The signature
@@ -1334,8 +1332,8 @@ patBindSigErr sig_tvs
   = hang (ptext (sLit "You cannot bind scoped type variable") <> plural sig_tvs
           <+> pprQuotedList (map fst sig_tvs))
        2 (ptext (sLit "in a pattern binding signature"))
-\end{code}
 
+{-
 Note [Pattern signature binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -1379,19 +1377,19 @@ I think we could solve this by recording in a SigTv a list of all the
 in-scope varaibles that it should not unify with, but it's fiddly.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
         Checking kinds
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 We would like to get a decent error message from
   (a) Under-applied type constructors
              f :: (Maybe, Maybe)
   (b) Over-applied type constructors
              f :: Int x -> Int x
+-}
 
-\begin{code}
 -- The ExpKind datatype means "expected kind" and contains
 -- some info about just why that kind is expected, to improve
 -- the error message on a mis-match
@@ -1515,20 +1513,19 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt)
       ; traceTc "checkExpectedKind 1" (ppr ty $$ ppr tidy_act_kind $$ ppr tidy_exp_kind $$ ppr env1 $$ ppr env2)
       ; failWithTcM (env2, err) } } }
 
-\end{code}
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Sort checking kinds
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 tcLHsKind converts a user-written kind to an internal, sort-checked kind.
 It does sort checking and desugaring at the same time, in one single pass.
 It fails when the kinds are not well-formed (eg. data A :: * Int), or if there
 are non-promotable or non-fully applied kinds.
+-}
 
-\begin{code}
 tcLHsKind :: LHsKind Name -> TcM Kind
 tcLHsKind k = addErrCtxt (ptext (sLit "In the kind") <+> quotes (ppr k)) $
               tc_lhs_kind k
@@ -1642,15 +1639,15 @@ promotionErr name err
                FamDataConPE -> ptext (sLit "it comes from a data family instance")
                NoDataKinds  -> ptext (sLit "Perhaps you intended to use DataKinds")
                _ -> ptext (sLit "it is defined and used in the same recursive group")
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                 Scoped type variables
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 badPatSigTvs :: TcType -> [TyVar] -> SDoc
 badPatSigTvs sig_ty bad_tvs
   = vcat [ fsep [ptext (sLit "The type variable") <> plural bad_tvs,
@@ -1669,5 +1666,3 @@ unifyKindMisMatch ki1 ki2 = do
                       ptext (sLit "against"),
                       quotes (ppr ki2')])
     failWithTc msg
-\end{code}
-
similarity index 97%
rename from compiler/typecheck/TcInstDcls.lhs
rename to compiler/typecheck/TcInstDcls.hs
index 553af73..3b182de 100644 (file)
@@ -1,11 +1,11 @@
-%
-(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
+
 
 TcInstDecls: Typechecking instance declarations
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
@@ -62,8 +62,8 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
 import Control.Monad
 import Maybes     ( isNothing, isJust, whenIsJust )
 import Data.List  ( mapAccumL, partition )
-\end{code}
 
+{-
 Typechecking instance declarations is done in two passes. The first
 pass, made by @tcInstDecls1@, collects information to be used in the
 second pass.
@@ -346,15 +346,15 @@ complained if 'b' is mentioned in <rhs>.
 
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Extracting instance decls}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Gather up the instance declarations from their various sources
+-}
 
-\begin{code}
 tcInstDecls1    -- Deal with both source-code and imported instance decls
    :: [LTyClDecl Name]          -- For deriving stuff
    -> [LInstDecl Name]          -- Source code instance decls
@@ -469,8 +469,8 @@ addFamInsts fam_insts thing_inside
     axioms = map (toBranchedAxiom . famInstAxiom) fam_insts
     tycons = famInstsRepTyCons fam_insts
     things = map ATyCon tycons ++ map ACoAxiom axioms
-\end{code}
 
+{-
 Note [Deriving inside TH brackets]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Given a declaration bracket
@@ -486,9 +486,8 @@ The easy solution is simply not to generate the derived instances at
 all.  (A less brutal solution would be to generate them with no
 bindings.)  This will become moot when we shift to the new TH plan, so
 the brutal solution will do.
+-}
 
-
-\begin{code}
 tcLocalInstDecl :: LInstDecl Name
                 -> TcM ([InstInfo Name], [FamInst])
         -- A source-file instance declaration
@@ -595,20 +594,20 @@ tcATDefault inst_subst defined_ats (ATI fam_tc defs)
       = (extendTvSubst subst tc_tv ty', ty')
       where
         ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                Type checking family instances
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Family instances are somewhat of a hybrid.  They are processed together with
 class instance heads, but can contain data constructors and hence they share a
 lot of kinding and type checking code with ordinary algebraic data types (and
 GADTs).
+-}
 
-\begin{code}
 tcFamInstDeclCombined :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable
                       -> Located Name -> TcM TyCon
 tcFamInstDeclCombined mb_clsinfo fam_tc_lname
@@ -736,8 +735,7 @@ tcDataFamInstDecl mb_clsinfo
       = go tvs pats
     go tvs pats = (reverse tvs, reverse pats)
 
-\end{code}
-
+{-
 Note [Eta reduction for data family axioms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this
@@ -766,13 +764,13 @@ See Note [Newtype eta] in TyCon.
 
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
       Type-checking instance declarations, pass 2
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
              -> TcM (LHsBinds Id)
 -- (a) From each class declaration,
@@ -795,8 +793,8 @@ tcInstDecls2 tycl_decls inst_decls
 
           -- Done
         ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
-\end{code}
 
+{-
 See Note [Default methods and instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The default method Ids are already in the type environment (see Note
@@ -809,8 +807,8 @@ particular operation (see Note [INLINE and default methods] below).
 
 So right here in tcInstDecls2 we must re-extend the type envt with
 the default method Ids replete with their INLINE pragmas.  Urk.
+-}
 
-\begin{code}
 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
             -- Returns a binding for the dfun
 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
@@ -980,8 +978,8 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
                             filter isSpecInstLSig uprags
              -- The filter removes the pragmas for methods
        ; return (spec_inst_prags, mkPragFun uprags binds) }
-\end{code}
 
+{-
 Note [Instance method signatures]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 With -XInstanceSigs we allow the user to supply a signature for the
@@ -1150,9 +1148,8 @@ Note that
   * We want to specialise the RHS of both $dfIxPair and $crangePair,
     but the SAME HsWrapper will do for both!  We can call tcSpecPrag
     just once, and pass the result (in spec_inst_info) to tcInstanceMethods.
+-}
 
-
-\begin{code}
 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
   = addErrCtxt (spec_ctxt prag) $
@@ -1165,13 +1162,13 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
 
 tcSpecInst _  _ = panic "tcSpecInst"
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
       Type-checking an instance method
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 tcInstanceMethod
 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
@@ -1180,8 +1177,8 @@ tcInstanceMethod
 - Use sig_fn mapping instance method Name -> instance tyvars
 - Ditto prag_fn
 - Use tcValBinds to do the checking
+-}
 
-\begin{code}
 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
                   -> [EvVar]
                   -> [TcType]
@@ -1223,7 +1220,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
     tc_body sig_fn sel_id rn_bind bndr_loc
       = add_meth_ctxt sel_id rn_bind $
         do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
-           ; (meth_id, local_meth_sig, hs_wrap) 
+           ; (meth_id, local_meth_sig, hs_wrap)
                   <- setSrcSpan bndr_loc $
                      mkMethIds sig_fn clas tyvars dfun_ev_vars
                                inst_tys sel_id
@@ -1274,7 +1271,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
            ; let self_ev_bind = EvBind self_dict
                                 (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars))
 
-           ; (meth_id, local_meth_sig, hs_wrap) 
+           ; (meth_id, local_meth_sig, hs_wrap)
                    <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
            ; dm_id <- tcLookupId dm_name
            ; let dm_inline_prag = idInlinePragma dm_id
@@ -1386,8 +1383,8 @@ warnUnsatisifiedMinimalDefinition mindef
     message = vcat [ptext (sLit "No explicit implementation for")
                    ,nest 2 $ pprBooleanFormulaNice mindef
                    ]
-\end{code}
 
+{-
 Note [Export helper functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We arrange to export the "helper functions" of an instance declaration,
@@ -1489,13 +1486,13 @@ Note carefully:
   in TcSpecPrags.
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Error messages}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 instDeclCtxt1 :: LHsType Name -> SDoc
 instDeclCtxt1 hs_inst_ty
   = inst_decl_ctxt (case unLoc hs_inst_ty of
@@ -1539,4 +1536,3 @@ badFamInstDecl tc_name
 notOpenFamily :: TyCon -> SDoc
 notOpenFamily tc
   = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc)
-\end{code}
similarity index 99%
rename from compiler/typecheck/TcInteract.lhs
rename to compiler/typecheck/TcInteract.hs
index dcac915..ed686da 100644 (file)
@@ -1,4 +1,3 @@
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcInteract (
@@ -49,8 +48,8 @@ import Unique( hasKey )
 import FastString ( sLit )
 import DynFlags
 import Util
-\end{code}
 
+{-
 **********************************************************************
 *                                                                    *
 *                      Main Interaction Solver                       *
@@ -111,9 +110,8 @@ to float. This means that
       [w] xxx[1] ~ s
       [W] forall[2] . (xxx[1] ~ Empty)
                    => Intersect (BuriedUnder sub k Empty) inv ~ Empty
+-}
 
-
-\begin{code}
 solveFlatGivens :: CtLoc -> [EvVar] -> TcS ()
 solveFlatGivens loc givens
   | null givens  -- Shortcut for common case
@@ -345,7 +343,7 @@ runSolverPipeline pipeline workItem
                                             , ptext (sLit "inerts     =") <+> ppr final_is]
                                  ; insertInertItemTcS ct }
        }
-  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct 
+  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct
                      -> TcS (StopOrContinue Ct)
         run_pipeline [] res        = return res
         run_pipeline _ (Stop ev s) = return (Stop ev s)
@@ -355,8 +353,8 @@ runSolverPipeline pipeline workItem
                ; res <- stg ct
                ; traceTcS ("end stage " ++ stg_name ++ " }") empty
                ; run_pipeline stgs res }
-\end{code}
 
+{-
 Example 1:
   Inert:   {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given)
   Reagent: a ~ [b] (given)
@@ -379,15 +377,14 @@ Example 3:
 
 React with (a ~ Int)   ==> IR (ContinueWith (F Int ~ b)) True []
 React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canonicalize and get nothing
+-}
 
-\begin{code}
 thePipeline :: [(String,SimplifierStage)]
 thePipeline = [ ("canonicalization",        TcCanonical.canonicalize)
               , ("interact with inerts",    interactWithInertsStage)
               , ("top-level reactions",     topReactionsStage) ]
-\end{code}
-
 
+{-
 *********************************************************************************
 *                                                                               *
                        The interact-with-inert Stage
@@ -418,8 +415,8 @@ or, equivalently,
    If the work-item is Given,
    and the inert item is Wanted/Derived
    then there is no reaction
+-}
 
-\begin{code}
 -- Interaction result of  WorkItem <~> Ct
 
 type StopNowFlag = Bool    -- True <=> stop after this interaction
@@ -439,9 +436,7 @@ interactWithInertsStage wi
              _ -> pprPanic "interactWithInerts" (ppr wi) }
                 -- CHoleCan are put straight into inert_frozen, so never get here
                 -- CNonCanonical have been canonicalised
-\end{code}
 
-\begin{code}
 data InteractResult = IRKeep | IRReplace | IRDelete
 instance Outputable InteractResult where
   ppr IRKeep    = ptext (sLit "keep")
@@ -475,15 +470,15 @@ solveOneFromTheOther ev_i ev_w
                    -- But the work item *overrides* the inert item (hence IRReplace)
                    -- See Note [Shadowing of Implicit Parameters]
   = return (IRReplace, True)
-\end{code}
 
+{-
 *********************************************************************************
 *                                                                               *
                    interactIrred
 *                                                                               *
 *********************************************************************************
+-}
 
-\begin{code}
 -- Two pieces of irreducible evidence: if their types are *exactly identical*
 -- we can rewrite them. We can never improve using this:
 -- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not
@@ -513,15 +508,15 @@ interactIrred inerts workItem@(CIrredEvCan { cc_ev = ev_w })
   = continueWith workItem
 
 interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
-\end{code}
 
+{-
 *********************************************************************************
 *                                                                               *
                    interactDict
 *                                                                               *
 *********************************************************************************
+-}
 
-\begin{code}
 interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
   | Just ctev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys
@@ -532,7 +527,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs
            IRReplace -> updInertDicts $ \ ds -> addDict ds cls tys workItem
        ; if stop_now then
             return (Stop ev_w (ptext (sLit "Dict equal") <+> parens (ppr inert_effect)))
-         else 
+         else
             continueWith workItem }
 
   | cls `hasKey` ipClassNameKey
@@ -587,8 +582,7 @@ addFunDepWork work_ct inert_ct
     derived_loc = work_loc { ctl_origin = FunDepOrigin1 work_pred  work_loc
                                                         inert_pred inert_loc }
 
-\end{code}
-
+{-
 Note [Shadowing of Implicit Parameters]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following example:
@@ -644,8 +638,8 @@ I can think of two ways to fix this:
                    interactFunEq
 *                                                                               *
 *********************************************************************************
+-}
 
-\begin{code}
 interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 -- Try interacting the work item with the inert set
 interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
@@ -672,7 +666,7 @@ interactFunEq inerts workItem@(CFunEqCan { cc_ev = ev, cc_fun = tc
   = do { let matching_funeqs = findFunEqsByTyCon funeqs tc
        ; let interact = sfInteractInert ops args (lookupFlattenTyVar eqs fsk)
              do_one (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = iev })
-                = mapM_ (emitNewDerivedEq (ctEvLoc iev)) 
+                = mapM_ (emitNewDerivedEq (ctEvLoc iev))
                         (interact iargs (lookupFlattenTyVar eqs ifsk))
              do_one ct = pprPanic "interactFunEq" (ppr ct)
        ; mapM_ do_one matching_funeqs
@@ -691,7 +685,7 @@ interactFunEq _ wi = pprPanic "interactFunEq" (ppr wi)
 
 lookupFlattenTyVar :: TyVarEnv EqualCtList -> TcTyVar -> TcType
 -- ^ Look up a flatten-tyvar in the inert TyVarEqs
-lookupFlattenTyVar inert_eqs ftv 
+lookupFlattenTyVar inert_eqs ftv
   = case lookupVarEnv inert_eqs ftv of
       Just (CTyEqCan { cc_rhs = rhs } : _) -> rhs
       _                                    -> mkTyVarTy ftv
@@ -712,8 +706,8 @@ reactFunEq from_this fuv1 (CtWanted { ctev_evar = evar }) fuv2
 
 reactFunEq _ _ solve_this@(CtDerived {}) _
   = pprPanic "reactFunEq" (ppr solve_this)
-\end{code}
 
+{-
 Note [Cache-caused loops]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
@@ -801,8 +795,8 @@ test when solving pairwise CFunEqCan.
                    interactTyVarEq
 *                                                                               *
 *********************************************************************************
+-}
 
-\begin{code}
 interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
 -- CTyEqCans are always consumed, so always returns Stop
 interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv, cc_rhs = rhs , cc_ev = ev })
@@ -891,7 +885,7 @@ solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()
 --     say that in (a ~ xi), the type variable a does not appear in xi.
 --     See TcRnTypes.Ct invariants.
 --
--- Post: tv is unified (by side effect) with xi; 
+-- Post: tv is unified (by side effect) with xi;
 --       we often write tv := xi
 solveByUnification wd tv xi
   = do { let tv_ty = mkTyVarTy tv
@@ -921,9 +915,7 @@ givenFlavour = CtGiven { ctev_pred = panic "givenFlavour:ev"
 ppr_kicked :: Int -> SDoc
 ppr_kicked 0 = empty
 ppr_kicked n = parens (int n <+> ptext (sLit "kicked out"))
-\end{code}
 
-\begin{code}
 kickOutRewritable :: CtEvidence   -- Flavour of the equality that is
                                   -- being added to the inert set
                   -> TcTyVar      -- The new equality is tv ~ ty
@@ -995,8 +987,8 @@ kick_out new_ev new_tv (IC { inert_eqs = tv_eqs
                                (eq1:_) -> extendVarEnv acc_in (cc_tyvar eq1) eqs_in)
       where
         (eqs_out, eqs_in) = partition kick_out_ct eqs
-\end{code}
 
+{-
 Note [Kicking out inert constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Given a new (a -> ty) inert, we want to kick out an existing inert
@@ -1024,7 +1016,7 @@ because (~) has kind forall k. k -> k -> Constraint.  So the constraint
 itself is ill-kinded.  We can "see" k1 but not k2.  That's why we use
 closeOverKinds to make sure we see k2.
 
-This is not pretty. Maybe (~) should have kind 
+This is not pretty. Maybe (~) should have kind
    (~) :: forall k1 k1. k1 -> k2 -> Constraint
 
 Note [Kick out insolubles]
@@ -1436,11 +1428,11 @@ then the no-superclass thing kicks in.  WATCH OUT if you fiddle
 with InstLocOrigin!
 
 
-%************************************************************************
-%*                                                                      *
-%*          Functional dependencies, instantiation of equations
-%*                                                                      *
-%************************************************************************
+************************************************************************
+*                                                                      *
+*          Functional dependencies, instantiation of equations
+*                                                                      *
+************************************************************************
 
 When we spot an equality arising from a functional dependency,
 we now use that equality (a "wanted") to rewrite the work-item
@@ -1457,8 +1449,8 @@ constraint right away.  This avoids two dangers
 
 To achieve this required some refactoring of FunDeps.lhs (nicer
 now!).
+-}
 
-\begin{code}
 rewriteWithFunDeps :: [Equation CtLoc] -> TcS ()
 -- NB: The returned constraints are all Derived
 -- Post: returns no trivial equalities (identities) and all EvVars returned are fresh
@@ -1473,16 +1465,15 @@ instFunDepEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })
   where
     do_one subst (FDEq { fd_ty_left = ty1, fd_ty_right = ty2 })
        = emitNewDerivedEq loc (Pair (Type.substTy subst ty1) (Type.substTy subst ty2))
-\end{code}
-
 
+{-
 *********************************************************************************
 *                                                                               *
                        The top-reaction Stage
 *                                                                               *
 *********************************************************************************
+-}
 
-\begin{code}
 topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
 topReactionsStage wi
  = do { inerts <- getTcSInerts
@@ -1690,8 +1681,8 @@ dischargeFmv evar fmv co xi
        ; setEvBind evar (EvCoercion co)
        ; n_kicked <- kickOutRewritable givenFlavour fmv
        ; traceTcS "dischargeFuv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) }
-\end{code}
 
+{-
 Note [Cached solved FunEqs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When trying to solve, say (FunExpensive big-type ~ ty), it's important
@@ -1935,8 +1926,8 @@ Conclusion, we will (correctly) end up with the unsolved goals
 
 NB: The desugarer needs be more clever to deal with equalities
     that participate in recursive dictionary bindings.
+-}
 
-\begin{code}
 data LookupInstResult
   = NoInstance
   | GenInst [CtEvidence] EvTerm
@@ -2169,8 +2160,8 @@ requestCoercible loc ty1 ty2
            -- Evidence for a Coercible constraint is always a coercion t1 ~R t2
   where
      loc' = bumpCtLocDepth CountConstraints loc
-\end{code}
 
+{-
 Note [Coercible Instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 The class Coercible is special: There are no regular instances, and the user
@@ -2251,7 +2242,7 @@ we'd unwrap the newtype (on both sides) to get
 whic succeeds.
 
 So our current decision is to apply case 3 (newtype-unwrapping) first,
-followed by decomposition (case 4).  This is strictly more powerful 
+followed by decomposition (case 4).  This is strictly more powerful
 if the newtype constructor is in scope.  See Trac #9117 for a discussion.
 
 Note [Instance and Given overlap]
@@ -2293,3 +2284,4 @@ overlapping checks. There we are interested in validating the following principl
 
 But for the Given Overlap check our goal is just related to completeness of
 constraint solving.
+-}
similarity index 89%
rename from compiler/typecheck/TcMType.lhs
rename to compiler/typecheck/TcMType.hs
index c7f1418..d5a2781 100644 (file)
@@ -1,14 +1,14 @@
-%
-(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
+
 
 Monadic type operations
 
 This module contains monadic operations over types that contain
 mutable type variables
+-}
 
-\begin{code}
 {-# LANGUAGE CPP #-}
 
 module TcMType (
@@ -88,16 +88,15 @@ import Bag
 
 import Control.Monad
 import Data.List        ( partition, mapAccumL )
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         Kind variables
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 mkKindName :: Unique -> Name
 mkKindName unique = mkSystemName unique kind_var_occ
 
@@ -113,16 +112,15 @@ newMetaKindVar = do { uniq <- newUnique
 
 newMetaKindVars :: Int -> TcM [TcKind]
 newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ())
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
      Evidence variables; range over constraints we can abstract over
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 newEvVars :: TcThetaType -> TcM [EvVar]
 newEvVars theta = mapM newEvVar theta
 
@@ -155,15 +153,15 @@ predTypeOccName ty = case classifyPredType ty of
     EqPred _ _      -> mkVarOccFS (fsLit "cobox")
     TuplePred _     -> mkVarOccFS (fsLit "tup")
     IrredPred _     -> mkVarOccFS (fsLit "irred")
-\end{code}
 
+{-
 *********************************************************************************
 *                                                                               *
 *                   Wanted constraints
 *                                                                               *
 *********************************************************************************
+-}
 
-\begin{code}
 newFlatWanted :: CtOrigin -> PredType -> TcM Ct
 newFlatWanted orig pty
   = do loc <- getCtLoc orig
@@ -175,15 +173,15 @@ newFlatWanted orig pty
 
 newFlatWanteds :: CtOrigin -> ThetaType -> TcM [Ct]
 newFlatWanteds orig = mapM (newFlatWanted orig)
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         SkolemTvs (immutable)
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcInstType :: ([TyVar] -> TcM (TvSubst, [TcTyVar]))     -- How to instantiate the type variables
            -> TcType                                    -- Type to instantiate
            -> TcM ([TcTyVar], TcThetaType, TcType)      -- Result
@@ -286,8 +284,8 @@ instSkolTyVarX mk_tv subst tyvar
   where
     old_name = tyVarName tyvar
     kind     = substTy subst (tyVarKind tyvar)
-\end{code}
 
+{-
 Note [Kind substitution when instantiating]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we instantiate a bunch of kind and type variables, first we
@@ -304,13 +302,13 @@ instead of the buggous
   [(?k1 :: BOX), (?k2 :: BOX), (?a :: k1 -> k2), (?b :: k1)]
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
         MetaTvs (meta type variables; mutable)
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
 -- Make a new meta tyvar out of thin air
 newMetaTyVar meta_info kind
@@ -440,16 +438,15 @@ writeMetaTyVarRef tyvar ref ty
   where
     tv_kind = tyVarKind tyvar
     ty_kind = typeKind ty
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
         MetaTvs: TauTvs
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 newFlexiTyVar :: Kind -> TcM TcTyVar
 newFlexiTyVar kind = newMetaTyVar (TauTv False) kind
 
@@ -484,14 +481,13 @@ tcInstTyVarX subst tyvar
               kind   = substTy subst (tyVarKind tyvar)
               new_tv = mkTcTyVar name kind details
         ; return (extendTvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
              Quantification
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 Note [quantifyTyVars]
 ~~~~~~~~~~~~~~~~~~~~~
@@ -510,8 +506,8 @@ also free in the type.  Eg
 has free vars {k,a}.  But the type (see Trac #7916)
     (f::k->*) (a::k)
 has free vars {f,a}, but we must add 'k' as well! Hence step (3).
+-}
 
-\begin{code}
 quantifyTyVars :: TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar]
 -- See Note [quantifyTyVars]
 -- The input is a mixture of type and kind variables; a kind variable k
@@ -619,8 +615,8 @@ skolemiseUnboundMetaTyVar tv details
     generaliseWildcardVarName name | startsWithUnderscore name
       = mkOccNameFS (occNameSpace name) (appendFS (fsLit "w") (occNameFS name))
     generaliseWildcardVarName name = name
-\end{code}
 
+{-
 Note [Zonking to Skolem]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 We used to zonk quantified type variables to regular TyVars.  However, this
@@ -687,17 +683,17 @@ Consider this:
 All very silly.   I think its harmless to ignore the problem.  We'll end up with
 a \/\a in the final result but all the occurrences of a will be zonked to ()
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
               Zonking types
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 To improve subsequent calls to the same function it writes the zonked set back into
 the environment.
+-}
 
-\begin{code}
 tcGetGlobalTyVars :: TcM TcTyVarSet
 tcGetGlobalTyVars
   = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
@@ -706,9 +702,7 @@ tcGetGlobalTyVars
        ; writeMutVar gtv_var gbl_tvs'
        ; return gbl_tvs' }
   where
-\end{code}
 
-\begin{code}
 zonkTcTypeAndFV :: TcType -> TcM TyVarSet
 -- Zonk a type and take its free variables
 -- With kind polymorphism it can be essential to zonk *first*
@@ -746,15 +740,15 @@ zonkTcThetaType theta = mapM zonkTcPredType theta
 
 zonkTcPredType :: TcPredType -> TcM TcPredType
 zonkTcPredType = zonkTcType
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
               Zonking constraints
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 zonkImplication :: Implication -> TcM (Bag Implication)
 zonkImplication implic@(Implic { ic_skols  = skols
                                , ic_given  = given
@@ -787,9 +781,7 @@ zonkWCRec (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
        ; implic' <- flatMapBagM zonkImplication implic
        ; insol'  <- zonkFlats insol
        ; return (WC { wc_flat = flat', wc_impl = implic', wc_insol = insol' }) }
-\end{code}
 
-\begin{code}
 zonkFlats :: Cts -> TcM Cts
 zonkFlats cts = do { cts' <- mapBagM zonkCt' cts
                    ; traceTc "zonkFlats done:" (ppr cts')
@@ -825,19 +817,17 @@ zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys
   where
     do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }
 zonkSkolemInfo skol_info = return skol_info
-\end{code}
-
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}
-%*                                                                      *
-%*              For internal use only!                                  *
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+*              For internal use only!                                  *
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 -- zonkId is used *during* typechecking just to zonk the Id's type
 zonkId :: TcId -> TcM TcId
 zonkId id
@@ -908,30 +898,26 @@ zonkTcTyVar tv
   where
     zonk_kind_and_return = do { z_tv <- zonkTyVarKind tv
                               ; return (TyVarTy z_tv) }
-\end{code}
 
-
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                         Zonking kinds
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 zonkTcKind :: TcKind -> TcM TcKind
 zonkTcKind k = zonkTcType k
-\end{code}
-
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
                  Tidying
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
 zonkTidyTcType env ty = do { ty' <- zonkTcType ty
                            ; return (tidyOpenType env ty') }
@@ -1008,15 +994,14 @@ tidySkolemInfo env (UnifyForAllSkol skol_tvs ty)
     ty'               = tidyType env2 ty
 
 tidySkolemInfo env info = (env, info)
-\end{code}
-%************************************************************************
-%*                                                                      *
-        (Named) Wildcards
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
 
+{-
+************************************************************************
+*                                                                      *
+        (Named) Wildcards
+*                                                                      *
+************************************************************************
+-}
 
 -- | Create a new meta var with the given kind. This meta var should be used
 -- to replace a wildcard in a type. Such a wildcard meta var can be
@@ -1037,4 +1022,3 @@ newWildcardVarMetaKind name = do kind <- newMetaKindVar
 isWildcardVar :: TcTyVar -> Bool
 isWildcardVar tv | isTcTyVar tv, MetaTv (TauTv True) _ _ <- tcTyVarDetails tv = True
 isWildcardVar _ = False
-\end{code}
similarity index 95%
rename from compiler/typecheck/TcMatches.lhs
rename to compiler/typecheck/TcMatches.hs
index b4e3180..dda97d1 100644 (file)
@@ -1,11 +1,11 @@
-%
-(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
+
 
 TcMatches: Typecheck some @Matches@
+-}
 
-\begin{code}
 {-# LANGUAGE CPP, RankNTypes #-}
 
 module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
@@ -43,13 +43,13 @@ import MkCore
 import Control.Monad
 
 #include "HsVersions.h"
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{tcMatchesFun, tcMatchesCase}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
 @FunMonoBind@.  The second argument is the name of the function, which
@@ -61,8 +61,8 @@ Note [Polymorphic expected type for tcMatchesFun]
 tcMatchesFun may be given a *sigma* (polymorphic) type
 so it must be prepared to use tcGen to skolemise it.
 See Note [sig_tau may be polymorphic] in TcPat.
+-}
 
-\begin{code}
 tcMatchesFun :: Name -> Bool
              -> MatchGroup Name (LHsExpr Name)
              -> TcSigmaType     -- Expected type of function
@@ -89,12 +89,12 @@ tcMatchesFun fun_name inf matches exp_ty
     herald = ptext (sLit "The equation(s) for")
              <+> quotes (ppr fun_name) <+> ptext (sLit "have")
     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
-\end{code}
 
+{-
 @tcMatchesCase@ doesn't do the argument-count check because the
 parser guarantees that each equation has exactly one argument.
+-}
 
-\begin{code}
 tcMatchesCase :: (Outputable (body Name)) =>
                  TcMatchCtxt body                             -- Case context
               -> TcRhoType                                    -- Type of scrutinee
@@ -123,11 +123,9 @@ tcMatchLambda match res_ty
                 ptext (sLit "has")]
     match_ctxt = MC { mc_what = LambdaExpr,
                       mc_body = tcBody }
-\end{code}
 
-@tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
+-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 
-\begin{code}
 tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType
            -> TcM (GRHSs TcId (LHsExpr TcId))
 -- Used for pattern bindings
@@ -135,10 +133,7 @@ tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
   where
     match_ctxt = MC { mc_what = PatBindRhs,
                       mc_body = tcBody }
-\end{code}
-
 
-\begin{code}
 matchFunTys
   :: SDoc       -- See Note [Herald for matchExpecteFunTys] in TcUnify
   -> Arity
@@ -153,15 +148,15 @@ matchFunTys herald arity res_ty thing_inside
   = do  { (co, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
         ; res <- thing_inside pat_tys res_ty
         ; return (coToHsWrapper (mkTcSymCo co), res) }
-\end{code}
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{tcMatch}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcMatches :: (Outputable (body Name)) => TcMatchCtxt body
           -> [TcSigmaType]      -- Expected pattern types
           -> TcRhoType          -- Expected result-type of the Match.
@@ -236,16 +231,15 @@ tcGRHS ctxt res_ty (GRHS guards rhs)
         ; return (GRHS guards' rhs') }
   where
     stmt_ctxt  = PatGuard (mc_what ctxt)
-\end{code}
-
 
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
+-}
 
-\begin{code}
 tcDoStmts :: HsStmtContext Name
           -> [LStmt Name (LHsExpr Name)]
           -> TcRhoType
@@ -282,16 +276,14 @@ tcBody body res_ty
         ; body' <- tcMonoExpr body res_ty
         ; return body'
         }
-\end{code}
 
-
-%************************************************************************
-%*                                                                      *
+{-
+************************************************************************
+*                                                                      *
 \subsection{tcStmts}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
+*                                                                      *
+************************************************************************
+-}
 
 type TcExprStmtChecker = TcStmtChecker HsExpr
 type TcCmdStmtChecker  = TcStmtChecker HsCmd
@@ -826,8 +818,8 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 
 tcDoStmt _ stmt _ _
   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
-\end{code}
 
+{-
 Note [Treat rebindable syntax first]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When typechecking
@@ -839,16 +831,16 @@ Otherwise the error shows up when cheking the rebindable syntax, and
 the expected/inferred stuff is back to front (see Trac #3613).
 
 
-%************************************************************************
-%*                                                                      *
+************************************************************************
+*                                                                      *
 \subsection{Errors and contexts}
-%*                                                                      *
-%************************************************************************
+*                                                                      *
+************************************************************************
 
 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 number of args are used in each equation.
+-}
 
-\begin{code}
 checkArgs :: Name -> MatchGroup Name body -> TcM ()
 checkArgs _ (MG { mg_alts = [] })
     = return ()
@@ -866,5 +858,3 @@ checkArgs fun (MG { mg_alts = match1:matches })
 
     args_in_match :: LMatch Name body -> Int
     args_in_match (L _ (Match pats _ _)) = length pats
-\end{code}
-
similarity index 95%
rename from compiler/typecheck/TcMatches.lhs-boot
rename to compiler/typecheck/TcMatches.hs-boot
index 1fe05ec..50bad30 100644 (file)
@@ -1,4 +1,3 @@
-\begin{code}
 module TcMatches where
 import HsSyn    ( GRHSs, MatchGroup, LHsExpr )
 import TcEvidence( HsWrapper )
@@ -15,4 +14,3 @@ tcMatchesFun :: Name -> Bool
              -> MatchGroup Name (LHsExpr Name)
              -> TcRhoType
              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
-\end{code}