Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics
[ghc.git] / compiler / iface / TcIface.lhs
index ba1da60..7ac95b1 100644 (file)
@@ -21,6 +21,7 @@ import BuildTyCl
 import TcRnMonad
 import TcType
 import Type
+import Coercion
 import TypeRep
 import HscTypes
 import Annotations
@@ -39,8 +40,7 @@ import TyCon
 import DataCon
 import TysWiredIn
 import TysPrim         ( anyTyConOfKind )
-import Var              ( TyVar )
-import BasicTypes      ( nonRuleLoopBreaker )
+import BasicTypes      ( Arity, nonRuleLoopBreaker )
 import qualified Var
 import VarEnv
 import Name
@@ -433,7 +433,6 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
                          ifCons = rdr_cons, 
                          ifRec = is_rec, 
-                         ifGeneric = want_generic,
                          ifFamInst = mb_family })
   = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
     { tc_name <- lookupIfaceTop occ_name
@@ -442,7 +441,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
            ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
            ; mb_fam_inst  <- tcFamInst mb_family
            ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
-                           want_generic gadt_syn parent mb_fam_inst
+                           gadt_syn parent mb_fam_inst
            })
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
@@ -791,20 +790,56 @@ tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceTy
 tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePredType st; return (PredTy st') }
+tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') }
+tcIfaceType t@(IfaceCoConApp {})  = pprPanic "tcIfaceType" (ppr t)
 
 tcIfaceTypes :: [IfaceType] -> IfL [Type]
 tcIfaceTypes tys = mapM tcIfaceType tys
 
 -----------------------------------------
-tcIfacePredType :: IfacePredType -> IfL PredType
-tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
-tcIfacePredType (IfaceIParam ip t)   = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
-tcIfacePredType (IfaceEqPred t1 t2)  = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') }
+tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a)
+tcIfacePred tc (IfaceClassP cls ts)
+  = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') }
+tcIfacePred tc (IfaceIParam ip t)
+  = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') }
+tcIfacePred tc (IfaceEqPred t1 t2)
+  = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') }
 
 -----------------------------------------
 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
