    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE TupleSections #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE TypeSynonymInstances #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE CPP #-}

    -- | Pretty printing.

    module HIndent.Pretty
      (pretty)
      where

    import           Control.Applicative
    import           Control.Monad.State.Strict hiding (state)
    import qualified Data.ByteString.Builder as S
    import           Data.Foldable (for_, forM_, traverse_)
    import           Data.Int
    import           Data.List
    import           Data.Maybe
    import           Data.Monoid ((<>))
    import           Data.Typeable
    import           HIndent.Types
    import qualified Language.Haskell.Exts as P
    import           Language.Haskell.Exts.SrcLoc
    import           Language.Haskell.Exts.Syntax
    import           Prelude hiding (exp)

    --------------------------------------------------------------------------------
    -- * Pretty printing class

    -- | Pretty printing class.
    class (Annotated ast,Typeable ast) => Pretty ast where
      prettyInternal :: ast NodeInfo -> Printer ()

    -- | Pretty print including comments.
    pretty :: (Pretty ast,Show (ast NodeInfo))
           => ast NodeInfo -> Printer ()
    pretty a = do
      mapM_
        (\c' -> do
           case c' of
             CommentBeforeLine _ c -> do
               case c of
                 EndOfLine s -> write ("--" ++ s)
                 MultiLine s -> write ("{-" ++ s ++ "-}")
               newline
             _ -> return ())
        comments
      prettyInternal a
      mapM_
        (\(i, c') -> do
           case c' of
             CommentSameLine spn c -> do
               col <- gets psColumn
               if col == 0
                 then do
                   -- write comment keeping original indentation
                   let col' = fromIntegral $ srcSpanStartColumn spn - 1
                   column col' $ writeComment c
                 else do
                   space
                   writeComment c
             CommentAfterLine spn c -> do
               when (i == 0) newline
               -- write comment keeping original indentation
               let col = fromIntegral $ srcSpanStartColumn spn - 1
               column col $ writeComment c
             _ -> return ())
        (zip [0 :: Int ..] comments)
      where
        comments = nodeInfoComments (ann a)
        writeComment =
          \case
            EndOfLine cs -> do
              write ("--" ++ cs)
              modify
                (\s ->
                    s
                    { psEolComment = True
                    })
            MultiLine cs -> do
              write ("{-" ++ cs ++ "-}")
              modify
                (\s ->
                    s
                    { psEolComment = True
                    })

    -- | Pretty print using HSE's own printer. The 'P.Pretty' class here
    -- is HSE's.
    pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo))
            => ast NodeInfo -> Printer ()
    pretty' = write . P.prettyPrint . fmap nodeInfoSpan

    --------------------------------------------------------------------------------
    -- * Combinators

    -- | Increase indentation level by n spaces for the given printer.
    indented :: Int64 -> Printer a -> Printer a
    indented i p =
      do level <- gets psIndentLevel
         modify (\s -> s {psIndentLevel = level + i})
         m <- p
         modify (\s -> s {psIndentLevel = level})
         return m

    indentedBlock :: Printer a -> Printer a
    indentedBlock p =
      do indentSpaces <- getIndentSpaces
         indented indentSpaces p

    -- | Print all the printers separated by spaces.
    spaced :: [Printer ()] -> Printer ()
    spaced = inter space

    -- | Print all the printers separated by commas.
    commas :: [Printer ()] -> Printer ()
    commas = inter (write ", ")

    -- | Print all the printers separated by sep.
    inter :: Printer () -> [Printer ()] -> Printer ()
    inter sep ps =
      foldr
        (\(i,p) next ->
            depend
              (do p
                  if i < length ps
                    then sep
                    else return ())
              next)
        (return ())
        (zip [1 ..] ps)

    -- | Print all the printers separated by newlines.
    lined :: [Printer ()] -> Printer ()
    lined ps = sequence_ (intersperse newline ps)

    -- | Print all the printers separated newlines and optionally a line
    -- prefix.
    prefixedLined :: String -> [Printer ()] -> Printer ()
    prefixedLined pref ps' =
      case ps' of
        [] -> return ()
        (p:ps) ->
          do p
             indented (fromIntegral
                         (length pref *
                          (-1)))
                      (mapM_ (\p' ->
                                do newline
                                   depend (write pref) p')
                             ps)

    -- | Set the (newline-) indent level to the given column for the given
    -- printer.
    column :: Int64 -> Printer a -> Printer a
    column i p =
      do level <- gets psIndentLevel
         modify (\s -> s {psIndentLevel = i})
         m <- p
         modify (\s -> s {psIndentLevel = level})
         return m

    -- | Output a newline.
    newline :: Printer ()
    newline =
      do write "\n"
         modify (\s -> s {psNewline = True})

    -- | Set the context to a case context, where RHS is printed with -> .
    withCaseContext :: Bool -> Printer a -> Printer a
    withCaseContext bool pr =
      do original <- gets psInsideCase
         modify (\s -> s {psInsideCase = bool})
         result <- pr
         modify (\s -> s {psInsideCase = original})
         return result

    -- | Get the current RHS separator, either = or -> .
    rhsSeparator :: Printer ()
    rhsSeparator =
      do inCase <- gets psInsideCase
         if inCase
            then write "->"
            else write "="

    -- | Make the latter's indentation depend upon the end column of the
    -- former.
    depend :: Printer () -> Printer b -> Printer b
    depend maker dependent =
      do state' <- get
         maker
         st <- get
         col <- gets psColumn
         if psLine state' /= psLine st || psColumn state' /= psColumn st
            then column col dependent
            else dependent

    -- | Wrap.
    wrap :: String -> String -> Printer a -> Printer a
    wrap open close p = depend (write open) $ p <* write close

    -- | Wrap in parens.
    parens :: Printer a -> Printer a
    parens = wrap "(" ")"

    -- | Wrap in braces.
    braces :: Printer a -> Printer a
    braces = wrap "{" "}"

    -- | Wrap in brackets.
    brackets :: Printer a -> Printer a
    brackets = wrap "[" "]"

    -- | Write a space.
    space :: Printer ()
    space = write " "

    -- | Write a comma.
    comma :: Printer ()
    comma = write ","

    -- | Write an integral.
    int :: Integer -> Printer ()
    int = write . show

    -- | Write out a string, updating the current position information.
    write :: String -> Printer ()
    write x =
      do eol <- gets psEolComment
         hardFail <- gets psFitOnOneLine
         let addingNewline = eol && x /= "\n"
         when addingNewline newline
         state <- get
         let writingNewline = x == "\n"
             out :: String
             out =
               if psNewline state && not writingNewline
                  then (replicate (fromIntegral (psIndentLevel state))
                                   ' ') <>
                       x
                  else x
             psColumn' =
                if additionalLines > 0
                   then fromIntegral (length (concat (take 1 (reverse srclines))))
                   else psColumn state + fromIntegral (length out)
         when
           hardFail
           (guard
              (additionalLines == 0 &&
               (psColumn' <= configMaxColumns (psConfig state))))
         modify (\s ->
                   s {psOutput = psOutput state <> S.stringUtf8 out
                     ,psNewline = False
                     ,psLine = psLine state + fromIntegral additionalLines
                     ,psEolComment= False
                     ,psColumn = psColumn'})
      where srclines = lines x
            additionalLines =
              length (filter (== '\n') x)

    -- | Write a string.
    string :: String -> Printer ()
    string = write

    -- | Indent spaces, e.g. 2.
    getIndentSpaces :: Printer Int64
    getIndentSpaces =
      gets (configIndentSpaces . psConfig)

    -- | Play with a printer and then restore the state to what it was
    -- before.
    sandbox :: Printer a -> Printer (a,PrintState)
    sandbox p =
      do orig <- get
         a <- p
         new <- get
         put orig
         return (a,new)

    -- | Render a type with a context, or not.
    withCtx :: (Pretty ast,Show (ast NodeInfo))
            => Maybe (ast NodeInfo) -> Printer b -> Printer b
    withCtx Nothing m = m
    withCtx (Just ctx) m =
      do pretty ctx
         write " =>"
         newline
         m

    -- | Maybe render an overlap definition.
    maybeOverlap ::  Maybe (Overlap NodeInfo) -> Printer ()
    maybeOverlap =
      maybe (return ())
            (\p ->
               pretty p >>
               space)

    -- | Swing the second printer below and indented with respect to the first.
    swing :: Printer () -> Printer b -> Printer ()
    swing a b =
      do orig <- gets psIndentLevel
         a
         mst <- fitsOnOneLine (do space
                                  b)
         case mst of
           Just st -> put st
           Nothing -> do newline
                         indentSpaces <- getIndentSpaces
                         _ <- column (orig + indentSpaces) b
                         return ()

    -- | Swing the second printer below and indented with respect to the first by
    -- the specified amount.
    swingBy :: Int64 -> Printer() -> Printer b -> Printer b
    swingBy i a b =
      do orig <- gets psIndentLevel
         a
         newline
         column (orig + i) b

    --------------------------------------------------------------------------------
    -- * Instances

    instance Pretty Context where
      prettyInternal ctx@(CxTuple _ asserts) = do
        mst <- fitsOnOneLine (parens (inter (comma >> space) (map pretty asserts)))
        case mst of
          Nothing -> context ctx
          Just st -> put st
      prettyInternal ctx = context ctx

    instance Pretty Pat where
      prettyInternal x =
        case x of
          PLit _ sign l -> pretty sign >> pretty l
          PNPlusK _ n k ->
            depend (do pretty n
                       write "+")
                   (int k)
          PInfixApp _ a op b ->
            case op of
              Special{} ->
                depend (pretty a)
                       (depend (prettyInfixOp op)
                               (pretty b))
              _ ->
                depend (do pretty a
                           space)
                       (depend (do prettyInfixOp op
                                   space)
                               (pretty b))
          PApp _ f args ->
            depend (do pretty f
                       unless (null args) space)
                   (spaced (map pretty args))
          PTuple _ boxed pats ->
            depend (write (case boxed of
                             Unboxed -> "(# "
                             Boxed -> "("))
                   (do commas (map pretty pats)
                       write (case boxed of
                                Unboxed -> " #)"
                                Boxed -> ")"))
          PList _ ps ->
            brackets (commas (map pretty ps))
          PParen _ e -> parens (pretty e)
          PRec _ qname fields -> do
            let horVariant = do
                  pretty qname
                  space
                  braces $ commas $ map pretty fields
                verVariant =
                  depend (pretty qname >> space) $ do
                    case fields of
                      [] -> write "{}"
                      [field] -> braces $ pretty field
                      _ -> do
                        depend (write "{") $
                          prefixedLined "," $ map (depend space . pretty) fields
                        newline
                        write "}"
            horVariant `ifFitsOnOneLineOrElse` verVariant
          PAsPat _ n p ->
            depend (do pretty n
                       write "@")
                   (pretty p)
          PWildCard _ -> write "_"
          PIrrPat _ p ->
            depend (write "~")
                   (pretty p)
          PatTypeSig _ p ty ->
            depend (do pretty p
                       write " :: ")
                   (pretty ty)
          PViewPat _ e p ->
            depend (do pretty e
                       write " -> ")
                   (pretty p)
          PQuasiQuote _ name str -> quotation name (string str)
          PBangPat _ p ->
            depend (write "!")
                   (pretty p)
          PRPat{} -> pretty' x
          PXTag{} -> pretty' x
          PXETag{} -> pretty' x
          PXPcdata{} -> pretty' x
          PXPatTag{} -> pretty' x
          PXRPats{} -> pretty' x
          PVar{} -> pretty' x
          PSplice _ s -> pretty s

    -- | Pretty infix application of a name (identifier or symbol).
    prettyInfixName :: Name NodeInfo -> Printer ()
    prettyInfixName (Ident _ n) = do write "`"; string n; write "`";
    prettyInfixName (Symbol _ s) = string s

    -- | Pretty print a name for being an infix operator.
    prettyInfixOp ::  QName NodeInfo -> Printer ()
    prettyInfixOp x =
      case x of
        Qual _ mn n ->
          case n of
            Ident _ i -> do write "`"; pretty mn; write "."; string i; write "`";
            Symbol _ s -> do pretty mn; write "."; string s;
        UnQual _ n -> prettyInfixName n
        Special _ s -> pretty s

    prettyQuoteName :: Name NodeInfo -> Printer ()
    prettyQuoteName x =
      case x of
        Ident _ i -> string i
        Symbol _ s -> string ("(" ++ s ++ ")")

    instance Pretty Type where
      prettyInternal = typ

    instance Pretty Exp where
      prettyInternal = exp

    -- | Render an expression.
    exp :: Exp NodeInfo -> Printer ()
    -- | Do after lambda should swing.
    exp (Lambda _ pats (Do l stmts)) =
      do
         mst <-
              fitsOnOneLine
                (do write "\\"
                    spaced (map pretty pats)
                    write " -> "
                    pretty (Do l stmts))
         case mst of
           Nothing -> swing (do write "\\"
                                spaced (map pretty pats)
                                write " -> do")
                             (lined (map pretty stmts))
           Just st -> put st
    -- | Space out tuples.
    exp (Tuple _ boxed exps) = do
      let horVariant = parensHorB boxed $ inter (write ", ") (map pretty exps)
          verVariant = parensVerB boxed $ prefixedLined "," (map (depend space . pretty) exps)
      mst <- fitsOnOneLine horVariant
      case mst of
        Nothing -> verVariant
        Just st -> put st
      where
        parensHorB Boxed = parens
        parensHorB Unboxed = wrap "(# " " #)"
        parensVerB Boxed = parens
        parensVerB Unboxed = wrap "(#" "#)"
    -- | Space out tuples.
    exp (TupleSection _ boxed mexps) = do
      let horVariant = parensHorB boxed $ inter (write ", ") (map (maybe (return ()) pretty) mexps)
          verVariant =
            parensVerB boxed $ prefixedLined "," (map (maybe (return ()) (depend space . pretty)) mexps)
      mst <- fitsOnOneLine horVariant
      case mst of
        Nothing -> verVariant
        Just st -> put st
      where
        parensHorB Boxed = parens
        parensHorB Unboxed = wrap "(# " " #)"
        parensVerB Boxed = parens
        parensVerB Unboxed = wrap "(#" "#)"
    exp (UnboxedSum{}) = error "FIXME: No implementation for UnboxedSum."
    -- | Infix apps, same algorithm as ChrisDone at the moment.
    exp e@(InfixApp _ a op b) =
      infixApp e a op b Nothing
    -- | If bodies are indented 4 spaces. Handle also do-notation.
    exp (If _ if' then' else') =
      do depend (write "if ")
                (pretty if')
         newline
         indentSpaces <- getIndentSpaces
         indented indentSpaces
                  (do branch "then " then'
                      newline
                      branch "else " else')
         -- Special handling for do.
      where branch str e =
              case e of
                Do _ stmts ->
                  do write str
                     write "do"
                     newline
                     indentSpaces <- getIndentSpaces
                     indented indentSpaces (lined (map pretty stmts))
                _ ->
                  depend (write str)
                         (pretty e)
    -- | Render on one line, or otherwise render the op with the arguments
    -- listed line by line.
    exp (App _ op arg) = do
      let flattened = flatten op ++ [arg]
      mst <- fitsOnOneLine (spaced (map pretty flattened))
      case mst of
        Nothing -> do
          let (f:args) = flattened
          col <- gets psColumn
          spaces <- getIndentSpaces
          pretty f
          col' <- gets psColumn
          let diff = col' - col - if col == 0 then spaces else 0
          if diff + 1 <= spaces
            then space
            else newline
          spaces' <- getIndentSpaces
          indented spaces' (lined (map pretty args))
        Just st -> put st
      where
        flatten (App label' op' arg') = flatten op' ++ [amap (addComments label') arg']
        flatten x = [x]
        addComments n1 n2 =
          n2
          { nodeInfoComments = nub (nodeInfoComments n2 ++ nodeInfoComments n1)
          }
    -- | Space out commas in list.
    exp (List _ es) =
      do mst <- fitsOnOneLine p
         case mst of
           Nothing -> do
             depend
               (write "[")
               (prefixedLined "," (map (depend space . pretty) es))
             newline
             write "]"
           Just st -> put st
      where p =
              brackets (inter (write ", ")
                              (map pretty es))
    exp (RecUpdate _ exp' updates) = recUpdateExpr (pretty exp') updates
    exp (RecConstr _ qname updates) = recUpdateExpr (pretty qname) updates
    exp (Let _ binds e) =
      depend (write "let ")
             (do pretty binds
                 newline
                 indented (-3) (depend (write "in ")
                                       (pretty e)))
    exp (ListComp _ e qstmt) = do
      let horVariant = brackets $ do
            pretty e
            write " | "
            commas $ map pretty qstmt
          verVariant = do
            write "[ "
            pretty e
            newline
            depend (write "| ") $ prefixedLined ", " $ map pretty qstmt
            newline
            write "]"
      horVariant `ifFitsOnOneLineOrElse` verVariant

    exp (ParComp _ e qstmts) = do
      let horVariant = brackets $ do
            pretty e
            for_ qstmts $ \qstmt -> do
              write " | "
              commas $ map pretty qstmt
          verVariant = do
            depend (write "[ ") $ pretty e
            newline
            for_ qstmts $ \qstmt -> do
              depend (write "| ") $ prefixedLined ", " $ map pretty qstmt
              newline
            write "]"
      horVariant `ifFitsOnOneLineOrElse` verVariant

    exp (TypeApp _ t) = do
      write "@"
      pretty t
    exp (NegApp _ e) =
      depend (write "-")
             (pretty e)
    exp (Lambda _ ps e) = do
      write "\\"
      spaced [ do case (i, x) of
                    (0, PIrrPat {}) -> space
                    (0, PBangPat {}) -> space
                    _ -> return ()
                  pretty x
             | (i, x) <- zip [0 :: Int ..] ps
             ]
      swing (write " ->") $ pretty e
    exp (Paren _ e) = parens (pretty e)
    exp (Case _ e alts) =
      do depend (write "case ")
                (do pretty e
                    write " of")
         if null alts
           then write " {}"
           else do newline
                   indentedBlock (lined (map (withCaseContext True . pretty) alts))
    exp (Do _ stmts) =
      depend (write "do ")
             (lined (map pretty stmts))
    exp (MDo _ stmts) =
      depend (write "mdo ")
             (lined (map pretty stmts))
    exp (LeftSection _ e op) =
      parens (depend (do pretty e
                         space)
                     (pretty op))
    exp (RightSection _ e op) =
      parens (depend (do pretty e
                         space)
                     (pretty op))
    exp (EnumFrom _ e) =
      brackets (do pretty e
                   write " ..")
    exp (EnumFromTo _ e f) =
      brackets (depend (do pretty e
                           write " .. ")
                       (pretty f))
    exp (EnumFromThen _ e t) =
      brackets (depend (do pretty e
                           write ",")
                       (do pretty t
                           write " .."))
    exp (EnumFromThenTo _ e t f) =
      brackets (depend (do pretty e
                           write ",")
                       (depend (do pretty t
                                   write " .. ")
                               (pretty f)))
    exp (ExpTypeSig _ e t) =
      depend (do pretty e
                 write " :: ")
             (pretty t)
    exp (VarQuote _ x) =
      depend (write "'")
             (pretty x)
    exp (TypQuote _ x) =
      depend (write "''")
             (pretty x)
    exp (BracketExp _ b) = pretty b
    exp (SpliceExp _ s) = pretty s
    exp (QuasiQuote _ n s) = quotation n (string s)
    exp (LCase _ alts) =
      do write "\\case"
         if null alts
           then write " {}"
           else do newline
                   indentedBlock (lined (map (withCaseContext True . pretty) alts))
    exp (MultiIf _ alts) =
      withCaseContext
        True
        (depend
           (write "if ")
           (lined
              (map
                 (\p -> do
                    write "| "
                    prettyG p)
                 alts)))
      where
        prettyG (GuardedRhs _ stmts e) = do
          indented
            1
            (do (lined (map
                             (\(i,p) -> do
                                unless (i == 1)
                                       space
                                pretty p
                                unless (i == length stmts)
                                       (write ","))
                             (zip [1..] stmts))))
          swing (write " " >> rhsSeparator) (pretty e)
    exp (Lit _ lit) = prettyInternal lit
    exp (Var _ q) = pretty q
    exp (IPVar _ q) = pretty q
    exp (Con _ q) = pretty q

    exp x@XTag{} = pretty' x
    exp x@XETag{} = pretty' x
    exp x@XPcdata{} = pretty' x
    exp x@XExpTag{} = pretty' x
    exp x@XChildTag{} = pretty' x
    exp x@CorePragma{} = pretty' x
    exp x@SCCPragma{} = pretty' x
    exp x@GenPragma{} = pretty' x
    exp x@Proc{} = pretty' x
    exp x@LeftArrApp{} = pretty' x
    exp x@RightArrApp{} = pretty' x
    exp x@LeftArrHighApp{} = pretty' x
    exp x@RightArrHighApp{} = pretty' x
    exp x@ParArray{} = pretty' x
    exp x@ParArrayFromTo{} = pretty' x
    exp x@ParArrayFromThenTo{} = pretty' x
    exp x@ParArrayComp{} = pretty' x
    exp (OverloadedLabel _ label) = string ('#' : label)

    instance Pretty IPName where
     prettyInternal = pretty'

    instance Pretty Stmt where
      prettyInternal =
        stmt

    instance Pretty QualStmt where
      prettyInternal x =
        case x of
          QualStmt _ s -> pretty s
          ThenTrans _ s -> do
            write "then "
            pretty s
          ThenBy _ s t -> do
            write "then "
            pretty s
            write " by "
            pretty t
          GroupBy _ s -> do
            write "then group by "
            pretty s
          GroupUsing _ s -> do
            write "then group using "
            pretty s
          GroupByUsing _ s t -> do
            write "then group by "
            pretty s
            write " using "
            pretty t

    instance Pretty Decl where
      prettyInternal = decl'

    -- | Render a declaration.
    decl ::  Decl NodeInfo -> Printer ()
    decl (InstDecl _ moverlap dhead decls) =
      do depend (write "instance ")
                (depend (maybeOverlap moverlap)
                        (depend (pretty dhead)
                                (unless (null (fromMaybe [] decls))
                                        (write " where"))))
         unless (null (fromMaybe [] decls))
                (do newline
                    indentedBlock (lined (map pretty (fromMaybe [] decls))))
    decl (SpliceDecl _ e) = pretty e
    decl (TypeSig _ names ty) =
      depend (do inter (write ", ")
                       (map pretty names)
                 write " :: ")
             (pretty ty)
    decl (FunBind _ matches) =
      lined (map pretty matches)
    decl (ClassDecl _ ctx dhead fundeps decls) =
      do classHead ctx dhead fundeps decls
         unless (null (fromMaybe [] decls))
                (do newline
                    indentedBlock (lined (map pretty (fromMaybe [] decls))))
    decl (TypeDecl _ typehead typ') = do
      write "type "
      pretty typehead
      ifFitsOnOneLineOrElse
        (depend (write " = ") (pretty typ'))
        (do newline
            indentedBlock (depend (write " = ") (pretty typ')))
    decl (TypeFamDecl _ declhead result injectivity) = do
      write "type family "
      pretty declhead
      case result of
        Just r -> do
          space
          let sep = case r of
                      KindSig _ _ -> "::"
                      TyVarSig _ _ -> "="
          write sep
          space
          pretty r
        Nothing -> return ()
      case injectivity of
        Just i -> do
          space
          pretty i
        Nothing -> return ()
    decl (ClosedTypeFamDecl _ declhead result injectivity instances) = do
      write "type family "
      pretty declhead
      for_ result $ \r -> do
        space
        let sep = case r of
                    KindSig _ _ -> "::"
                    TyVarSig _ _ -> "="
        write sep
        space
        pretty r
      for_ injectivity $ \i -> do
        space
        pretty i
      space
      write "where"
      newline
      indentedBlock (lined (map pretty instances))
    decl (DataDecl _ dataornew ctx dhead condecls mderivs) =
      do depend (do pretty dataornew
                    space)
                (withCtx ctx
                         (do pretty dhead
                             case condecls of
                               [] -> return ()
                               [x] -> singleCons x
                               xs -> multiCons xs))
         indentSpaces <- getIndentSpaces
         forM_ mderivs $ \deriv -> newline >> column indentSpaces (pretty deriv)
      where singleCons x =
              do write " ="
                 indentSpaces <- getIndentSpaces
                 column indentSpaces
                        (do newline
                            pretty x)
            multiCons xs =
              do newline
                 indentSpaces <- getIndentSpaces
                 column indentSpaces
                        (depend (write "=")
                                (prefixedLined "|"
                                               (map (depend space . pretty) xs)))

    decl (GDataDecl _ dataornew ctx dhead mkind condecls mderivs) =
      do depend (pretty dataornew >> space)
           (withCtx ctx
             (do pretty dhead
                 case mkind of
                   Nothing -> return ()
                   Just kind -> do write " :: "
                                   pretty kind
                 write " where"))
         indentedBlock $ do
           case condecls of
             [] -> return ()
             _ -> do
               newline
               lined (map pretty condecls)
           forM_ mderivs $ \deriv -> newline >> pretty deriv

    decl (InlineSig _ inline active name) = do
      write "{-# "

      unless inline $ write "NO"
      write "INLINE "
      case active of
        Nothing -> return ()
        Just (ActiveFrom _ x) -> write ("[" ++ show x ++ "] ")
        Just (ActiveUntil _ x) -> write ("[~" ++ show x ++ "] ")
      pretty name

      write " #-}"
    decl (MinimalPragma _ (Just formula)) =
      wrap "{-# " " #-}" $ do
        depend (write "MINIMAL ") $ pretty formula
    decl (ForImp _ callconv maybeSafety maybeName name ty) = do
      string "foreign import "
      pretty' callconv >> space
      case maybeSafety of
        Just safety -> pretty' safety >> space
        Nothing -> return ()
      case maybeName of
        Just namestr -> string (show namestr) >> space
        Nothing -> return ()
      pretty' name
      tyline <- fitsOnOneLine $ do string " :: "
                                   pretty' ty
      case tyline of
        Just line -> put line
        Nothing -> do newline
                      indentedBlock $ do string ":: "
                                         pretty' ty
    decl (ForExp _ callconv maybeName name ty) = do
      string "foreign export "
      pretty' callconv >> space
      case maybeName of
        Just namestr -> string (show namestr) >> space
        Nothing -> return ()
      pretty' name
      tyline <- fitsOnOneLine $ do string " :: "
                                   pretty' ty
      case tyline of
        Just line -> put line
        Nothing -> do newline
                      indentedBlock $ do string ":: "
                                         pretty' ty
    decl x' = pretty' x'

    classHead
      :: Maybe (Context NodeInfo)
      -> DeclHead NodeInfo
      -> [FunDep NodeInfo]
      -> Maybe [ClassDecl NodeInfo]
      -> Printer ()
    classHead ctx dhead fundeps decls = shortHead `ifFitsOnOneLineOrElse` longHead
      where
        shortHead =
          depend
            (write "class ")
            (withCtx ctx $
             depend
               (pretty dhead)
               (depend (unless (null fundeps) (write " | " >> commas (map pretty fundeps)))
                  (unless (null (fromMaybe [] decls)) (write " where"))))
        longHead = do
          depend (write "class ") (withCtx ctx $ pretty dhead)
          newline
          indentedBlock $ do
            unless (null fundeps) $ do
              depend (write "| ") (prefixedLined ", " $ map pretty fundeps)
              newline
            unless (null (fromMaybe [] decls)) (write "where")

    instance Pretty TypeEqn where
      prettyInternal (TypeEqn _ in_ out_) = do
        pretty in_
        write " = "
        pretty out_

    instance Pretty Deriving where
      prettyInternal (Deriving _ strategy heads) =
        depend (write "deriving" >> space >> writeStrategy) $ do
          let heads' =
                if length heads == 1
                  then map stripParens heads
                  else heads
          maybeDerives <- fitsOnOneLine $ parens (commas (map pretty heads'))
          case maybeDerives of
            Nothing -> formatMultiLine heads'
            Just derives -> put derives
        where
          writeStrategy = case strategy of
            Nothing -> return ()
            Just st -> pretty st >> space
          stripParens (IParen _ iRule) = stripParens iRule
          stripParens x = x
          formatMultiLine derives = do
            depend (write "( ") $ prefixedLined ", " (map pretty derives)
            newline
            write ")"

    instance Pretty DerivStrategy where
      prettyInternal x =
        case x of
          DerivStock _ -> return ()
          DerivAnyclass _ -> write "anyclass"
          DerivNewtype _ -> write "newtype"

    instance Pretty Alt where
      prettyInternal x =
        case x of
          Alt _ p galts mbinds ->
            do pretty p
               pretty galts
               case mbinds of
                 Nothing -> return ()
                 Just binds ->
                   do newline
                      indentedBlock (depend (write "where ")
                                    (pretty binds))

    instance Pretty Asst where
      prettyInternal x =
        case x of
          ClassA _ name types -> spaced (pretty name : map pretty types)
          i@InfixA {} -> pretty' i
          IParam _ name ty -> do
            pretty name
            write " :: "
            pretty ty
          EqualP _ a b -> do
            pretty a
            write " ~ "
            pretty b
          ParenA _ asst -> parens (pretty asst)
          AppA _ name tys ->
            spaced (pretty name : map pretty tys)
          WildCardA _ name ->
            case name of
              Nothing -> write "_"
              Just n -> do
                write "_"
                pretty n

    instance Pretty BangType where
      prettyInternal x =
        case x of
          BangedTy _ -> write "!"
          LazyTy _ -> write "~"
          NoStrictAnnot _ -> return ()

    instance Pretty Unpackedness where
      prettyInternal (Unpack _) = write "{-# UNPACK #-}"
      prettyInternal (NoUnpack _) = write "{-# NOUNPACK #-}"
      prettyInternal (NoUnpackPragma _) = return ()

    instance Pretty Binds where
      prettyInternal x =
        case x of
          BDecls _ ds -> lined (map pretty ds)
          IPBinds _ i -> lined (map pretty i)

    instance Pretty ClassDecl where
      prettyInternal x =
        case x of
          ClsDecl _ d -> pretty d
          ClsDataFam _ ctx h mkind ->
            depend
              (write "data ")
              (withCtx
                 ctx
                 (do pretty h
                     (case mkind of
                        Nothing -> return ()
                        Just kind -> do
                          write " :: "
                          pretty kind)))
          ClsTyFam _ h msig minj ->
            depend
              (write "type ")
              (depend
                 (pretty h)
                 (depend
                    (traverse_
                       (\case
                          KindSig _ kind -> write " :: " >> pretty kind
                          TyVarSig _ tyVarBind -> write " = " >> pretty tyVarBind)
                       msig)
                    (traverse_ (\inj -> space >> pretty inj) minj)))
          ClsTyDef _ (TypeEqn _ this that) -> do
            write "type "
            pretty this
            write " = "
            pretty that
          ClsDefSig _ name ty -> do
            write "default "
            pretty name
            write " :: "
            pretty ty

    instance Pretty ConDecl where
      prettyInternal x =
        conDecl x

    instance Pretty FieldDecl where
      prettyInternal (FieldDecl _ names ty) =
        depend (do commas (map pretty names)
                   write " :: ")
               (pretty ty)

    instance Pretty FieldUpdate where
      prettyInternal x =
        case x of
          FieldUpdate _ n e ->
            swing (do pretty n
                      write " =")
                   (pretty e)
          FieldPun _ n -> pretty n
          FieldWildcard _ -> write ".."

    instance Pretty GuardedRhs where
      prettyInternal  =
        guardedRhs

    instance Pretty InjectivityInfo where
      prettyInternal x = pretty' x

    instance Pretty InstDecl where
      prettyInternal i =
        case i of
          InsDecl _ d -> pretty d
          InsType _ name ty ->
            depend (do write "type "
                       pretty name
                       write " = ")
                   (pretty ty)
          _ -> pretty' i

    instance Pretty Match where
      prettyInternal = match
        {-case x of
          Match _ name pats rhs' mbinds ->
            do depend (do pretty name
                          space)
                      (spaced (map pretty pats))
               withCaseContext False (pretty rhs')
               case mbinds of
                 Nothing -> return ()
                 Just binds ->
                   do newline
                      indentedBlock (depend (write "where ")
                                            (pretty binds))
          InfixMatch _ pat1 name pats rhs' mbinds ->
            do depend (do pretty pat1
                          space
                          prettyInfixName name)
                      (do space
                          spaced (map pretty pats))
               withCaseContext False (pretty rhs')
               case mbinds of
                 Nothing -> return ()
                 Just binds ->
                   do newline
                      indentedBlock (depend (write "where ")
                                            (pretty binds))-}

    instance Pretty PatField where
      prettyInternal x =
        case x of
          PFieldPat _ n p ->
            depend (do pretty n
                       write " = ")
                   (pretty p)
          PFieldPun _ n -> pretty n
          PFieldWildcard _ -> write ".."

    instance Pretty QualConDecl where
      prettyInternal x =
        case x of
          QualConDecl _ tyvars ctx d ->
            depend (unless (null (fromMaybe [] tyvars))
                           (do write "forall "
                               spaced (map pretty (reverse (fromMaybe [] tyvars)))
                               write ". "))
                   (withCtx ctx
                           (pretty d))

    instance Pretty GadtDecl where
    #if MIN_VERSION_haskell_src_exts(1,21,0)
      prettyInternal (GadtDecl _ name _ _ fields t) =
    #else
      prettyInternal (GadtDecl _ name fields t) =
    #endif
        horVar `ifFitsOnOneLineOrElse` verVar
        where
          fields' p =
            case fromMaybe [] fields of
              [] -> return ()
              fs -> do
                depend (write "{") $ do
                  prefixedLined "," (map (depend space . pretty) fs)
                write "}"
                p
          horVar =
            depend (pretty name >> write " :: ") $ do
              fields' (write " -> ")
              declTy t
          verVar = do
            pretty name
            newline
            indentedBlock $
              depend (write ":: ") $ do
                fields' $ do
                  newline
                  indented (-3) (write "-> ")
                declTy t

    instance Pretty Rhs where
      prettyInternal =
        rhs

    instance Pretty Splice where
      prettyInternal x =
        case x of
          IdSplice _ str ->
            do write "$"
               string str
          ParenSplice _ e ->
            depend (write "$")
                   (parens (pretty e))

    instance Pretty InstRule where
      prettyInternal (IParen _ rule) = parens $ pretty rule
      prettyInternal (IRule _ mvarbinds mctx ihead) =
        do case mvarbinds of
             Nothing -> return ()
             Just xs -> do write "forall "
                           spaced (map pretty xs)
                           write ". "
           case mctx of
             Nothing -> pretty ihead
             Just ctx -> do
               mst <- fitsOnOneLine (do pretty ctx
                                        write " => "
                                        pretty ihead
                                        write " where")
               case mst of
                 Nothing -> withCtx mctx (pretty ihead)
                 Just {} -> do
                   pretty ctx
                   write " => "
                   pretty ihead

    instance Pretty InstHead where
      prettyInternal x =
        case x of
          -- Base cases
          IHCon _ name -> pretty name
          IHInfix _ typ' name ->
            depend (pretty typ')
                   (do space
                       prettyInfixOp name)
          -- Recursive application
          IHApp _ ihead typ' ->
            depend (pretty ihead)
                   (do space
                       pretty typ')
          -- Wrapping in parens
          IHParen _ h -> parens (pretty h)

    instance Pretty DeclHead where
      prettyInternal x =
        case x of
          DHead _ name -> prettyQuoteName name
          DHParen _ h -> parens (pretty h)
          DHInfix _ var name ->
            do pretty var
               space
               prettyInfixName name
          DHApp _ dhead var ->
            depend (pretty dhead)
                   (do space
                       pretty var)

    instance Pretty Overlap where
      prettyInternal (Overlap _) = write "{-# OVERLAP #-}"
      prettyInternal (Overlapping _) = write "{-# OVERLAPPING #-}"
      prettyInternal (Overlaps _) = write "{-# OVERLAPS #-}"
      prettyInternal (Overlappable _) = write "{-# OVERLAPPABLE #-}"
      prettyInternal (NoOverlap _) = write "{-# NO_OVERLAP #-}"
      prettyInternal (Incoherent _) = write "{-# INCOHERENT #-}"

    instance Pretty Sign where
      prettyInternal (Signless _) = return ()
      prettyInternal (Negative _) = write "-"

    instance Pretty CallConv where
      prettyInternal = pretty'

    instance Pretty Safety where
      prettyInternal = pretty'

    --------------------------------------------------------------------------------
    -- * Unimplemented or incomplete printers

    instance Pretty Module where
      prettyInternal x =
        case x of
          Module _ mayModHead pragmas imps decls ->
            do inter (do newline
                         newline)
                     (mapMaybe (\(isNull,r) ->
                                  if isNull
                                     then Nothing
                                     else Just r)
                               [(null pragmas,inter newline (map pretty pragmas))
                               ,(case mayModHead of
                                   Nothing -> (True,return ())
                                   Just modHead -> (False,pretty modHead))
                               ,(null imps,formatImports imps)
                               ,(null decls
                                ,interOf newline
                                         (map (\case
                                                 r@TypeSig{} -> (1,pretty r)
                                                 r@InlineSig{} -> (1, pretty r)
                                                 r -> (2,pretty r))
                                              decls))])
               newline
            where interOf i ((c,p):ps) =
                    case ps of
                      [] -> p
                      _ ->
                        do p
                           replicateM_ c i
                           interOf i ps
                  interOf _ [] = return ()
          XmlPage{} -> error "FIXME: No implementation for XmlPage."
          XmlHybrid{} -> error "FIXME: No implementation for XmlHybrid."

    -- | Format imports, preserving empty newlines between groups.
    formatImports :: [ImportDecl NodeInfo] -> Printer ()
    formatImports =
      sequence_ .
      intersperse (newline >> newline) .
      map formatImportGroup . groupAdjacentBy atNextLine
      where
        atNextLine import1 import2 =
          let end1 = srcSpanEndLine (srcInfoSpan (nodeInfoSpan (ann import1)))
              start2 = srcSpanStartLine (srcInfoSpan (nodeInfoSpan (ann import2)))
          in start2 - end1 <= 1
        formatImportGroup imps = do
          shouldSortImports <- gets $ configSortImports . psConfig
          let imps1 =
                if shouldSortImports
                  then sortImports imps
                  else imps
          sequence_ . intersperse newline $ map formatImport imps1
        moduleVisibleName idecl =
          let ModuleName _ name = importModule idecl
          in name
        formatImport = pretty
        sortImports imps = sortOn moduleVisibleName . map sortImportSpecsOnImport $ imps
        sortImportSpecsOnImport imp = imp { importSpecs = fmap sortImportSpecs (importSpecs imp) }
        sortImportSpecs (ImportSpecList l hiding specs) = ImportSpecList l hiding sortedSpecs
          where
            sortedSpecs = sortBy importSpecCompare . map sortCNames $ specs

            sortCNames (IThingWith l2 name cNames) = IThingWith l2 name . sortBy cNameCompare $ cNames
            sortCNames is = is

    groupAdjacentBy :: (a -> a -> Bool) -> [a] -> [[a]]
    groupAdjacentBy _ [] = []
    groupAdjacentBy adj items = xs : groupAdjacentBy adj rest
      where
        (xs, rest) = spanAdjacentBy adj items

    spanAdjacentBy :: (a -> a -> Bool) -> [a] -> ([a], [a])
    spanAdjacentBy _ [] = ([], [])
    spanAdjacentBy _ [x] = ([x], [])
    spanAdjacentBy adj (x:xs@(y:_))
      | adj x y =
        let (xs', rest') = spanAdjacentBy adj xs
        in (x : xs', rest')
      | otherwise = ([x], xs)

    importSpecCompare :: ImportSpec l -> ImportSpec l -> Ordering
    importSpecCompare (IAbs _ _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2
    importSpecCompare (IAbs _ _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT
    importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2
    importSpecCompare (IAbs _ _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT
    importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2
    importSpecCompare (IAbs _ _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT
    importSpecCompare (IAbs _ _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT
    importSpecCompare (IAbs _ _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2
    importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT
    importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2
    importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT
    importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2
    importSpecCompare (IAbs _ _ _) (IVar _ _) = LT
    importSpecCompare (IThingAll _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2
    importSpecCompare (IThingAll _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT
    importSpecCompare (IThingAll _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2
    importSpecCompare (IThingAll _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT
    importSpecCompare (IThingAll _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2
    importSpecCompare (IThingAll _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT
    importSpecCompare (IThingAll _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT
    importSpecCompare (IThingAll _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2
    importSpecCompare (IThingAll _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT
    importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2
    importSpecCompare (IThingAll _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT
    importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2
    importSpecCompare (IThingAll _ _) (IVar _ _) = LT
    importSpecCompare (IThingWith _ (Ident _ s1) _) (IAbs _ _ (Ident _ s2)) = compare s1 s2
    importSpecCompare (IThingWith _ (Ident _ _) _) (IAbs _ _ (Symbol _ _)) = GT
    importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingAll _ (Ident _ s2)) = compare s1 s2
    importSpecCompare (IThingWith _ (Ident _ _) _) (IThingAll _ (Symbol _ _)) = GT
    importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingWith _ (Ident _ s2) _) = compare s1 s2
    importSpecCompare (IThingWith _ (Ident _ _) _) (IThingWith _ (Symbol _ _) _) = GT
    importSpecCompare (IThingWith _ (Symbol _ _) _) (IAbs _ _ (Ident _ _)) = LT
    importSpecCompare (IThingWith _ (Symbol _ s1) _) (IAbs _ _ (Symbol _ s2)) = compare s1 s2
    importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingAll _ (Ident _ _)) = LT
    importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingAll _ (Symbol _ s2)) = compare s1 s2
    importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingWith _ (Ident _ _) _) = LT
    importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingWith _ (Symbol _ s2) _) = compare s1 s2
    importSpecCompare (IThingWith _ _ _) (IVar _ _) = LT
    importSpecCompare (IVar _ (Ident _ s1)) (IVar _ (Ident _ s2)) = compare s1 s2
    importSpecCompare (IVar _ (Ident _ _)) (IVar _ (Symbol _ _)) = GT
    importSpecCompare (IVar _ (Symbol _ _)) (IVar _ (Ident _ _)) = LT
    importSpecCompare (IVar _ (Symbol _ s1)) (IVar _ (Symbol _ s2)) = compare s1 s2
    importSpecCompare (IVar _ _) _ = GT

    cNameCompare :: CName l -> CName l -> Ordering
    cNameCompare (VarName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2
    cNameCompare (VarName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT
    cNameCompare (VarName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2
    cNameCompare (VarName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT
    cNameCompare (VarName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT
    cNameCompare (VarName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2
    cNameCompare (VarName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT
    cNameCompare (VarName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2
    cNameCompare (ConName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2
    cNameCompare (ConName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT
    cNameCompare (ConName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2
    cNameCompare (ConName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT
    cNameCompare (ConName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT
    cNameCompare (ConName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2
    cNameCompare (ConName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT
    cNameCompare (ConName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2

    instance Pretty Bracket where
      prettyInternal x =
        case x of
          ExpBracket _ p -> quotation "" (pretty p)
          PatBracket _ p -> quotation "p" (pretty p)
          TypeBracket _ ty -> quotation "t" (pretty ty)
          d@(DeclBracket _ _) -> pretty' d

    instance Pretty IPBind where
      prettyInternal x =
        case x of
          IPBind _ name expr -> do
            pretty name
            space
            write "="
            space
            pretty expr

    instance Pretty BooleanFormula where
      prettyInternal (VarFormula _ i@(Ident _ _)) = pretty' i
      prettyInternal (VarFormula _ (Symbol _ s)) = write "(" >> string s >> write ")"
      prettyInternal (AndFormula _ fs) = do
          maybeFormulas <- fitsOnOneLine $ inter (write ", ") $ map pretty fs
          case maybeFormulas of
            Nothing -> prefixedLined ", " (map pretty fs)
            Just formulas -> put formulas
      prettyInternal (OrFormula _ fs) = do
          maybeFormulas <- fitsOnOneLine $ inter (write " | ") $ map pretty fs
          case maybeFormulas of
            Nothing -> prefixedLined "| " (map pretty fs)
            Just formulas -> put formulas
      prettyInternal (ParenFormula _ f) = parens $ pretty f

    --------------------------------------------------------------------------------
    -- * Fallback printers

    instance Pretty DataOrNew where
      prettyInternal = pretty'

    instance Pretty FunDep where
      prettyInternal = pretty'

    #if !MIN_VERSION_haskell_src_exts(1,21,0)
    instance Pretty Kind where
      prettyInternal = pretty'
    #endif

    instance Pretty ResultSig where
      prettyInternal (KindSig _ kind) = pretty kind
      prettyInternal (TyVarSig _ tyVarBind) = pretty tyVarBind

    instance Pretty Literal where
      prettyInternal (String _ _ rep) = do
        write "\""
        string rep
        write "\""
      prettyInternal (Char _ _ rep) = do
        write "'"
        string rep
        write "'"
      prettyInternal (PrimString _ _ rep) = do
        write "\""
        string rep
        write "\"#"
      prettyInternal (PrimChar _ _ rep) = do
        write "'"
        string rep
        write "'#"
      -- We print the original notation (because HSE doesn't track Hex
      -- vs binary vs decimal notation).
      prettyInternal (Int _l _i originalString) =
        string originalString
      prettyInternal (Frac _l _r originalString) =
        string originalString
      prettyInternal x = pretty' x

    instance Pretty Name where
      prettyInternal x = case x of
                              Ident _ _ -> pretty' x -- Identifiers.
                              Symbol _ s -> string s -- Symbols

    instance Pretty QName where
      prettyInternal =
        \case
          Qual _ mn n ->
            case n of
              Ident _ i -> do pretty mn; write "."; string i;
              Symbol _ s -> do write "("; pretty mn; write "."; string s; write ")";
          UnQual _ n ->
            case n of
              Ident _ i -> string i
              Symbol _ s -> do write "("; string s; write ")";
          Special _ s@Cons{} -> parens (pretty s)
          Special _ s@FunCon{} -> parens (pretty s)
          Special _ s -> pretty s

    instance Pretty SpecialCon where
      prettyInternal s =
        case s of
          UnitCon _ -> write "()"
          ListCon _ -> write "[]"
          FunCon _ -> write "->"
          TupleCon _ Boxed i ->
            string ("(" ++
                    replicate (i - 1) ',' ++
                    ")")
          TupleCon _ Unboxed i ->
            string ("(# " ++
                    replicate (i - 1) ',' ++
                    " #)")
          Cons _ -> write ":"
          UnboxedSingleCon _ -> write "(##)"
          ExprHole _ -> write "_"

    instance Pretty QOp where
      prettyInternal = pretty'

    instance Pretty TyVarBind where
      prettyInternal = pretty'

    instance Pretty ModuleHead where
      prettyInternal (ModuleHead _ name mwarnings mexports) =
        do write "module "
           pretty name
           maybe (return ()) pretty mwarnings
           maybe (return ())
                 (\exports ->
                    do newline
                       indentSpaces <- getIndentSpaces
                       indented indentSpaces (pretty exports))
                 mexports
           write " where"

    instance Pretty ModulePragma where
      prettyInternal = pretty'

    instance Pretty ImportDecl where
      prettyInternal (ImportDecl _ name qualified source safe mpkg mas mspec) = do
        write "import"
        when source $ write " {-# SOURCE #-}"
        when safe $ write " safe"
        when qualified $ write " qualified"
        case mpkg of
          Nothing -> return ()
          Just pkg -> space >> write ("\"" ++ pkg ++ "\"")
        space
        pretty name
        case mas of
          Nothing -> return ()
          Just asName -> do
            space
            write "as "
            pretty asName
        case mspec of
          Nothing -> return ()
          Just spec -> pretty spec

    instance Pretty ModuleName where
      prettyInternal (ModuleName _ name) =
        write name

    instance Pretty ImportSpecList where
      prettyInternal (ImportSpecList _ hiding spec) = do
        when hiding $ write " hiding"
        let verVar = do
              space
              parens (commas (map pretty spec))
        let horVar = do
              newline
              indentedBlock
                (do depend (write "( ") (prefixedLined ", " (map pretty spec))
                    newline
                    write ")")
        verVar `ifFitsOnOneLineOrElse` horVar

    instance Pretty ImportSpec where
      prettyInternal = pretty'

    instance Pretty WarningText where
      prettyInternal (DeprText _ s) =
        write "{-# DEPRECATED " >> string s >> write " #-}"
      prettyInternal (WarnText _ s) =
        write "{-# WARNING " >> string s >> write " #-}"

    instance Pretty ExportSpecList where
      prettyInternal (ExportSpecList _ es) = do
        depend (write "(")
               (prefixedLined "," (map pretty es))
        newline
        write ")"

    instance Pretty ExportSpec where
      prettyInternal x = string " " >> pretty' x

    -- Do statements need to handle infix expression indentation specially because
    -- do x *
    --    y
    -- is two invalid statements, not one valid infix op.
    stmt :: Stmt NodeInfo -> Printer ()
    stmt (Qualifier _ e@(InfixApp _ a op b)) =
      do col <- fmap (psColumn . snd)
                     (sandbox (write ""))
         infixApp e a op b (Just col)
    stmt (Generator _ p e) =
      do indentSpaces <- getIndentSpaces
         pretty p
         indented indentSpaces
                  (dependOrNewline
                     (write " <-")
                     space
                     e
                     pretty)
    stmt x = case x of
               Generator _ p e ->
                 depend (do pretty p
                            write " <- ")
                        (pretty e)
               Qualifier _ e -> pretty e
               LetStmt _ binds ->
                 depend (write "let ")
                        (pretty binds)
               RecStmt _ es ->
                 depend (write "rec ")
                        (lined (map pretty es))

    -- | Make the right hand side dependent if it fits on one line,
    -- otherwise send it to the next line.
    dependOrNewline
      :: Printer ()
      -> Printer ()
      -> Exp NodeInfo
      -> (Exp NodeInfo -> Printer ())
      -> Printer ()
    dependOrNewline left prefix right f =
      do msg <- fitsOnOneLine renderDependent
         case msg of
           Nothing -> do left
                         newline
                         (f right)
           Just st -> put st
      where renderDependent = depend left (do prefix; f right)

    -- | Handle do and case specially and also space out guards more.
    rhs :: Rhs NodeInfo -> Printer ()
    rhs (UnGuardedRhs _ (Do _ dos)) =
      do inCase <- gets psInsideCase
         write (if inCase then " -> " else " = ")
         indentSpaces <- getIndentSpaces
         let indentation | inCase = indentSpaces
                         | otherwise = max 2 indentSpaces
         swingBy indentation
                 (write "do")
                 (lined (map pretty dos))
    rhs (UnGuardedRhs _ e) = do
      msg <-
        fitsOnOneLine
          (do write " "
              rhsSeparator
              write " "
              pretty e)
      case msg of
        Nothing -> swing (write " " >> rhsSeparator) (pretty e)
        Just st -> put st
    rhs (GuardedRhss _ gas) =
      do newline
         n <- getIndentSpaces
         indented n
                  (lined (map (\p ->
                                 do write "|"
                                    pretty p)
                              gas))

    -- | Implement dangling right-hand-sides.
    guardedRhs :: GuardedRhs NodeInfo -> Printer ()
    -- | Handle do specially.

    guardedRhs (GuardedRhs _ stmts (Do _ dos)) =
      do indented 1
                  (do prefixedLined
                        ","
                        (map (\p ->
                                do space
                                   pretty p)
                             stmts))
         inCase <- gets psInsideCase
         write (if inCase then " -> " else " = ")
         swing (write "do")
                (lined (map pretty dos))
    guardedRhs (GuardedRhs _ stmts e) = do
        mst <- fitsOnOneLine printStmts
        case mst of
          Just st -> do
            put st
            mst' <-
              fitsOnOneLine
                (do write " "
                    rhsSeparator
                    write " "
                    pretty e)
            case mst' of
              Just st' -> put st'
              Nothing -> swingIt
          Nothing -> do
            printStmts
            swingIt
      where
        printStmts =
          indented
            1
            (do prefixedLined
                  ","
                  (map
                     (\p -> do
                        space
                        pretty p)
                     stmts))
        swingIt = swing (write " " >> rhsSeparator) (pretty e)

    match :: Match NodeInfo -> Printer ()
    match (Match _ name pats rhs' mbinds) =
      do depend (do case name of
                      Ident _ _ ->
                        pretty name
                      Symbol _ _ ->
                        do write "("
                           pretty name
                           write ")"
                    space)
           (spaced (map pretty pats))
         withCaseContext False (pretty rhs')
         for_ mbinds bindingGroup
    match (InfixMatch _ pat1 name pats rhs' mbinds) =
      do depend (do pretty pat1
                    space
                    prettyInfixName name)
                (do space
                    spaced (map pretty pats))
         withCaseContext False (pretty rhs')
         for_ mbinds bindingGroup

    -- | Format contexts with spaces and commas between class constraints.
    context :: Context NodeInfo -> Printer ()
    context ctx =
      case ctx of
        CxSingle _ a -> pretty a
        CxTuple _ as -> do
          depend (write "( ") $ prefixedLined ", " (map pretty as)
          newline
          write ")"
        CxEmpty _ -> parens (return ())

    typ :: Type NodeInfo -> Printer ()
    typ (TyTuple _ Boxed types) = do
      let horVar = parens $ inter (write ", ") (map pretty types)
      let verVar = parens $ prefixedLined "," (map (depend space . pretty) types)
      horVar `ifFitsOnOneLineOrElse` verVar
    typ (TyTuple _ Unboxed types) = do
      let horVar = wrap "(# " " #)" $ inter (write ", ") (map pretty types)
      let verVar = wrap "(#" " #)" $ prefixedLined "," (map (depend space . pretty) types)
      horVar `ifFitsOnOneLineOrElse` verVar
    typ (TyForall _ mbinds ctx ty) =
      depend (case mbinds of
                Nothing -> return ()
                Just ts ->
                  do write "forall "
                     spaced (map pretty ts)
                     write ". ")
             (do indentSpaces <- getIndentSpaces
                 withCtx ctx (indented indentSpaces (pretty ty)))
    typ (TyFun _ a b) =
      depend (do pretty a
                 write " -> ")
             (pretty b)
    typ (TyList _ t) = brackets (pretty t)
    typ (TyParArray _ t) =
      brackets (do write ":"
                   pretty t
                   write ":")
    typ (TyApp _ f a) = spaced [pretty f, pretty a]
    typ (TyVar _ n) = pretty n
    typ (TyCon _ p) = pretty p
    typ (TyParen _ e) = parens (pretty e)
    typ (TyInfix _ a promotedop b) = do
      -- Apply special rules to line-break operators.
      let isLineBreak' op =
            case op of
              PromotedName _ op' -> isLineBreak op'
              UnpromotedName _ op' -> isLineBreak op'
          prettyInfixOp' op =
            case op of
              PromotedName _ op' -> write "'" >> prettyInfixOp op'
              UnpromotedName _ op' -> prettyInfixOp op'
      linebreak <- isLineBreak' promotedop
      if linebreak
        then do pretty a
                newline
                prettyInfixOp' promotedop
                space
                pretty b
        else do pretty a
                space
                prettyInfixOp' promotedop
                space
                pretty b
    typ (TyKind _ ty k) =
      parens (do pretty ty
                 write " :: "
                 pretty k)
    typ (TyBang _ bangty unpackty right) =
      do pretty unpackty
         pretty bangty
         pretty right
    typ (TyEquals _ left right) =
      do pretty left
         write " ~ "
         pretty right
    typ (TyPromoted _ (PromotedList _ _ ts)) =
      do write "'["
         unless (null ts) $ write " "
         commas (map pretty ts)
         write "]"
    typ (TyPromoted _ (PromotedTuple _ ts)) =
      do write "'("
         unless (null ts) $ write " "
         commas (map pretty ts)
         write ")"
    typ (TyPromoted _ (PromotedCon _ _ tname)) =
      do write "'"
         pretty tname
    typ (TyPromoted _ (PromotedString _ _ raw)) = do
      do write "\""
         string raw
         write "\""
    typ ty@TyPromoted{} = pretty' ty
    typ (TySplice _ splice) = pretty splice
    typ (TyWildCard _ name) =
      case name of
        Nothing -> write "_"
        Just n ->
          do write "_"
             pretty n
    typ (TyQuasiQuote _ n s) = quotation n (string s)
    typ (TyUnboxedSum{}) = error "FIXME: No implementation for TyUnboxedSum."
    #if MIN_VERSION_haskell_src_exts(1,21,0)
    typ (TyStar _) = write "*"
    #endif

    prettyTopName :: Name NodeInfo -> Printer ()
    prettyTopName x@Ident{} = pretty x
    prettyTopName x@Symbol{} = parens $ pretty x

    -- | Specially format records. Indent where clauses only 2 spaces.
    decl' :: Decl NodeInfo -> Printer ()
    -- | Pretty print type signatures like
    --
    -- foo :: (Show x, Read x)
    --     => (Foo -> Bar)
    --     -> Maybe Int
    --     -> (Char -> X -> Y)
    --     -> IO ()
    --
    decl' (TypeSig _ names ty') = do
      mst <- fitsOnOneLine (depend (do commas (map prettyTopName names)
                                       write " :: ")
                                   (declTy ty'))
      case mst of
        Nothing -> do
          commas (map prettyTopName names)
          indentSpaces <- getIndentSpaces
          if allNamesLength >= indentSpaces
            then do write " ::"
                    newline
                    indented indentSpaces (depend (write "   ") (declTy ty'))
            else (depend (write " :: ") (declTy ty'))
        Just st -> put st
      where
        nameLength (Ident _ s) = length s
        nameLength (Symbol _ s) = length s + 2
        allNamesLength = fromIntegral $ sum (map nameLength names) + 2 * (length names - 1)

    decl' (PatBind _ pat rhs' mbinds) =
      withCaseContext False $
        do pretty pat
           pretty rhs'
           for_ mbinds bindingGroup

    -- | Handle records specially for a prettier display (see guide).
    decl' e = decl e

    declTy :: Type NodeInfo -> Printer ()
    declTy dty =
      case dty of
        TyForall _ mbinds mctx ty ->
          case mbinds of
            Nothing -> do
              case mctx of
                Nothing -> prettyTy False ty
                Just ctx -> do
                  mst <- fitsOnOneLine (do pretty ctx
                                           depend (write " => ") (prettyTy False ty))
                  case mst of
                    Nothing -> do
                      pretty ctx
                      newline
                      indented (-3) (depend (write "=> ") (prettyTy True ty))
                    Just st -> put st
            Just ts -> do
              write "forall "
              spaced (map pretty ts)
              write "."
              case mctx of
                Nothing -> do
                  mst <- fitsOnOneLine (space >> prettyTy False ty)
                  case mst of
                    Nothing -> do
                      newline
                      prettyTy True ty
                    Just st -> put st
                Just ctx -> do
                  mst <- fitsOnOneLine (space >> pretty ctx)
                  case mst of
                    Nothing -> do
                      newline
                      pretty ctx
                      newline
                      indented (-3) (depend (write "=> ") (prettyTy True ty))
                    Just st -> do
                      put st
                      newline
                      indented (-3) (depend (write "=> ") (prettyTy True ty))
        _ -> prettyTy False dty
      where
        collapseFaps (TyFun _ arg result) = arg : collapseFaps result
        collapseFaps e = [e]
        prettyTy breakLine ty = do
          if breakLine
            then
              case collapseFaps ty of
                [] -> pretty ty
                tys -> prefixedLined "-> " (map pretty tys)
            else do
              mst <- fitsOnOneLine (pretty ty)
              case mst of
                Nothing ->
                  case collapseFaps ty of
                    [] -> pretty ty
                    tys -> prefixedLined "-> " (map pretty tys)
                Just st -> put st

    -- | Use special record display, used by 'dataDecl' in a record scenario.
    qualConDecl :: QualConDecl NodeInfo -> Printer ()
    qualConDecl (QualConDecl _ tyvars ctx d) =
      depend (unless (null (fromMaybe [] tyvars))
                     (do write "forall "
                         spaced (map pretty (fromMaybe [] tyvars))
                         write ". "))
             (withCtx ctx (recDecl d))

    -- | Fields are preceded with a space.
    conDecl :: ConDecl NodeInfo -> Printer ()
    conDecl (RecDecl _ name fields) = do
       pretty name
       newline
       indentedBlock
        (do depend (write "{")
                   (prefixedLined ","
                                  (map (depend space . pretty) fields))
            newline
            write "}"
            )
    conDecl (ConDecl _ name bangty) = do
      prettyQuoteName name
      unless
        (null bangty)
        (ifFitsOnOneLineOrElse
           (do space
               spaced (map pretty bangty))
           (do newline
               indentedBlock (lined (map pretty bangty))))
    conDecl (InfixConDecl _ a f b) =
      inter space [pretty a, pretty f, pretty b]

    -- | Record decls are formatted like: Foo
    -- { bar :: X
    -- }
    recDecl :: ConDecl NodeInfo -> Printer ()
    recDecl (RecDecl _ name fields) =
      do pretty name
         indentSpaces <- getIndentSpaces
         newline
         column indentSpaces
                (do depend (write "{!")
                           (prefixedLined ","
                                          (map (depend space . pretty) fields))
                    newline
                    write "}")
    recDecl r = prettyInternal r

    recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer ()
    recUpdateExpr expWriter updates = do
      ifFitsOnOneLineOrElse hor $ do
        expWriter
        newline
        indentedBlock (updatesHor `ifFitsOnOneLineOrElse` updatesVer)
      where
        hor = do
          expWriter
          space
          updatesHor
        updatesHor = braces $ commas $ map pretty updates
        updatesVer = do
          depend (write "{ ") $ prefixedLined ", " $ map pretty updates
          newline
          write "}"

    --------------------------------------------------------------------------------
    -- Predicates

    -- | Is the decl a record?
    isRecord :: QualConDecl t -> Bool
    isRecord (QualConDecl _ _ _ RecDecl{}) = True
    isRecord _ = False

    -- | If the given operator is an element of line breaks in configuration.
    isLineBreak :: QName NodeInfo -> Printer Bool
    isLineBreak (UnQual _ (Symbol _ s)) = do
      breaks <- gets (configLineBreaks . psConfig)
      return $ s `elem` breaks
    isLineBreak _ = return False

    -- | Does printing the given thing overflow column limit? (e.g. 80)
    fitsOnOneLine :: Printer a -> Printer (Maybe PrintState)
    fitsOnOneLine p =
      do st <- get
         put st { psFitOnOneLine = True}
         ok <- fmap (const True) p <|> return False
         st' <- get
         put st
         guard $ ok || not (psFitOnOneLine st)
         return (if ok
                    then Just st' { psFitOnOneLine = psFitOnOneLine st }
                    else Nothing)

    -- | If first printer fits, use it, else use the second one.
    ifFitsOnOneLineOrElse :: Printer a -> Printer a -> Printer a
    ifFitsOnOneLineOrElse a b = do
      stOrig <- get
      put stOrig{psFitOnOneLine = True}
      res <- fmap Just a <|> return Nothing
      case res of
        Just r -> do
          modify $ \st -> st{psFitOnOneLine = psFitOnOneLine stOrig}
          return r
        Nothing -> do
          put stOrig
          guard $ not (psFitOnOneLine stOrig)
          b

    bindingGroup :: Binds NodeInfo -> Printer ()
    bindingGroup binds =
      do newline
         indented 2
                  (do write "where"
                      newline
                      indented 2 (pretty binds))

    infixApp :: Exp NodeInfo
             -> Exp NodeInfo
             -> QOp NodeInfo
             -> Exp NodeInfo
             -> Maybe Int64
             -> Printer ()
    infixApp e a op b indent =
      hor `ifFitsOnOneLineOrElse` ver
      where
        hor =
          spaced
            [ case link of
              OpChainExp e' -> pretty e'
              OpChainLink qop -> pretty qop
            | link <- flattenOpChain e
            ]
        ver = do
          prettyWithIndent a
          beforeRhs <- case a of
                         Do _ _ -> do
                           indentSpaces <- getIndentSpaces
                           column (fromMaybe 0 indent + indentSpaces + 3) (newline >> pretty op) -- 3 = "do "
                           return space
                         _ -> space >> pretty op >> return newline
          case b of
            Lambda{} -> space >> pretty b
            LCase{} -> space >> pretty b
            Do _ stmts -> swing (write " do") $ lined (map pretty stmts)
            _ -> do
              beforeRhs
              case indent of
                Nothing -> do
                  col <- fmap (psColumn . snd)
                              (sandbox (write ""))
                  -- force indent for top-level template haskell expressions, #473.
                  if col == 0
                    then do indentSpaces <- getIndentSpaces
                            column indentSpaces (prettyWithIndent b)
                    else prettyWithIndent b
                Just col -> do
                  indentSpaces <- getIndentSpaces
                  column (col + indentSpaces) (prettyWithIndent b)
        prettyWithIndent e' =
          case e' of
            InfixApp _ a' op' b' -> infixApp e' a' op' b' indent
            _ -> pretty e'

    -- | A link in a chain of operator applications.
    data OpChainLink l
      = OpChainExp (Exp l)
      | OpChainLink (QOp l)
      deriving (Show)

    -- | Flatten a tree of InfixApp expressions into a chain of operator
    -- links.
    flattenOpChain :: Exp l -> [OpChainLink l]
    flattenOpChain (InfixApp _ left op right) =
      flattenOpChain left <>
      [OpChainLink op] <>
      flattenOpChain right
    flattenOpChain e = [OpChainExp e]

    -- | Write a Template Haskell quotation or a quasi-quotation.
    --
    -- >>> quotation "t" (string "Foo")
    -- > [t|Foo|]
    quotation :: String -> Printer () -> Printer ()
    quotation quoter body =
      brackets
        (depend
           (do string quoter
               write "|")
           (do body
               write "|"))