typecheck/TcTypeable.hs

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

    {-# LANGUAGE RecordWildCards #-}

    module TcTypeable(mkTypeableBinds) where

    import TcBinds( addTypecheckedBinds )
    import IfaceEnv( newGlobalBinder )
    import TcEnv
    import TcRnMonad
    import PrelNames
    import TysPrim ( primTyCons )
    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 FastString ( FastString, mkFastString )

    import Data.Word( Word64 )

    {- 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:

    * The timing of when we produce this bindings is rather important: they must be
      defined after the rest of the module has been typechecked since we need to be
      able to lookup Module and TyCon in the type environment and we may be
      currently compiling GHC.Types (where they are defined).

    * GHC.Prim doesn't have any associated object code, so we need to put the
      representations for types defined in this module elsewhere. We chose this
      place to be 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]

    -}

    -- | Generate the Typeable bindings for a module. This is the only
    -- entry-point of this module and is invoked by the typechecker driver in
    -- 'tcRnSrcDecls'.
    --
    -- See Note [Grand plan for Typeable] in TcTypeable.
    mkTypeableBinds :: TcM TcGblEnv
    mkTypeableBinds
      = do { -- Create a binding for $trModule.
             -- Do this before processing any data type declarations,
             -- which need tcg_tr_module to be initialised
           ; tcg_env <- mkModIdBindings
             -- Now we can generate the TyCon representations...
             -- First we handle the primitive TyCons if we are compiling GHC.Types
           ; tcg_env <- setGblEnv tcg_env mkPrimTypeableBinds
             -- Then we produce bindings for the user-defined types in this module.
           ; setGblEnv tcg_env $
                 let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
                 in mkTypeableTyConBinds tycons
           }
      where
        needs_typeable_binds tc =
              (not (isFamInstTyCon tc) && isAlgTyCon tc)
           || isDataFamilyTyCon tc
           || isClassTyCon tc

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

    mkModIdBindings :: TcM TcGblEnv
    mkModIdBindings
      = do { mod <- getModule
           ; loc <- getSrcSpanM
           ; mod_nm        <- newGlobalBinder mod (mkVarOcc "$trModule") loc
           ; trModuleTyCon <- tcLookupTyCon trModuleTyConName
           ; 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 -> TcM (LHsExpr Id)
    mkModIdRHS mod
      = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
           ; trNameLit <- mkTrNameLit
           ; return $ nlHsApps (dataConWrapId trModuleDataCon)
                               [ trNameLit (unitIdFS (moduleUnitId mod))
                               , trNameLit (moduleNameFS (moduleName mod)) ]
           }

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

    -- | Generate TyCon bindings for a set of type constructors
    mkTypeableTyConBinds :: [TyCon] -> TcM TcGblEnv
    mkTypeableTyConBinds tycons
      = do { gbl_env <- getGblEnv
           ; mod <- getModule
           ; let 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 <- collect_stuff mod mod_expr
           ; let 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 { mod <- getModule
           ; if mod == gHC_TYPES
               then do { trModuleTyCon <- tcLookupTyCon trModuleTyConName
                       ; let ghc_prim_module_id =
                                 mkExportedVanillaId trGhcPrimModuleName
                                                     (mkTyConTy trModuleTyCon)

                       ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
                                                 <$> mkModIdRHS gHC_PRIM

                       ; stuff <- collect_stuff gHC_PRIM (nlHsVar ghc_prim_module_id)
                       ; let prim_binds :: LHsBinds Id
                             prim_binds = unitBag ghc_prim_module_bind
                                          `unionBags` ghcPrimTypeableBinds stuff

                             prim_rep_ids = collectHsBindsBinders prim_binds
                       ; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv
                       ; return (gbl_env `addTypecheckedBinds` [prim_binds])
                       }
               else getGblEnv
           }
      where

    -- | 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 :: TypeableStuff -> LHsBinds Id
    ghcPrimTypeableBinds stuff
      = unionManyBags (map mkBind all_prim_tys)
      where
        all_prim_tys :: [TyCon]
        all_prim_tys = [ tc' | tc <- funTyCon : primTyCons
                             , tc' <- tc : tyConATs tc ]

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

    data TypeableStuff
        = Stuff { dflags         :: DynFlags
                , mod_rep        :: LHsExpr Id  -- ^ Of type GHC.Types.Module
                , pkg_str        :: String      -- ^ Package name
                , mod_str        :: String      -- ^ Module name
                , trTyConTyCon   :: TyCon       -- ^ of @TyCon@
                , trTyConDataCon :: DataCon     -- ^ of @TyCon@
                , trNameLit      :: FastString -> LHsExpr Id
                                                -- ^ To construct @TrName@s
                }

    -- | Collect various tidbits which we'll need to generate TyCon representations.
    collect_stuff :: Module -> LHsExpr Id -> TcM TypeableStuff
    collect_stuff mod mod_rep = do
        dflags <- getDynFlags
        let pkg_str  = unitIdString (moduleUnitId mod)
            mod_str  = moduleNameString (moduleName mod)

        trTyConTyCon   <- tcLookupTyCon trTyConTyConName
        trTyConDataCon <- tcLookupDataCon trTyConDataConName
        trNameLit      <- mkTrNameLit
        return Stuff {..}

    -- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
    -- can save the work of repeating lookups when constructing many TyCon
    -- representations.
    mkTrNameLit :: TcM (FastString -> LHsExpr Id)
    mkTrNameLit = do
        trNameSDataCon <- tcLookupDataCon trNameSDataConName
        let trNameLit :: FastString -> LHsExpr Id
            trNameLit fs = nlHsApps (dataConWrapId trNameSDataCon)
                                    [nlHsLit (mkHsStringPrimLit fs)]
        return trNameLit

    -- | 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 (mkTyConRepBinds stuff . promoteDataCon)
                           (tyConDataCons tycon))

    -- | Make typeable bindings for the given 'TyCon'.
    mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id
    mkTyConRepBinds stuff@(Stuff {..}) tycon
      = case tyConRepName_maybe tycon of
          Just rep_name -> unitBag (mkVarBind rep_id rep_rhs)
             where
               rep_id  = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon)
               rep_rhs = mkTyConRepRHS stuff tycon
          _ -> emptyBag

    -- | Produce the right-hand-side of a @TyCon@ representation.
    mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id
    mkTyConRepRHS (Stuff {..}) tycon = rep_rhs
      where
        rep_rhs = nlHsApps (dataConWrapId trTyConDataCon)
                           [ nlHsLit (word64 high), nlHsLit (word64 low)
                           , mod_rep
                           , 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)