-tcIfaceCtxt sts = mapM tcIfacePredType sts
+tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+                       Coercions
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+tcIfaceCo :: IfaceType -> IfL Coercion
+tcIfaceCo (IfaceTyVar n)        = mkCoVarCo <$> tcIfaceCoVar n
+tcIfaceCo (IfaceAppTy t1 t2)    = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceFunTy t1 t2)    = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
+tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
+tcIfaceCo (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' ->
+                                  mkForAllCo tv' <$> tcIfaceCo t
+-- tcIfaceCo (IfacePredTy co)      = mkPredCo <$> tcIfacePred tcIfaceCo co
+tcIfaceCo (IfacePredTy _)      = panic "tcIfaceCo"
+
+tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
+tcIfaceCoApp IfaceReflCo    [t]     = Refl         <$> tcIfaceType t
+tcIfaceCoApp (IfaceCoAx n)  ts      = AxiomInstCo  <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
+tcIfaceCoApp IfaceUnsafeCo  [t1,t2] = UnsafeCo     <$> tcIfaceType t1 <*> tcIfaceType t2
+tcIfaceCoApp IfaceSymCo     [t]     = SymCo        <$> tcIfaceCo t
+tcIfaceCoApp IfaceTransCo   [t1,t2] = TransCo      <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCoApp IfaceInstCo    [t1,t2] = InstCo       <$> tcIfaceCo t1 <*> tcIfaceType t2
+tcIfaceCoApp (IfaceNthCo d) [t]     = NthCo d      <$> tcIfaceCo t
+tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
+
+tcIfaceCoVar :: FastString -> IfL CoVar
+tcIfaceCoVar = tcIfaceLclId
 \end{code}
 
 
@@ -819,6 +854,12 @@ tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
 tcIfaceExpr (IfaceType ty)
   = Type <$> tcIfaceType ty
 
+tcIfaceExpr (IfaceCo co)
+  = Coercion <$> tcIfaceCo co
+
+tcIfaceExpr (IfaceCast expr co)
+  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
+
 tcIfaceExpr (IfaceLcl name)
   = Var <$> tcIfaceLclId name
 
@@ -853,7 +894,7 @@ tcIfaceExpr (IfaceLam bndr body)
 tcIfaceExpr (IfaceApp fun arg)
   = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
 
-tcIfaceExpr (IfaceCase scrut case_bndr ty alts)  = do
+tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
     scrut' <- tcIfaceExpr scrut
     case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
     let
@@ -868,28 +909,34 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts)  = do
 
     extendIfaceIdEnv [case_bndr'] $ do
      alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
-     ty' <- tcIfaceType ty
-     return (Case scrut' case_bndr' ty' alts')
-
-tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) = do
-    rhs' <- tcIfaceExpr rhs
-    id   <- tcIfaceLetBndr bndr
-    body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
-    return (Let (NonRec id rhs') body')
-
-tcIfaceExpr (IfaceLet (IfaceRec pairs) body) = do
-    ids <- mapM tcIfaceLetBndr bndrs
-    extendIfaceIdEnv ids $ do
-     rhss' <- mapM tcIfaceExpr rhss
-     body' <- tcIfaceExpr body
-     return (Let (Rec (ids `zip` rhss')) body')
-  where
-    (bndrs, rhss) = unzip pairs
-
-tcIfaceExpr (IfaceCast expr co) = do
-    expr' <- tcIfaceExpr expr
-    co' <- tcIfaceType co
-    return (Cast expr' co')
+     return (Case scrut' case_bndr' (coreAltsType alts') alts')
+
+tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
+  = do { name    <- newIfaceName (mkVarOccFS fs)
+       ; ty'     <- tcIfaceType ty
+        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+                              name ty' info
+       ; let id = mkLocalIdWithInfo name ty' id_info
+        ; rhs' <- tcIfaceExpr rhs
+        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
+        ; return (Let (NonRec id rhs') body') }
+
+tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
+  = do { ids <- mapM tc_rec_bndr (map fst pairs)
+       ; extendIfaceIdEnv ids $ do
+       { pairs' <- zipWithM tc_pair pairs ids
+       ; body' <- tcIfaceExpr body
+       ; return (Let (Rec pairs') body') } }
+ where
+   tc_rec_bndr (IfLetBndr fs ty _) 
+     = do { name <- newIfaceName (mkVarOccFS fs)  
+          ; ty'  <- tcIfaceType ty
+          ; return (mkLocalId name ty') }
+   tc_pair (IfLetBndr _ _ info, rhs) id
+     = do { rhs' <- tcIfaceExpr rhs
+          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+                                (idName id) (idType id) info
+          ; return (setIdInfo id id_info, rhs') }
 
 tcIfaceExpr (IfaceNote note expr) = do
     expr' <- tcIfaceExpr expr
@@ -930,14 +977,13 @@ tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
 tcIfaceDataAlt con inst_tys arg_strs rhs
   = do { us <- newUniqueSupply
        ; let uniqs = uniqsFromSupply us
-       ; let (ex_tvs, co_tvs, arg_ids)
+       ; let (ex_tvs, arg_ids)
                      = dataConRepFSInstPat arg_strs uniqs con inst_tys
-              all_tvs = ex_tvs ++ co_tvs
 
-       ; rhs' <- extendIfaceTyVarEnv all_tvs   $
+       ; rhs' <- extendIfaceTyVarEnv ex_tvs    $
                  extendIfaceIdEnv arg_ids      $
                  tcIfaceExpr rhs
-       ; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
+       ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
 \end{code}
 
 
@@ -974,10 +1020,10 @@ do_one (IfaceRec pairs) thing_inside
 \begin{code}
 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
 tcIdDetails _  IfVanillaId = return VanillaId
-tcIdDetails ty IfDFunId
-  = return (DFunId (isNewTyCon (classTyCon cls)))
+tcIdDetails ty (IfDFunId ns)
+  = return (DFunId ns (isNewTyCon (classTyCon cls)))
   where
-    (_, cls, _) = tcSplitDFunTy ty
+    (_, _, cls, _) = tcSplitDFunTy ty
 
 tcIdDetails _ (IfRecSelId tc naughty)
   = do { tc' <- tcIfaceTyCon tc
@@ -1038,8 +1084,26 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
                                                  (UnfWhen unsat_ok boring_ok))
     }
 
-tcUnfolding name ty info (IfWrapper arity wkr)
-  = do         { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
+tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
+  = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops
+       ; return (case mb_ops1 of
+                           Nothing   -> noUnfolding
+                    Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
+  where
+    doc = text "Class ops for dfun" <+> ppr name
+    tc_arg (DFunPolyArg  e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') }
+    tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') }
+    tc_arg (DFunLamArg i)   = return (DFunLamArg i)
+
+tcUnfolding name ty info (IfExtWrapper arity wkr)
+  = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr)
+tcUnfolding name ty info (IfLclWrapper arity wkr)
+  = tcIfaceWrapper name ty info arity (tcIfaceLclId wkr)
+
+-------------
+tcIfaceWrapper :: Name -> Type -> IdInfo -> Arity -> IfL Id -> IfL Unfolding
+tcIfaceWrapper name ty info arity get_worker
+  = do         { mb_wkr_id <- forkM_maybe doc get_worker
        ; us <- newUniqueSupply
        ; return (case mb_wkr_id of
                     Nothing     -> noUnfolding
@@ -1056,15 +1120,7 @@ tcUnfolding name ty info (IfWrapper arity wkr)
        -- before unfolding
     strict_sig = case strictnessInfo info of
                   Just sig -> sig
-                  Nothing  -> pprPanic "Worker info but no strictness for" (ppr wkr)
-
-tcUnfolding name dfun_ty _ (IfDFunUnfold ops)
-  = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
-       ; return (case mb_ops1 of
-                           Nothing   -> noUnfolding
-                    Just ops1 -> mkDFunUnfolding dfun_ty ops1) }
-  where
-    doc = text "Class ops for dfun" <+> ppr name
+                  Nothing  -> pprPanic "Worker info but no strictness for" (ppr name)
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
@@ -1078,22 +1134,30 @@ tcPragExpr name expr
 
                 -- Check for type consistency in the unfolding
     ifDOptM Opt_DoCoreLinting $ do
-        in_scope <- get_in_scope_ids
+        in_scope <- get_in_scope
         case lintUnfolding noSrcLoc in_scope core_expr' of
           Nothing       -> return ()
-          Just fail_msg -> pprPanic "Iface Lint failure" (hang doc 2 fail_msg)
-
+          Just fail_msg -> do { mod <- getIfModule 
+                              ; pprPanic "Iface Lint failure" 
+                                  (vcat [ ptext (sLit "In interface for") <+> ppr mod
+                                        , hang doc 2 fail_msg
+                                        , ppr name <+> equals <+> ppr core_expr'
+                                        , ptext (sLit "Iface expr =") <+> ppr expr ]) }
     return core_expr'
   where
     doc = text "Unfolding of" <+> ppr name
-    get_in_scope_ids   -- Urgh; but just for linting
-       = setLclEnv () $ 
-         do    { env <- getGblEnv 
-               ; case if_rec_types env of {
-                         Nothing -> return [] ;
-                         Just (_, get_env) -> do
-               { type_env <- get_env
-               ; return (typeEnvIds type_env) }}}
+
+    get_in_scope :: IfL [Var] -- Totally disgusting; but just for linting
+    get_in_scope       
+       = do { (gbl_env, lcl_env) <- getEnvs
+             ; rec_ids <- case if_rec_types gbl_env of
+                            Nothing -> return []
+                            Just (_, get_env) -> do
+                               { type_env <- setLclEnv () get_env
+                               ; return (typeEnvIds type_env) }
+             ; return (varEnvElts (if_tv_env lcl_env) ++
+                       varEnvElts (if_id_env lcl_env) ++
+                       rec_ids) }
 \end{code}
 
 
@@ -1187,6 +1251,10 @@ tcIfaceClass :: Name -> IfL Class
 tcIfaceClass name = do { thing <- tcIfaceGlobal name
                       ; return (tyThingClass thing) }
 
+tcIfaceCoAxiom :: Name -> IfL CoAxiom
+tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
+                        ; return (tyThingCoAxiom thing) }
+
 tcIfaceDataCon :: Name -> IfL DataCon
 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
                         ; case thing of
@@ -1223,24 +1291,6 @@ bindIfaceBndrs (b:bs) thing_inside
     bindIfaceBndrs bs  $ \ bs' ->
     thing_inside (b':bs')
 
-
------------------------
-tcIfaceLetBndr :: IfaceLetBndr -> IfL Id
-tcIfaceLetBndr (IfLetBndr fs ty info)
-  = do { name <- newIfaceName (mkVarOccFS fs)
-       ; ty' <- tcIfaceType ty
-       ; case info of
-               NoInfo    -> return (mkLocalId name ty')
-               HasInfo i -> return (mkLocalIdWithInfo name ty' (tc_info i)) } 
-  where
-       -- Similar to tcIdInfo, but much simpler
-    tc_info [] = vanillaIdInfo
-    tc_info (HsInline p     : i) = tc_info i `setInlinePragInfo` p 
-    tc_info (HsArity a      : i) = tc_info i `setArityInfo` a 
-    tc_info (HsStrictness s : i) = tc_info i `setStrictnessInfo` Just s 
-    tc_info (other          : i) = pprTrace "tcIfaceLetBndr: discarding unexpected IdInfo" 
-                                           (ppr other) (tc_info i)
-
 -----------------------
 newExtCoreBndr :: IfaceLetBndr -> IfL Id
 newExtCoreBndr (IfLetBndr var ty _)    -- Ignoring IdInfo for now