path: root/compiler/iface/BuildTyCl.lhs

%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
-- for details

module BuildTyCl (
	buildSynTyCon, buildAlgTyCon, buildDataCon,
	buildClass,
	mkAbstractTyConRhs, mkOpenDataTyConRhs, 
	mkNewTyConRhs, mkDataTyConRhs 
    ) where

#include "HsVersions.h"

import IfaceEnv
import TcRnMonad

import DataCon
import Var
import VarSet
import TysWiredIn
import BasicTypes
import Name
import OccName
import MkId
import Class
import TyCon
import Type
import Coercion

import TcRnMonad
import Outputable

import Data.List
\end{code}
	

\begin{code}
------------------------------------------------------
buildSynTyCon :: Name -> [TyVar] 
              -> SynTyConRhs 
	      -> Maybe (TyCon, [Type])  -- family instance if applicable
              -> TcRnIf m n TyCon

buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
  = let
      kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
    in
    return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
    
buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family
  = do { -- We need to tie a knot as the coercion of a data instance depends
	 -- on the instance representation tycon and vice versa.
       ; tycon <- fixM (\ tycon_rec -> do 
	 { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
	 ; let { tycon   = mkSynTyCon tc_name kind tvs rhs parent
	       ; kind    = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
	       }
         ; return tycon
         })
       ; return tycon 
       }

------------------------------------------------------
buildAlgTyCon :: Name -> [TyVar] 
	      -> ThetaType		-- Stupid theta
	      -> AlgTyConRhs
	      -> RecFlag
	      -> Bool			-- True <=> want generics functions
	      -> Bool			-- True <=> was declared in GADT syntax
	      -> Maybe (TyCon, [Type])  -- family instance if applicable
	      -> TcRnIf m n TyCon

buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
	      mb_family
  = do { -- We need to tie a knot as the coercion of a data instance depends
	 -- on the instance representation tycon and vice versa.
       ; tycon <- fixM (\ tycon_rec -> do 
	 { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
	 ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs
				    fields parent is_rec want_generics gadt_syn
	       ; kind    = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
	       ; fields  = mkTyConSelIds tycon rhs
	       }
         ; return tycon
         })
       ; return tycon 
       }

