CoreShow.hs

{-# LANGUAGE StandaloneDeriving,FlexibleInstances, UndecidableInstances, OverlappingInstances #-}
--
-- This module derives Show instances for CoreSyn types.
--
module CLasH.Utils.Core.CoreShow where

-- GHC API
import qualified BasicTypes
import qualified CoreSyn
import qualified TypeRep
import qualified TyCon
import qualified HsTypes
import qualified HsExpr
import qualified HsBinds
import qualified SrcLoc
import qualified RdrName
import Outputable ( Outputable, OutputableBndr, showSDoc, ppr)

-- Derive Show for core expressions and binders, so we can see the actual
-- structure.
deriving instance (Show b) => Show (CoreSyn.Expr b)
deriving instance (Show b) => Show (CoreSyn.Bind b)
deriving instance Show TypeRep.Type
deriving instance (Show n, OutputableBndr n) => Show (HsTypes.HsType n)
deriving instance (Show n, OutputableBndr n) => Show (HsTypes.ConDeclField n)
deriving instance (Show x) => Show (SrcLoc.Located x)
deriving instance (Show x, OutputableBndr x) => Show (HsExpr.StmtLR x x)
deriving instance (Show x, OutputableBndr x) => Show (HsExpr.HsTupArg x)
deriving instance (Show x, OutputableBndr x) => Show (HsExpr.HsExpr x)
deriving instance Show (RdrName.RdrName)
deriving instance (Show idL, Show idR, OutputableBndr idL, OutputableBndr idR) => Show (HsBinds.HsBindLR idL idR)
deriving instance Show CoreSyn.Note
deriving instance Show TyCon.SynTyConRhs


-- Implement dummy shows, since deriving them will need loads of other shows
-- as well.
instance Show TypeRep.PredType where
  show t = "_PredType:(" ++ showSDoc (ppr t) ++ ")"
instance Show TyCon.TyCon where
  show t | TyCon.isAlgTyCon t && not (TyCon.isTupleTyCon t) =
           showtc "AlgTyCon" ""
         | TyCon.isCoercionTyCon t =
           showtc "CoercionTyCon" ""
         | TyCon.isSynTyCon t =
           showtc "SynTyCon" (", synTcRhs = " ++ synrhs)
         | TyCon.isTupleTyCon t =
           showtc "TupleTyCon" ""
         | TyCon.isFunTyCon t =
           showtc "FunTyCon" ""
         | TyCon.isPrimTyCon t =
           showtc "PrimTyCon" ""
         | TyCon.isSuperKindTyCon t =
           showtc "SuperKindTyCon" ""
         | otherwise = 
           "_Nonexistant tycon?:(" ++ showSDoc (ppr t) ++ ")_"
      where
        showtc con extra = "(" ++ con ++ " {tyConName = " ++ name ++ extra ++ ", ...})"
        name = show (TyCon.tyConName t)
        synrhs = show (TyCon.synTyConRhs t)
instance Show BasicTypes.Boxity where
  show b = "_Boxity"
instance Show HsTypes.HsExplicitForAll where
  show b = "_HsExplicitForAll"
instance Show HsExpr.HsArrAppType where
  show b = "_HsArrAppType"
instance Show (HsExpr.MatchGroup x) where
  show b = "_HsMatchGroup"
instance Show (HsExpr.GroupByClause x) where
  show b = "_GroupByClause"
instance Show (HsExpr.HsStmtContext x) where
  show b = "_HsStmtContext"
instance Show (HsBinds.Prag) where
  show b = "_Prag"
instance Show (HsExpr.GRHSs id) where
  show b = "_GRHSs"


instance (Outputable x) => Show x where
  show x = "__" ++ showSDoc (ppr x) ++ "__"