-printTerm :: Term -> SDoc
-printTerm Prim{value=value} = text value
-printTerm t@Term{} = printTerm1 0 t
-printTerm Suspension{bound_to=Nothing} = char '_' -- <> ppr ct <> char '_'
-printTerm Suspension{mb_ty=Just ty, bound_to=Just n} =
- parens$ ppr n <> text "::" <> ppr ty
-
-printTerm1 p Term{dc=dc, subTerms=tt}
-{- | dataConIsInfix dc, (t1:t2:tt') <- tt
- = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2)
- <+> hsep (map (printTerm1 True) tt)
--}
- | null tt = ppr dc
- | otherwise = parensCond (p > app_prec)
- (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))
-
- where fixity = undefined
-
-printTerm1 _ t = printTerm t
-
-customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
-customPrintTerm custom = let
--- go :: Monad m => Int -> Term -> m SDoc
- go prec t@Term{subTerms=tt, dc=dc} = do
- mb_customDocs <- sequence$ sequence (custom go) t -- Inner sequence is List monad
- case msum mb_customDocs of -- msum is in Maybe monad
- Just doc -> return$ parensCond (prec>app_prec+1) doc
--- | dataConIsInfix dc, (t1:t2:tt') <- tt =
- Nothing -> do pprSubterms <- mapM (go (app_prec+1)) tt
- return$ parensCond (prec>app_prec+1)
- (ppr dc <+> sep pprSubterms)
- go _ t = return$ printTerm t
- in go 0
- where fixity = undefined
-
-customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
-customPrintTermBase showP =
- [
- test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms)
- , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
- , test (isDC intDataCon) (coerceShow$ \(a::Int)->a)
- , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
--- , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
- , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
- , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
- , test isIntegerDC (coerceShow$ \(a::Integer)->a)
- ]
- where test pred f t = if pred t then liftM Just (f t) else return Nothing
- isIntegerDC Term{dc=dc} =
- dataConName dc `elem` [ smallIntegerDataConName
- , largeIntegerDataConName]
- isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
- isDC a_dc Term{dc=dc} = a_dc == dc
- coerceShow f = return . text . show . f . unsafeCoerce# . val
- --TODO pprinting of list terms is not lazy
- doList h t = do
- let elems = h : getListTerms t
- isConsLast = isSuspension (last elems) &&
- (mb_ty$ last elems) /= (termType h)
- init <- mapM (showP 0) (init elems)
- last0 <- showP 0 (last elems)
- let last = case length elems of
- 1 -> last0
- _ | isConsLast -> text " | " <> last0
- _ -> comma <> last0
- return$ brackets (hcat (punctuate comma init ++ [last]))
+pprTerm :: TermPrinter -> TermPrinter
+pprTerm y p t | Just doc <- pprTermM (\p -> Just . y p) p t = doc
+pprTerm _ _ _ = panic "pprTerm"
+
+pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
+pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
+
+pprTermM1, ppr_termM1 :: Monad m => Term -> m SDoc
+pprTermM1 t = pprDeeper `liftM` ppr_termM1 t
+
+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 tt = return$ ppr dc
+ | otherwise = do
+ tt_docs <- mapM (y app_prec) tt
+ return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
+
+ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
+
+ppr_termM _ _ t = ppr_termM1 t
+
+
+ppr_termM1 Prim{value=words, ty=ty} =
+ return$ text$ repPrim (tyConAppTyCon ty) words
+ppr_termM1 Term{} = panic "ppr_termM1 - unreachable"
+ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_'
+ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n}
+ | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
+ | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
+ppr_termM1 _ = panic "ppr_termM1"
+
+pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
+ | Just (tc,_) <- splitNewTyConApp_maybe ty
+ , ASSERT(isNewTyCon tc) True
+ , Just new_dc <- maybeTyConSingleCon tc = do
+ real_term <- y 10 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 | isTerm t || isNewtypeWrap 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
+ go _ t = pprTermM1 t
+
+ 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 :: 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)
+ (\ p Term{subTerms=[h,t]} -> doList p h t)
+ , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
+ , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
+ , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
+ , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
+ , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
+ ]
+ where ifTerm pred f prec t@Term{}
+ | pred t = Just `liftM` f prec t
+ ifTerm _ _ _ _ = return Nothing
+
+ isIntegerTy ty = fromMaybe False $ do
+ (tc,_) <- splitTyConApp_maybe ty
+ return (tyConName tc == integerTyConName)
+
+ isTupleTy ty = fromMaybe False $ do
+ (tc,_) <- splitTyConApp_maybe ty
+ return (tc `elem` (fst.unzip.elems) boxedTupleArr)
+
+ isTyCon a_tc ty = fromMaybe False $ do
+ (tc,_) <- splitTyConApp_maybe ty
+ return (a_tc == tc)
+
+ coerceShow f _p = return . text . show . f . unsafeCoerce# . val
+
+ --NOTE pprinting of list terms is not lazy
+ doList p h t = do
+ let elems = h : getListTerms t
+ isConsLast = termType(last elems) /= termType h
+ print_elems <- mapM (y cons_prec) elems
+ return$ if isConsLast
+ then cparen (p >= cons_prec)
+ . pprDeeperList fsep
+ . punctuate (space<>colon)
+ $ print_elems
+ else brackets (pprDeeperList fcat$
+ punctuate comma print_elems)