-- If a family tycon with instance types is given, the current tycon is an
-- instance of that family and we need to
--
-- (1) create a coercion that identifies the family instance type and the
--     representation type from Step (1); ie, it is of the form 
--	   `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion,
--	   `F' the family tycon and `R' the (derived) representation tycon,
--	   and
-- (2) produce a `TyConParent' value containing the parent and coercion
--     information.
--
mkParentInfo :: Maybe (TyCon, [Type]) 
             -> Name -> [TyVar] 
             -> TyCon 
             -> TcRnIf m n TyConParent
mkParentInfo Nothing                  _       _   _         =
  return NoParentTyCon
mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon =
  do { -- Create the coercion
     ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
     ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
                                        family instTys rep_tycon
     ; return $ FamilyTyCon family instTys co_tycon
     }
    
------------------------------------------------------
mkAbstractTyConRhs :: AlgTyConRhs
mkAbstractTyConRhs = AbstractTyCon

mkOpenDataTyConRhs :: AlgTyConRhs
mkOpenDataTyConRhs = OpenTyCon Nothing

mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
mkDataTyConRhs cons
  = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons }

mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
-- Monadic because it makes a Name for the coercion TyCon
-- We pass the Name of the parent TyCon, as well as the TyCon itself,
-- because the latter is part of a knot, whereas the former is not.
mkNewTyConRhs tycon_name tycon con 
  = do	{ co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
	; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs
              cocon_maybe | all_coercions || isRecursiveTyCon tycon 
		          = Just co_tycon
                	  | otherwise              
                	  = Nothing
	; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe)
	; return (NewTyCon { data_con    = con, 
		       	     nt_rhs      = rhs_ty,
		       	     nt_etad_rhs = (etad_tvs, etad_rhs),
 		       	     nt_co 	 = cocon_maybe, 
                             -- Coreview looks through newtypes with a Nothing
                             -- for nt_co, or uses explicit coercions otherwise
		       	     nt_rep = mkNewTyConRep tycon rhs_ty }) }
  where
        -- If all_coercions is True then we use coercions for all newtypes
        -- otherwise we use coercions for recursive newtypes and look through
        -- non-recursive newtypes
    all_coercions = True
    tvs    = tyConTyVars tycon
    rhs_ty = ASSERT(not (null (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs)))) 
	     -- head (dataConInstOrigArgTys con (mkTyVarTys tvs))
	     head (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))
	-- Instantiate the data con with the 
	-- type variables from the tycon
	-- NB: a newtype DataCon has no existentials; hence the
	--     call to dataConInstOrigArgTys has the right type args

    etad_tvs :: [TyVar]	-- Matched lazily, so that mkNewTypeCoercion can
    etad_rhs :: Type	-- return a TyCon without pulling on rhs_ty
			-- See Note [Tricky iface loop] in LoadIface
    (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
 
    eta_reduce :: [TyVar]		-- Reversed
	       -> Type			-- Rhs type
	       -> ([TyVar], Type)	-- Eta-reduced version (tyvars in normal order)
    eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty,
			   Just tv <- getTyVar_maybe arg,
			   tv == a,
			   not (a `elemVarSet` tyVarsOfType fun)
			 = eta_reduce as fun
    eta_reduce tvs ty = (reverse tvs, ty)
				

mkNewTyConRep :: TyCon		-- The original type constructor
	      -> Type		-- The arg type of its constructor
	      -> Type		-- Chosen representation type
-- The "representation type" is guaranteed not to be another newtype
-- at the outermost level; but it might have newtypes in type arguments

-- Find the representation type for this newtype TyCon
-- Remember that the representation type is the *ultimate* representation
-- type, looking through other newtypes.
-- 
-- splitTyConApp_maybe no longer looks through newtypes, so we must
-- deal explicitly with this case
-- 
-- The trick is to to deal correctly with recursive newtypes
-- such as	newtype T = MkT T

mkNewTyConRep tc rhs_ty
  | null (tyConDataCons tc) = unitTy
	-- External Core programs can have newtypes with no data constructors
  | otherwise		    = go [tc] rhs_ty
  where
	-- Invariant: tcs have been seen before
    go tcs rep_ty 
	= case splitTyConApp_maybe rep_ty of
	    Just (tc, tys)
		| tc `elem` tcs -> unitTy	-- Recursive loop
		| isNewTyCon tc -> 
                    if isRecursiveTyCon tc then
			go (tc:tcs) (substTyWith tvs tys rhs_ty)
                    else
                        substTyWith tvs tys rhs_ty
		where
		  (tvs, rhs_ty) = newTyConRhs tc

	    other -> rep_ty 

------------------------------------------------------
buildDataCon :: Name -> Bool
	    -> [StrictnessMark] 
	    -> [Name]			-- Field labels
	    -> [TyVar] -> [TyVar]	-- Univ and ext 
            -> [(TyVar,Type)]           -- Equality spec
	    -> ThetaType		-- Does not include the "stupid theta"
					-- or the GADT equalities
	    -> [Type] -> TyCon
	    -> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
--   a) makes the worker Id
--   b) makes the wrapper Id if necessary, including
--	allocating its unique (hence monadic)
buildDataCon src_name declared_infix arg_stricts field_lbls
	     univ_tvs ex_tvs eq_spec ctxt arg_tys tycon
  = do	{ wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
	; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
	-- This last one takes the name of the data constructor in the source
	-- code, which (for Haskell source anyway) will be in the DataName name
	-- space, and puts it into the VarName name space

	; let
		stupid_ctxt = mkDataConStupidTheta tycon arg_tys univ_tvs
		data_con = mkDataCon src_name declared_infix
				     arg_stricts field_lbls
				     univ_tvs ex_tvs eq_spec ctxt
				     arg_tys tycon
				     stupid_ctxt dc_ids
		dc_ids = mkDataConIds wrap_name work_name data_con

	; returnM data_con }


-- The stupid context for a data constructor should be limited to
-- the type variables mentioned in the arg_tys
-- ToDo: Or functionally dependent on?  
--	 This whole stupid theta thing is, well, stupid.
mkDataConStupidTheta tycon arg_tys univ_tvs
  | null stupid_theta = []	-- The common case
  | otherwise 	      = filter in_arg_tys stupid_theta
  where
    tc_subst	 = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
    stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
	-- Start by instantiating the master copy of the 
	-- stupid theta, taken from the TyCon

    arg_tyvars      = tyVarsOfTypes arg_tys
    in_arg_tys pred = not $ isEmptyVarSet $ 
		      tyVarsOfPred pred `intersectVarSet` arg_tyvars

------------------------------------------------------
mkTyConSelIds :: TyCon -> AlgTyConRhs -> [Id]
mkTyConSelIds tycon rhs
  =  [ mkRecordSelId tycon fld 
     | fld <- nub (concatMap dataConFieldLabels (visibleDataCons rhs)) ]
	-- We'll check later that fields with the same name 
	-- from different constructors have the same type.
\end{code}


------------------------------------------------------
\begin{code}
buildClass :: Name -> [TyVar] -> ThetaType
	   -> [FunDep TyVar]		-- Functional dependencies
	   -> [TyThing]			-- Associated types
	   -> [(Name, DefMeth, Type)]	-- Method info
	   -> RecFlag			-- Info for type constructor
	   -> TcRnIf m n Class

buildClass class_name tvs sc_theta fds ats sig_stuff tc_isrec
  = do	{ traceIf (text "buildClass")
	; tycon_name <- newImplicitBinder class_name mkClassTyConOcc
	; datacon_name <- newImplicitBinder class_name mkClassDataConOcc
		-- The class name is the 'parent' for this datacon, not its tycon,
		-- because one should import the class to get the binding for 
		-- the datacon

	; fixM (\ rec_clas -> do {	-- Only name generation inside loop

	  let { rec_tycon  = classTyCon rec_clas
	      ; op_tys	   = [ty | (_,_,ty) <- sig_stuff]
	      ; op_items   = [ (mkDictSelId op_name rec_clas, dm_info)
			     | (op_name, dm_info, _) <- sig_stuff ] }
	  		-- Build the selector id and default method id

	; dict_con <- buildDataCon datacon_name
				   False 	-- Not declared infix
				   (map (const NotMarkedStrict) op_tys)
				   [{- No labelled fields -}]
				   tvs [{- no existentials -}]
                                   [{- No GADT equalities -}] sc_theta 
                                   op_tys
				   rec_tycon

	; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc) 
				[1..length (dataConDictTheta dict_con)]
	      -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
	      -- can construct names for the selectors.  Thus
	      --      class (C a, C b) => D a b where ...
	      -- gives superclass selectors
	      --      D_sc1, D_sc2
	      -- (We used to call them D_C, but now we can have two different
	      --  superclasses both called C!)
        ; let sc_sel_ids = [mkDictSelId sc_name rec_clas | sc_name <- sc_sel_names]

		-- Use a newtype if the class constructor has exactly one field:
		-- i.e. exactly one operation or superclass taken together
		-- Watch out: the sc_theta includes equality predicates,
		-- 	      which don't count for this purpose; hence dataConDictTheta
	; rhs <- if ((length $ dataConDictTheta dict_con) + length sig_stuff) == 1
		 then mkNewTyConRhs tycon_name rec_tycon dict_con
		 else return (mkDataTyConRhs [dict_con])

	; let {	clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind

 	      ; tycon = mkClassTyCon tycon_name clas_kind tvs
 	                             rhs rec_clas tc_isrec
		-- A class can be recursive, and in the case of newtypes 
		-- this matters.  For example
		-- 	class C a where { op :: C b => a -> b -> Int }
		-- Because C has only one operation, it is represented by
		-- a newtype, and it should be a *recursive* newtype.
		-- [If we don't make it a recursive newtype, we'll expand the
		-- newtype like a synonym, but that will lead to an infinite
		-- type]
	      ; atTyCons = [tycon | ATyCon tycon <- ats]

	      ; result = mkClass class_name tvs fds 
			         sc_theta sc_sel_ids atTyCons
				 op_items tycon
	      }
	; traceIf (text "buildClass" <+> ppr tycon) 
	; return result
	})}
\end{code}