+ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
+ tt_docs <- mapM (y app_prec) tt
+ return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs)
+
+ppr_termM y p Term{dc=Right dc, subTerms=tt}
+{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
+ = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
+ <+> hsep (map (ppr_term1 True) tt)
+-} -- TODO Printing infix constructors properly
+ | null sub_terms_to_show
+ = return (ppr dc)
+ | otherwise
+ = do { tt_docs <- mapM (y app_prec) sub_terms_to_show
+ ; return $ cparen (p >= app_prec) $
+ sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
+ where
+ sub_terms_to_show -- Don't show the dictionary arguments to
+ -- constructors unless -dppr-debug is on
+ | opt_PprStyle_Debug = tt
+ | otherwise = dropList (dataConTheta dc) tt
+
+ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
+ppr_termM y p RefWrap{wrapped_term=t} = do
+ contents <- y app_prec t
+ return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
+ -- The constructor name is wired in here ^^^ for the sake of simplicity.
+ -- I don't think mutvars are going to change in a near future.
+ -- In any case this is solely a presentation matter: MutVar# is
+ -- a datatype with no constructors, implemented by the RTS
+ -- (hence there is no way to obtain a datacon and print it).
+ppr_termM _ _ t = ppr_termM1 t
+
+
+ppr_termM1 :: Monad m => Term -> m SDoc
+ppr_termM1 Prim{value=words, ty=ty} =
+ return$ text$ repPrim (tyConAppTyCon ty) words
+ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
+ return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
+ppr_termM1 Suspension{ty=ty, bound_to=Just n}
+-- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
+ | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
+ppr_termM1 Term{} = panic "ppr_termM1 - Term"
+ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap"
+ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
+
+pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
+ | Just (tc,_) <- tcSplitTyConApp_maybe ty
+ , ASSERT(isNewTyCon tc) True
+ , Just new_dc <- tyConSingleDataCon_maybe tc = do
+ real_term <- y max_prec t
+ return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
+pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
+
+-------------------------------------------------------
+-- Custom Term Pretty Printers
+-------------------------------------------------------
+
+-- We can want to customize the representation of a
+-- term depending on its type.
+-- However, note that custom printers have to work with
+-- type representations, instead of directly with types.
+-- We cannot use type classes here, unless we employ some
+-- typerep trickery (e.g. Weirich's RepLib tricks),
+-- which I didn't. Therefore, this code replicates a lot
+-- of what type classes provide for free.
+
+type CustomTermPrinter m = TermPrinterM m
+ -> [Precedence -> Term -> (m (Maybe SDoc))]
+
+-- | Takes a list of custom printers with a explicit recursion knot and a term,
+-- and returns the output of the first succesful printer, or the default printer
+cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
+cPprTerm printers_ = go 0 where
+ printers = printers_ go
+ go prec t = do
+ let default_ = Just `liftM` pprTermM go prec t
+ mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
+ Just doc <- firstJustM mb_customDocs
+ return$ cparen (prec>app_prec+1) doc
+
+ firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
+ firstJustM [] = return Nothing
+
+-- Default set of custom printers. Note that the recursion knot is explicit
+cPprTermBase :: forall m. Monad m => CustomTermPrinter m
+cPprTermBase y =
+ [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
+ . mapM (y (-1))
+ . subTerms)
+ , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
+ ppr_list
+ , ifTerm (isTyCon intTyCon . ty) ppr_int
+ , ifTerm (isTyCon charTyCon . ty) ppr_char
+ , ifTerm (isTyCon floatTyCon . ty) ppr_float
+ , ifTerm (isTyCon doubleTyCon . ty) ppr_double
+ , ifTerm (isIntegerTy . ty) ppr_integer
+ ]
+ where
+ ifTerm :: (Term -> Bool)
+ -> (Precedence -> Term -> m SDoc)
+ -> Precedence -> Term -> m (Maybe SDoc)
+ ifTerm pred f prec t@Term{}
+ | pred t = Just `liftM` f prec t
+ ifTerm _ _ _ _ = return Nothing
+
+ isTupleTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (isBoxedTupleTyCon tc)
+
+ isTyCon a_tc ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (a_tc == tc)
+
+ isIntegerTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (tyConName tc == integerTyConName)
+
+ ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
+ :: Precedence -> Term -> m SDoc
+ ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
+ ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
+ ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v)))
+ ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
+ ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
+
+ --Note pprinting of list terms is not lazy
+ ppr_list :: Precedence -> Term -> m SDoc
+ ppr_list p (Term{subTerms=[h,t]}) = do
+ let elems = h : getListTerms t
+ isConsLast = not(termType(last elems) `eqType` termType h)
+ is_string = all (isCharTy . ty) elems
+
+ print_elems <- mapM (y cons_prec) elems
+ if is_string
+ then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
+ else if isConsLast
+ then return $ cparen (p >= cons_prec)
+ $ pprDeeperList fsep
+ $ punctuate (space<>colon) print_elems
+ else return $ brackets
+ $ pprDeeperList fcat
+ $ punctuate comma print_elems
+
+ where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
+ getListTerms Term{subTerms=[]} = []
+ getListTerms t@Suspension{} = [t]
+ getListTerms t = pprPanic "getListTerms" (ppr t)
+ ppr_list _ _ = panic "doList"
+
+
+repPrim :: TyCon -> [Word] -> String
+repPrim t = rep where
+ rep x
+ | t == charPrimTyCon = show (build x :: Char)
+ | t == intPrimTyCon = show (build x :: Int)
+ | t == wordPrimTyCon = show (build x :: Word)
+ | t == floatPrimTyCon = show (build x :: Float)
+ | t == doublePrimTyCon = show (build x :: Double)
+ | t == int32PrimTyCon = show (build x :: Int32)
+ | t == word32PrimTyCon = show (build x :: Word32)
+ | t == int64PrimTyCon = show (build x :: Int64)
+ | t == word64PrimTyCon = show (build x :: Word64)
+ | t == addrPrimTyCon = show (nullPtr `plusPtr` build x)
+ | t == stablePtrPrimTyCon = "<stablePtr>"
+ | t == stableNamePrimTyCon = "<stableName>"
+ | t == statePrimTyCon = "<statethread>"
+ | t == realWorldTyCon = "<realworld>"
+ | t == threadIdPrimTyCon = "<ThreadId>"
+ | t == weakPrimTyCon = "<Weak>"
+ | t == arrayPrimTyCon = "<array>"
+ | t == byteArrayPrimTyCon = "<bytearray>"
+ | t == mutableArrayPrimTyCon = "<mutableArray>"
+ | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
+ | t == mutVarPrimTyCon= "<mutVar>"
+ | t == mVarPrimTyCon = "<mVar>"
+ | t == tVarPrimTyCon = "<tVar>"
+ | otherwise = showSDoc (char '<' <> ppr t <> char '>')
+ where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
+-- This ^^^ relies on the representation of Haskell heap values being
+-- the same as in a C array.