-- | Pretty-printing
module Syntax.Ppr (
  pprTyApp,
  -- * Re-exports
  module Syntax.PprClass,
  module Syntax.Prec
) where

import Meta.Quasi
import Syntax.PprClass
import Syntax.Prec
import AST
import Util

import qualified Syntax.Strings as Strings
import Data.Loc

import Prelude ()
import Data.List (sortBy)

instance IsInfix (Type i) where
  isInfix [ty| ($_, $_) $lid:n |] = isOperator n
  isInfix [ty| $_ -[$_]> $_ |]    = True
  isInfix _                        = False

-- | For printing infix expressions.  Given a splitter function that
--   splits expressions into a left operand, operator name, and right
--   operand (if possible), and an expression to print, pretty-prints
--   the expression, but only if there is one level of infix to be
--   done.
pprInfix :: Ppr a =>
            (a -> Maybe (a, String, Maybe a)) ->
            a -> Maybe Doc
pprInfix inspect x0
  | Just (x1, op, Nothing) <- inspect x0
  , precOp op == Right precBang
    = let rloop x'
            | Just (x1', op', Nothing) <- inspect x'
            , precOp op == Right precBang
            = first (op':) (rloop x1')
            | otherwise
            = ([], x')
          (ops, x) = first (op:) (rloop x1)
       in Just $
            fsep (mapTail (nest 2) $ map text ops)
            <> pprPrec precBang x
  | Just (_, op, Just _) <- inspect x0
  , isOperator (ident op :: Lid Raw)
  , p <- precOp op
  , p /= Right precBang
    = Just $
        prec (id|||id $ p) $
          fcat $ mapTail (nest 2) $ loop p mempty x0
  | otherwise
    = Nothing
  where
  loop p suf x
    | Just (x1, op, Just x2) <- inspect x
    , precOp op == p
    = case precOp op of
        Left _  -> loop p (oper op) x1 ++ [ppr1 x2 <> suf]
        Right _ -> ppr1 x1 <> oper op : loop p suf x2
  loop _ suf x = [ ppr x <> suf ]
  oper s = case s of
    '@':_ -> text s
    "\\/" -> text Strings.join
    ';':_ -> text s <> space
    _     -> space <> text s <> space

instance Ppr (Type i) where
  ppr [ty| $t1 -> $t2 |]
            = prec precArr $
              sep [ ppr1 t1, text Strings.uArrow <+> pprRight t2 ]
  ppr [ty| $t1 -[$q]> $t2 |]
            = prec precArr $
              sep [ ppr1 t1,
                    text Strings.arrowPre <> ppr0 q <>
                    text Strings.arrowPost <+> pprRight t2 ]
  ppr [ty| U |]     = char 'U'
  ppr [ty| A |]     = char 'A'
  ppr [ty| [ $t ] |]
                    = atPrec precStart $
                        pprVariantRow (lbrack <+>) t (<+> rbrack)
  ppr [ty| {+ $t +} |] = pprRecordType "{+" t "+}"
  ppr [ty| { $t } |]   = pprRecordType "{" t "}"
  ppr [ty| $t ... |] = prec precApp $ sep [ ppr t, text Strings.ellipsis ]
  ppr [ty| $t $qtid:n |]
    | show n == tnRowHole
                    = brackets $ ppr0 t
  ppr t@[ty| ($list:ts) $qtid:n |]
    | Just doc <- pprInfix unfoldType t
                    = doc
    | null ts       = ppr n
    | otherwise     = prec precApp $ sep [ ppr ts, ppr n ]
  ppr [ty| '$x |]  = ppr x
  ppr [ty| $quant:qu '$x. $t |]
                    = prec precDot $
                        ppr qu <+>
                        fsep (map ppr1 tvs) <>
                        char '.'
                          >+> ppr body
      where (tvs, body) = unfoldTyQu qu [ty| $quant:qu '$x. $t |]
  ppr [ty| mu '$x. $t |]
                    = prec precDot $
                        text Strings.mu <+>
                        ppr1 x <>
                        char '.'
                          >+> ppr t
  ppr t@[ty| `$uid:_ of $_ | $_ |]
                       = pprVariantRow id t id
  ppr [ty| $anti:a |] = ppr a

unfoldType :: Type i -> Maybe (Type i, String, Maybe (Type i))
unfoldType [ty| ($t1, $t2) $name:n |] = Just (t1, n, Just t2)
unfoldType [ty| $t1 $name:n |]        = Just (t1, n, Nothing)
unfoldType _                           = Nothing

pprVariantRow ∷ (Doc → Doc) → Type i → (Doc → Doc) → Doc
pprVariantRow pre t post =
  case items' ++ end' of
    []   → pre (post mempty)
    docs → prec precStart .
           sep .
           mapHead pre .
           mapLast post .
           mapTail (char '|' <+>) $
             docs
  where
    (items, end) = unfoldTyRow t
    items' = [ char '`' <> ppr ni <+>
                 case ti of
                   [ty| unit                     |] → mempty
                   [ty| INTERNALS.PrimTypes.unit |] → mempty
                   _ → text "of" <+> ppr1 ti
             | (ni, ti) ← sortBy (compare`on`show.fst) items ]
    end'   = case end of
      [ty| $qtid:n |] | show n == tnRowEnd
                      → []
      _               → [ppr1 end]

pprRecordType ∷ String → Type i → String → Doc
pprRecordType lb t rb = case items' ++ end' of
  []   → text lb <> text rb
  docs → atPrec precStart .
         fsep .
         mapHead (text lb <+>) .
         mapTail (nest 2) .
         mapLast (<+> text rb) $
           docs
  where
    (uitems, end) = unfoldTyRow t
    items         = first uidToLid <$> uitems
    items' = punctuate comma
               [ ppr ni <> colon <+> ppr1 ti
               | (ni, ti) ← sortBy (compare`on`show.fst) items ]
    end'   = case end of
      [ty| $qtid:n |] | show n == tnRowEnd
                      → []
      _               → [(if null items' then mempty else char '|')
                         <+> ppr1 end]

instance Ppr (TyPat i) where
  ppr tp0 = case tp0 of
    _ | Just doc <- pprInfix unfoldTyPat tp0
                       -> doc
    N _ (TpVar tv var) -> pprParamV var tv
    N _ (TpRow tv var) -> pprParamV var tv <+> text Strings.ellipsis
    [tpQ| [ $tp ] |]   -> lbrack <+> ppr0 tp <+> rbrack
    [tpQ| { $tp } |]   -> lbrace <+> ppr0 tp <+> rbrace
    [tpQ| $qtid:ql |]  -> ppr ql
    [tpQ| ($list:tps) $qtid:ql |]
                       -> prec precApp $ sep [ppr tps, ppr ql]
    [tpQ| $antiP:a |]  -> ppr a

unfoldTyPat :: TyPat i -> Maybe (TyPat i, String, Maybe (TyPat i))
unfoldTyPat [tpQ| ($t1, $t2) $name:n |] = Just (t1, n, Just t2)
unfoldTyPat [tpQ| $t1 $name:n |]        = Just (t1, n, Nothing)
unfoldTyPat _                           = Nothing

instance Ppr (QExp i) where
  ppr [qeQ| $qlit:qu |]   = ppr qu
  ppr [qeQ| $qvar:v |]    = ifPrec (> 0)
                              (ppr v)
                              (ppr (tvname v))
  ppr [qeQ| $qe1, $qe2 |] = ifPrec (> 0)
    (ppr qe1 <+> text Strings.join <+> ppr qe2)
    (ppr qe1 <> comma <> ppr qe2)
  ppr [qeQ| $anti:a |]    = ppr a

instance Ppr (Prog i) where
  ppr [prQ| $list:ms |]       = vcat (map ppr0 ms)
  ppr [prQ| $expr:e |]        = ppr e
  ppr [prQ| $list:ms in $e |] = vcat (map ppr0 ms) $+$
                                 (text "in" >+> ppr e)

instance Ppr (Decl i) where
  ppr [dc| let $lid:x = $e |] =
    prec precDot $
      pprLet (text "let" <+> ppr x) e False
  ppr [dc| let $x = $e |] =
    prec precDot $
      text "let" <+> ppr x <+> equals
        >+> ppr e
  ppr [dc| let rec $list:bs |] =
    prec precDot $
      text "let" <+>
      vcat (zipWith pprBinding ("rec" : repeat "and") bs)
  ppr [dc| type $tid:lhs = type $qtid:rhs |] =
    text "type" <+> ppr lhs <+> equals <+> text "type" <+> ppr rhs
  ppr [dc| type $list:tds |] = pprTyDecs tds
  ppr [dc| abstype $list:ats0 with $list:ds end |] =
    case ats0 of
      []     ->
        vcat [
          text "abstype with",
          nest 2 $ vcat (map ppr ds),
          text "end"
        ]
      at:ats ->
        vcat [
          vcat (text "abstype" <+> pprAbsTy at :
                [ nest 4 $ text "and" <+> pprAbsTy ati | ati <- ats ])
            <+> text "with",
          nest 2 $ vcat (map ppr ds),
          text "end"
        ]
  ppr [dc| open $b |] = pprModExp (text "open" <+>) b
  ppr [dc| module $uid:n : $s = $b |] = pprModExp add1 b where
    add1 body = pprSigExp add2 s <+> equals <+> body
    add2 body = text "module" <+> ppr n <+> colon <+> body
  ppr [dc| module $uid:n = $b |] = pprModExp add b where
    add body = text "module" <+> ppr n <+> equals <+> body
  ppr [dc| module type $uid:n = $s |] = pprSigExp add s where
    add body = text "module type" <+> ppr n <+> equals <+> body
  ppr [dc| local $list:d0 with $list:d1 end |] =
    vcat [
      text "local",
      nest 2 (vcat (map ppr d0)),
      text "with",
      nest 2 (vcat (map ppr d1)),
      text "end"
    ]
  ppr [dc| exception $uid:n of $opt:mt |] =
    pprExcDec n mt
  ppr [dc| $anti:a |] = ppr a

pprTyDecs :: [TyDec i] -> Doc
pprTyDecs tds =
  vcat $
    mapHead (text "type" <+>) $
      mapTail ((nest 1) . (text "and" <+>)) $
        map ppr tds

pprExcDec :: Uid i -> Maybe (Type i) -> Doc
pprExcDec u Nothing  =
  text "exception" <+> ppr u
pprExcDec u (Just t) =
  text "exception" <+> ppr u <+> text "of" <+> ppr t

instance Ppr (TyDec i) where
  ppr td = case view td of
    TdAbs n ps vs gs qs -> pprProtoV n vs ps
                             >?> pprQuals qs
                             >?> pprGuards gs
    TdSyn n [(ps,t)]    -> pprProto n ps >+> equals <+> ppr t
    TdSyn n cs          -> vcat [ char '|' <+> each ci | ci <- cs ]
      where
        each (ps, rhs) = pprProto n ps
                           >+> equals <+> ppr rhs
    TdDat n ps alts     -> pprProtoV n (repeat Invariant) ps
                             >?> pprAlternatives alts
    TdAnti a            -> ppr a

pprAbsTy :: AbsTy i -> Doc
pprAbsTy at = case view at of
  AbsTy variances qual (N _ (TdDat name params alts)) ->
    pprProtoV name variances params
      >?> pprQuals qual
      >?> pprAlternatives alts
  AbsTy _ _ td -> ppr td -- shouldn't happen (yet)
  AbsTyAnti a -> ppr a

pprProto  :: TypId i -> [TyPat i] -> Doc
pprProto n ps = ppr (tpApp (J [] n) ps)

pprProtoV :: TypId i -> [Variance] -> [TyVar i] -> Doc
pprProtoV n vs tvs = pprProto n (zipWith tpVar tvs vs)

pprParamV :: Variance -> TyVar i -> Doc
pprParamV Invariant tv = ppr tv
pprParamV v         tv = ppr v <> ppr tv

pprGuards :: [TyVar i] -> Doc
pprGuards []  = mempty
pprGuards tvs = text "rec" <+> fsep (punctuate comma (ppr <$> tvs))

pprQuals :: QExp i -> Doc
pprQuals [qeQ| U |] = mempty
pprQuals qs         = text ":" <+> pprPrec precApp qs

pprAlternatives :: [(ConId i, Maybe (Type i))] -> Doc
pprAlternatives [] = equals
pprAlternatives (a:as) = sep $
  equals <+> alt a : [ char '|' <+> alt a' | a' <- as ]
  where
    alt (u, Nothing) = ppr u
    alt (u, Just t)  = ppr u <+> text "of" <+> pprPrec precDot t

pprModExp :: (Doc -> Doc) -> ModExp i -> Doc
pprModExp add modexp = case modexp of
  [meQ| $qmid:n |] -> add (ppr n)
  [meQ| $qmid:n $list:qls |] ->
    add (ppr n) <+>
    pprStyleList listStyleBrack qls
  [meQ| struct $list:ds end |] ->
    add (text "struct")
    $$ nest 2 (vcat (map ppr0 ds))
    $$ text "end"
  [meQ| $me1 : $se2 |] ->
    pprSigExp (pprModExp add me1 <+> colon <+>) se2
  [meQ| $anti:a |] -> add (ppr a)

instance Ppr (SigExp i) where
  ppr = pprSigExp id

pprSigExp :: (Doc -> Doc) -> SigExp i -> Doc
pprSigExp add se0 = body >+> withs where
  (wts, se1) = unfoldSeWith se0
  body       = case se1 of
    [seQ| $qsid:n |] -> add (ppr n)
    [seQ| $qsid:n $list:qls |] ->
      add (ppr n) <+>
      pprStyleList listStyleBrack qls
    [seQ| sig $list:sgs end |] ->
      add (text "sig")
      $$ nest 2 (vcat (map ppr0 sgs))
      $$ text "end"
    [seQ| $_ with type $list:_ $qtid:_ = $_ |] ->
      error "BUG! can't happen in pprSigExp"
    [seQ| $anti:a |] -> add (ppr a)
  withs      =
    atPrec 0 $ sep $
      mapHead (text "with type" <+>) $
        mapTail ((nest 6) . (text "and" <+>)) $
          [ pprTyApp tc tvs <+> equals <+> ppr t
          | (tc, tvs, t) <- wts ]

instance Ppr (SigItem i) where
  ppr sg0 = case sg0 of
    [sgQ| val $lid:n : $t |] ->
      text "val" <+> ppr n >+> colon <+> ppr t
    [sgQ| type $list:tds |] ->
      pprTyDecs tds
    [sgQ| type $tid:lhs = type $qtid:rhs |] ->
      text "type" <+> ppr lhs <+> equals <+> text "type" <+> ppr rhs
    [sgQ| module $uid:u : $s |] ->
      pprSigExp add s where
        add body = text "module" <+> ppr u <+> colon <+> body
    [sgQ| module type $uid:u = $s |] ->
      pprSigExp add s where
        add body = text "module type" <+> ppr u <+> equals <+> body
    [sgQ| include $s |] ->
      pprSigExp (text "include" <+>) s
    [sgQ| exception $uid:u of $opt:mt |] ->
      pprExcDec u mt
    [sgQ| $anti:a |] ->
      ppr a

instance Ppr (Expr i) where
  ppr e0 = case e0 of
    _ | Just doc <- pprInfix unfoldExpr e0
                       -> doc
      | Just es <- unfoldExList e0
                       -> pprStyleList listStyleBrack es
    [ex| { } |]        -> braces mempty -- Must come before ExVar case
    [ex| $e1 :: $e2 |] -> prec precCaret $
                            ppr1 e1 <+> text Strings.cons <+> ppr e2
    [ex| $qvid:x |]    -> ppr x
    [ex| $lit:lt |]    -> ppr lt
    [ex| $qcid:x |]    -> ppr x
    [ex| $qcid:x $e |] -> prec precApp (sep [ ppr x, ppr1 e ])
    [ex| `$uid:x |]    -> char '`' <> ppr x
    [ex| `$uid:x $e |] -> prec precApp (sep [ char '`' <> ppr x, ppr1 e ])
    [ex| #$uid:x $e |] -> prec precApp (sep [ char '#' <> ppr x, ppr1 e ])
    [ex| if $ec then $et else $ef |] ->
      prec precDot $
        sep [ text "if" <+> ppr ec,
              nest 2 $ text "then" <+> ppr0 et,
              nest 2 $ text "else" <+> ppr ef ]
    [ex| $_; $_ |] ->
      prec precExSemi $
        sep (unfold e0)
      where unfold [ex| $e1; $e2 |] = ppr1 e1 <> semi : unfold e2
            unfold e                 = [ ppr0 e ]
    [ex| let $lid:x = $e1 in $e2 |] ->
      prec precDot $
        hangLet (pprLet (text "let" <+> ppr x) e1 True) e2
    [ex| let $x = $e1 in $e2 |] ->
      prec precDot $
        hangLet (text "let" <+> ppr x <+> equals
                  >+> ppr e1 <+> text "in")
                e2
    [ex| match $e1 with $list:clauses |] ->
      prec precDot $
        vcat (sep [ text "match",
                    nest 2 $ ppr0 e1,
                    text "with" ] : map ppr clauses)
    [ex| let rec $list:bs in $e2 |] ->
      prec precDot $
        text "let" <+>
        vcat (zipWith pprBinding ("rec" : repeat "and") bs) $$
        nest 1 (text "in" <+> ppr e2)
    [ex| let $decl:d in $e2 |] ->
      prec precDot $
        hangLet
          (text "let" <+> ppr0 d <+> text "in")
          e2
    [ex| ($e1, $e2) |] ->
      prec precCom $
        sep [ ppr e1 <> comma, ppr1 e2 ]
    [ex| λ $_ → $_ |]  ->
      prec precDot $
        hang
          (text Strings.fun <+>
           fsep (pprPrec1 precApp <$> args) <+>
           text Strings.arrow)
          2
          (ppr body)
        where (args, body) = unfoldExAbs e0
    [ex| $e1 $e2 |]
          -> prec precApp $
               sep [ ppr e1, ppr1 e2 ]
    [ex| ( $e : $t1 :> $t2 ) |] ->
      prec precCast $
        atPrec (precCast + 2) $
          sep [ ppr e,
                colon     <+> ppr t1,
                text ":>" <+> ppr t2 ]
    [ex| { $list:flds | $e2 } |] ->
      pprRecord "{" flds e2 "}"
    [ex| {+ $list:flds | $e2 +} |] ->
      pprRecord "{+" flds e2 "+}"
    [ex| $e . $uid:sel |] ->
      prec precSel $
        pprPrec precSel e <> char '.' <> ppr (uidToLid sel)
    [ex| ( $e : $t1 ) |] ->
      prec precCast $
        atPrec (precCast + 2) $
          sep [ ppr e,
                colon <+> ppr t1 ]
    [ex| ( $e :> $t1 ) |] ->
      prec precCast $
        atPrec (precCast + 2) $
          sep [ ppr e,
                text ":>" <+> ppr t1 ]
    [ex| $anti:a |] -> ppr a
    where
    unfoldExpr [ex| ($name:x $e1) $e2 |] = Just (e1, x, Just e2)
    unfoldExpr [ex| $name:x $e1 |]       = Just (e1, x, Nothing)
    unfoldExpr _                          = Nothing

unfoldExList ∷ Expr i → Maybe [Expr i]
unfoldExList [ex| [] |]        = Just []
unfoldExList [ex| [ ] |]       = Just []
unfoldExList [ex| $e1 ∷ $e2 |] = (e1 :) <$> unfoldExList e2
unfoldExList _                 = Nothing

pprRecord    ∷ String → [Field i] → Expr i → String → Doc
pprRecord bl flds e2 br =
  atPrec precStart $
    text bl <+>
    fsep (punctuate comma (ppr <$> flds)
          ++ case e2 of
               [ex|! { } |] → []
               _            → [char '|' <+> ppr e2])
    <+> text br

instance Ppr (Field i) where
  ppr [fdQ| $uid:u = $e |] = pprLet (ppr (uidToLid u)) e False
  ppr [fdQ| $antiF:a |]    = ppr a

pprBinding :: String -> Binding i -> Doc
pprBinding kw [bnQ| $lid:x = $e |] = pprLet (text kw <+> ppr x) e True
pprBinding kw [bnQ| $antiB:a |]    = text kw <+> ppr a

instance Ppr (CaseAlt i) where
  ppr [caQ| $xi -> $ei |] =
    hang (char '|' <+> ppr xi <+> text Strings.arrow)
         4
         (ppr ei)
  ppr [caQ| #$uid:lab $opt:mxi -> $ei |] =
    hang (text "| #" <> ppr lab
          <+> maybe mempty (pprPrec (precApp + 1)) mxi
          <+> text Strings.arrow)
         4
         (ppr ei)
  ppr [caQ| $antiC:a |]   = char '|' <+> ppr a

-- | Print a let expression, indenting the body only if the body is
--   not another let expression.
hangLet ∷ Doc → Expr i → Doc
hangLet doc e2 = hang doc (if (isLet e2) then 0 else 2) (ppr e2)
  where
  isLet [ex| $_; $_ |]                = False
  isLet [ex| let $_ = $_ in $_ |]     = True
  isLet [ex| let rec $list:_ in $_ |] = True
  isLet _                             = False

-- | Print the binding and rhs of a let
pprLet :: Doc -> Expr i -> Bool -> Doc
pprLet doc e1 withIn =
  doc <+>
  nest 2 (fsep (pprPrec1 precApp <$> args)) <+>
  maybe mempty (nest 2 . (colon <+>) . ppr0) mannot <+> equals
    >+> ppr rhs <+> if withIn then text "in" else mempty
  where
    (args, rhs, mannot) = resugarLet e1

-- | Given the rhs of a let expression, pull out the arguments and
--   any result-type annotation.
resugarLet ∷ Expr i → ([Patt i], Expr i, Maybe (Type i))
resugarLet e =
  let (args, rhs0)  = unfoldExAbs e
   in case rhs0 of
        [ex| $e' : $t |] → (args, e', Just t)
        _                → (args, rhs0, Nothing)

instance Ppr (Patt i) where
  ppr π0 | Just πs ← unfoldPaList π0
                            = pprStyleList listStyleBrack πs
  ppr [pa| _ |]             = text "_"
  ppr [pa| $lid:l |]        = ppr l
  ppr [pa| $x :: $y |]      = prec precCaret $
                                 ppr1 x <+> text Strings.cons <+> ppr y
  ppr [pa| $qcid:qu |]      = ppr qu
  ppr [pa| $qcid:qu $x |]   = prec precApp $
                                 ppr qu <+> ppr1 x
  ppr [pa| ($x, $y) |]      = prec precCom $
                                 ppr x <> comma <+> ppr1 y
  ppr [pa| $lit:lt |]       = ppr lt
  ppr [pa| $x as $lid:l |]  = prec precDot $
                                 ppr1 x <+> text "as" <+> ppr l
  ppr [pa| `$uid:u |]       = char '`' <> ppr u
  ppr [pa| `$uid:u $x |]    = prec precApp $
                                char '`' <> ppr u <+> ppr1 x
  ppr π0@[pa| { $uid:_ = $_ | $_ } |]
                            =
    atPrec precStart $
      char '{' <+>
      fsep (punctuate comma
             [ ppr (uidToLid ui) <+> equals <+> ppr πi
             | (ui, πi) ← flds ]
            ++ case π2 of
                 [pa|! _ |] → []
                 _          → [char '|' <+> ppr π2])
      <+> char '}'
    where (flds, π2) = unfoldPaRec π0
  ppr [pa| ! $x |]          = prec precBang $
                                char '!' <> ppr1 x
  ppr [pa| $x : $t |]       = prec precCast $
                                hang (ppr x)
                                     2
                                     (colon <+> ppr0 t)
  ppr [pa| $anti:a |]       = ppr a

unfoldPaList ∷ Patt i → Maybe [Patt i]
unfoldPaList [pa| [] |]        = Just []
unfoldPaList [pa| [ ] |]       = Just []
unfoldPaList [pa| $π1 ∷ $π2 |] = (π1 :) <$> unfoldPaList π2
unfoldPaList _                 = Nothing

instance Ppr Lit where
  ppr (LtInt i)   = integer i
  ppr (LtChar c)  = text (show c)
  ppr (LtFloat f) = double f
  ppr (LtStr s)   = text (show s)
  ppr (LtAnti a)  = ppr a

--
-- Helper for pretty-printing type-like things -- doesn't require
-- underlying types, but does need to see the operator name.
--

data PprTyAppHelper i a
  = PTAHBranch (QTypId i) [a]
  | PTAHLeaf   a

instance Ppr a => Ppr (PprTyAppHelper i a) where
  ppr (PTAHLeaf a) = ppr a
  ppr _            = error "BUG! in PprTyAppHelper.ppr"

unfoldPTAH :: PprTyAppHelper i a ->
              Maybe (PprTyAppHelper i a, String, Maybe (PprTyAppHelper i a))
unfoldPTAH (PTAHBranch (J [] l) [a, b])
  = Just (PTAHLeaf a, unLid (unTypId l), Just (PTAHLeaf b))
unfoldPTAH (PTAHBranch (J [] l) [a])
  = Just (PTAHLeaf a, unLid (unTypId l), Nothing)
unfoldPTAH _
  = Nothing

pprTyApp :: Ppr a => QTypId i -> [a] -> Doc
pprTyApp ql ts
  | Just doc <- pprInfix unfoldPTAH (PTAHBranch ql ts)
               = doc
pprTyApp ql [] = ppr ql
pprTyApp ql ts = prec precApp $ sep [ ppr ts, ppr ql ]

--
-- Instances
--

instance Show (Prog i)   where showsPrec = showFromPpr
instance Show (Decl i)   where showsPrec = showFromPpr
instance Show (TyDec i)  where showsPrec = showFromPpr
instance Show (Expr i)   where showsPrec = showFromPpr
instance Show (Patt i)   where showsPrec = showFromPpr
instance Show Lit        where showsPrec = showFromPpr
instance Show (Type i)   where showsPrec = showFromPpr
instance Show (TyPat i)  where showsPrec = showFromPpr
instance Show (QExp i)   where showsPrec = showFromPpr
instance Show (SigItem i)where showsPrec = showFromPpr

instance Ppr Loc       where pprPrec = pprFromShow
instance Ppr QLit      where pprPrec = pprFromShow
instance Ppr Variance  where pprPrec = pprFromShow
instance Ppr Quant     where pprPrec = pprFromShow
instance Ppr (Lid i)   where pprPrec = pprFromShow
instance Ppr (Uid i)   where pprPrec = pprFromShow
instance Ppr (TypId i) where pprPrec = pprFromShow
instance Ppr (VarId i) where pprPrec = pprFromShow
instance Ppr (ConId i) where pprPrec = pprFromShow
instance Ppr (ModId i) where pprPrec = pprFromShow
instance Ppr (SigId i) where pprPrec = pprFromShow
instance Ppr (BIdent i)where pprPrec = pprFromShow
instance Ppr (TyVar i) where pprPrec = pprFromShow
instance Ppr Anti      where pprPrec = pprFromShow
instance (Show p, Show k) => Ppr (Path p k) where pprPrec = pprFromShow