typecheck/TcTypeable.hs

    {-
    (c) The University of Glasgow 2006
    (c) The GRASP/AQUA Project, Glasgow University, 1992-1999
    -}

    module TcTypeable(
        mkTypeableBinds, mkPrimTypeableBinds, mkModIdBindings
      ) where

    import TcBinds( addTypecheckedBinds )
    import IfaceEnv( newGlobalBinder )
    import TcEnv
    import TcRnMonad
    import PrelNames
    import TysPrim ( primTyCons )
    import TysWiredIn ( trModuleTyCon, trModuleDataCon, trTyConTyCon
                      , trTyConDataCon, trNameSDataCon )
    import Id
    import Type
    import TyCon
    import DataCon
    import Name( getOccName )
    import OccName
    import Module
    import HsSyn
    import DynFlags
    import Bag
    import Fingerprint(Fingerprint(..), fingerprintString)
    import Outputable
    import Data.Word( Word64 )
    import FastString ( FastString, mkFastString )

    {- Note [Grand plan for Typeable]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The overall plan is this:

    1. Generate a binding for each module p:M
       (done in TcTypeable by mkModIdBindings)
           M.$trModule :: GHC.Types.Module
           M.$trModule = Module "p" "M"
       ("tr" is short for "type representation"; see GHC.Types)

       We might want to add the filename too.
       This can be used for the lightweight stack-tracing stuff too

       Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv

    2. Generate a binding for every data type declaration T in module M,
           M.$tcT :: GHC.Types.TyCon
           M.$tcT = TyCon ...fingerprint info...
                          $trModule
                          "T"
       We define (in TyCon)
          type TyConRepName = Name
       to use for these M.$tcT "tycon rep names".

    3. Record the TyConRepName in T's TyCon, including for promoted
       data and type constructors, and kinds like * and #.

       The TyConRepName is not an "implicit Id".  It's more like a record
       selector: the TyCon knows its name but you have to go to the
       interface file to find its type, value, etc

    4. Solve Typeable constraints.  This is done by a custom Typeable solver,
       currently in TcInteract, that use M.$tcT so solve (Typeable T).

    There are many wrinkles:

    * Since we generate $tcT for every data type T, the types TyCon and
      Module must be available right from the start; so they are wired in (and
      defined in ghc-prim:GHC.Types).

    * GHC.Prim doesn't have any associated object code, so we need to put the
      representations for types defined in this module elsewhere. We put these
      in GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for injecting
      the bindings for the GHC.Prim representions when compiling GHC.Types.

    * TyCon.tyConRepModOcc is responsible for determining where to find
      the representation binding for a given type. This is where we handle
      the special case for GHC.Prim.

    * To save space and reduce dependencies, we need use quite low-level
      representations for TyCon and Module.  See GHC.Types
      Note [Runtime representation of modules and tycons]

    -}

    {- *********************************************************************
    *                                                                      *
                Building top-level binding for $trModule
    *                                                                      *
    ********************************************************************* -}

    mkModIdBindings :: TcM TcGblEnv
    mkModIdBindings
      = do { mod <- getModule
           ; loc <- getSrcSpanM
           ; mod_nm     <- newGlobalBinder mod (mkVarOcc "$trModule") loc
           ; let mod_id   = mkExportedVanillaId mod_nm
                                                (mkTyConApp trModuleTyCon [])
                 mod_bind = mkVarBind mod_id (mkModIdRHS mod)

           ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
           ; return (tcg_env { tcg_tr_module = Just mod_id }
                     `addTypecheckedBinds` [unitBag mod_bind]) }

    mkModIdRHS :: Module -> LHsExpr Id
    mkModIdRHS mod
      = nlHsApps (dataConWrapId trModuleDataCon)
                 [ trNameLit (unitIdFS (moduleUnitId mod))
                 , trNameLit (moduleNameFS (moduleName mod)) ]

    {- *********************************************************************
    *                                                                      *
                    Building type-representation bindings
    *                                                                      *
    ********************************************************************* -}

    mkTypeableBinds :: [TyCon] -> TcM TcGblEnv
    mkTypeableBinds tycons
      = do { dflags <- getDynFlags
           ; gbl_env <- getGblEnv
           ; mod <- getModule
           ; let pkg_str  = unitIdString (moduleUnitId mod)
                 mod_str  = moduleNameString (moduleName mod)
                 mod_expr = case tcg_tr_module gbl_env of  -- Should be set by now
                               Just mod_id -> nlHsVar mod_id
                               Nothing     -> pprPanic "tcMkTypeableBinds" (ppr tycons)
                 stuff    = (dflags, mod_expr, pkg_str, mod_str)
                 all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
                                 -- We need type representations for any associated types
                 tc_binds = map (mk_typeable_binds stuff) all_tycons
                 tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds

           ; gbl_env <- tcExtendGlobalValEnv tycon_rep_ids getGblEnv
           ; return (gbl_env `addTypecheckedBinds` tc_binds) }

    -- | Generate bindings for the type representation of a wired-in TyCon defined
    -- by the virtual "GHC.Prim" module. This is where we inject the representation
    -- bindings for primitive types into "GHC.Types"
    --
    -- See Note [Grand plan for Typeable] in this module.
    mkPrimTypeableBinds :: TcM TcGblEnv
    mkPrimTypeableBinds
      = do { dflags <- getDynFlags
           ; mod <- getModule
           ; let prim_binds :: LHsBinds Id
                 prim_binds
                   | mod == gHC_TYPES = ghcPrimTypeableBinds dflags
                   | otherwise        = emptyBag
                 prim_rep_ids = collectHsBindsBinders prim_binds
           ; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv
           ; return (gbl_env `addTypecheckedBinds` [prim_binds]) }

    -- | Generate bindings for the type representation of the wired-in TyCons defined
    -- by the virtual "GHC.Prim" module. This differs from the usual
    -- @mkTypeableBinds@ path in that here we need to lie to 'mk_typeable_binds'
    -- about the module we are compiling (since we are currently compiling
    -- "GHC.Types" yet are producing representations for types in "GHC.Prim").
    --
    -- See Note [Grand plan for Typeable] in this module.
    ghcPrimTypeableBinds :: DynFlags -> LHsBinds Id
    ghcPrimTypeableBinds dflags
      = ghc_prim_module_bind `unionBags` unionManyBags (map mkBind all_prim_tys)
      where
        all_prim_tys :: [TyCon]
        all_prim_tys = [ tc' | tc <- funTyCon : primTyCons
                             , tc' <- tc : tyConATs tc ]

        ghc_prim_module_id =
            mkExportedVanillaId trGhcPrimModuleName (mkTyConTy trModuleTyCon)
        ghc_prim_module_bind =
            unitBag $ mkVarBind ghc_prim_module_id (mkModIdRHS gHC_PRIM)

        stuff :: TypeableStuff
        stuff = (dflags, nlHsVar ghc_prim_module_id, "ghc-prim", "GHC.Prim")

        mkBind :: TyCon -> LHsBinds Id
        mkBind = mk_typeable_binds stuff

    trNameLit :: FastString -> LHsExpr Id
    trNameLit fs
      = nlHsApps (dataConWrapId trNameSDataCon) [nlHsLit (mkHsStringPrimLit fs)]

    type TypeableStuff
      = ( DynFlags
        , LHsExpr Id  -- Of type GHC.Types.Module
        , String      -- Package name
        , String      -- Module name
        )

    -- | Make bindings for the type representations of a 'TyCon' and its
    -- promoted constructors.
    mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id
    mk_typeable_binds stuff tycon
      = mkTyConRepBinds stuff tycon
        `unionBags`
        unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon))

    mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
    mkTyConRepBinds stuff tycon
      = case tyConRepName_maybe tycon of
          Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
             where
               rep_id  = mkExportedVanillaId rep_name (mkTyConApp trTyConTyCon [])
               rep_rhs = mkTyConRepRHS stuff tycon
          _ -> emptyBag

    -- | Produce typeable binds for the promoted 'TyCon' of a data constructor
    mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id
    mkTypeableDataConBinds stuff dc
      = mkTyConRepBinds stuff (promoteDataCon dc)

    mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id
    mkTyConRepRHS (dflags, mod_expr, pkg_str, mod_str) tycon = rep_rhs
      where
        rep_rhs = nlHsApps (dataConWrapId trTyConDataCon)
                           [ nlHsLit (word64 high), nlHsLit (word64 low)
                           , mod_expr
                           , trNameLit (mkFastString tycon_str) ]

        tycon_str = add_tick (occNameString (getOccName tycon))
        add_tick s | isPromotedDataCon tycon = '\'' : s
                   | otherwise               = s

        hashThis :: String
        hashThis = unwords [pkg_str, mod_str, tycon_str]

        Fingerprint high low = fingerprintString hashThis

        word64 :: Word64 -> HsLit
        word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n)
               | otherwise             = \n -> HsWordPrim   (show n) (toInteger n)