aihc-parser-1.0.0.2: src/Aihc/Parser/Shorthand.hs

{-# LANGUAGE OverloadedStrings #-}

-- |
--
-- Module      : Aihc.Parser.Shorthand
-- Description : Compact pretty-printing for debugging/inspection
--
-- This module provides a compact, human-readable representation of parsed
-- AST structures via the 'Shorthand' typeclass. Key features:
--
-- * Source spans are omitted to reduce noise
-- * Empty fields (Nothing, [], False, etc.) and field labels are omitted
-- * Remaining constructor/value tokens are a subsequence of the derived 'Show' output
-- * Output is on a single line by default
-- * Uses the prettyprinter library for consistent formatting
--
-- Example:
--
-- >>> shorthand $ snd $ parseModule defaultConfig "module Demo where x = 1"
-- Module {ModuleHead {"Demo"}, [DeclValue (PatternBind (PVar "x") (EInt 1 TInteger))]}
module Aihc.Parser.Shorthand
  ( Shorthand (..),
  )
where

import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..))
import Aihc.Parser.Syntax
import Aihc.Parser.Types (ParseResult (..))
import Data.Text (Text)
import Prettyprinter
  ( Doc,
    Pretty (..),
    braces,
    brackets,
    comma,
    hsep,
    parens,
    punctuate,
    (<+>),
  )

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Aihc.Parser

-- | Typeclass for compact, human-readable AST representations.
--
-- The 'shorthand' method produces a 'Doc' that can be rendered to text
-- or shown as a string. This is useful for debugging and golden tests.
--
-- Use 'show' on the result of 'shorthand' to get a 'String':
--
-- @
-- show (shorthand expr) :: String
-- @
class Shorthand a where
  shorthand :: a -> Doc ()

-- ParseResult

instance (Shorthand a) => Shorthand (ParseResult a) where
  shorthand (ParseOk a) = "ParseOk" <+> parens (shorthand a)
  shorthand (ParseErr _) = "ParseErr"

-- Module

instance Shorthand Module where
  shorthand modu =
    "Module" <+> braces (hsep (punctuate comma fields))
    where
      fields =
        optionalField docModuleHead (moduleHead modu)
          <> listField docExtensionSetting (moduleLanguagePragmas modu)
          <> listField docImportDecl (moduleImports modu)
          <> listField docDecl (moduleDecls modu)

instance Shorthand Decl where
  shorthand = docDecl

instance Shorthand Expr where
  shorthand = docExpr

instance Shorthand Pattern where
  shorthand = docPattern

instance Shorthand Type where
  shorthand = docType

instance Shorthand LexToken where
  shorthand = docToken

instance Shorthand LexTokenKind where
  shorthand = docTokenKind

docModuleHead :: ModuleHead -> Doc ann
docModuleHead head' =
  "ModuleHead" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [docText (moduleHeadName head')]
        <> optionalField docPragma (moduleHeadWarningPragma head')
        <> optionalField (brackets . hsep . punctuate comma . map docExportSpec) (moduleHeadExports head')

docExtensionSetting :: ExtensionSetting -> Doc ann
docExtensionSetting setting =
  case setting of
    EnableExtension ext -> pretty (extensionName ext)
    DisableExtension ext -> "DisableExtension" <+> pretty (extensionName ext)

docExportSpec :: ExportSpec -> Doc ann
docExportSpec spec =
  case spec of
    ExportAnn _ sub -> docExportSpec sub
    ExportModule mWarning name ->
      "ExportModule" <> braces (hsep (punctuate comma (optionalField docPragma mWarning <> [docText name])))
    ExportVar mWarning mNamespace name ->
      "ExportVar" <> braces (hsep (punctuate comma (optionalField docPragma mWarning <> optionalField docIENamespace mNamespace <> [docName name])))
    ExportAbs mWarning mNamespace name ->
      "ExportAbs" <> braces (hsep (punctuate comma (optionalField docPragma mWarning <> optionalField docIENamespace mNamespace <> [docName name])))
    ExportAll mWarning mNamespace name ->
      "ExportAll" <> braces (hsep (punctuate comma (optionalField docPragma mWarning <> optionalField docIENamespace mNamespace <> [docName name])))
    ExportWith mWarning mNamespace name members ->
      "ExportWith" <> braces (hsep (punctuate comma fields))
      where
        fields =
          optionalField docPragma mWarning
            <> optionalField docIENamespace mNamespace
            <> [docName name, brackets (hsep (punctuate comma (map docExportMember members)))]
    ExportWithAll mWarning mNamespace name wildcardIndex members ->
      "ExportWithAll" <> braces (hsep (punctuate comma fields))
      where
        fields =
          optionalField docPragma mWarning
            <> optionalField docIENamespace mNamespace
            <> [docName name, pretty wildcardIndex, brackets (hsep (punctuate comma (map docExportMember members)))]

docImportDecl :: ImportDecl -> Doc ann
docImportDecl decl =
  "ImportDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [docText (importDeclModule decl)]
        <> optionalField docPragma (importDeclSourcePragma decl)
        <> boolField (importDeclSafe decl)
        <> boolField (importDeclQualified decl)
        <> boolField (importDeclQualifiedPost decl)
        <> optionalField docImportLevel (importDeclLevel decl)
        <> optionalField docText (importDeclPackage decl)
        <> optionalField docText (importDeclAs decl)
        <> optionalField docImportSpec (importDeclSpec decl)

docImportLevel :: ImportLevel -> Doc ann
docImportLevel level =
  case level of
    ImportLevelQuote -> "ImportLevelQuote"
    ImportLevelSplice -> "ImportLevelSplice"

docImportSpec :: ImportSpec -> Doc ann
docImportSpec spec =
  "ImportSpec" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      boolField (importSpecHiding spec)
        <> [brackets (hsep (punctuate comma (map docImportItem (importSpecItems spec))))]

docImportItem :: ImportItem -> Doc ann
docImportItem item =
  case item of
    ImportAnn _ sub -> docImportItem sub
    ImportItemVar mNamespace name ->
      "ImportItemVar" <> braces (hsep (punctuate comma (optionalField docIENamespace mNamespace <> [docUnqualifiedName name])))
    ImportItemAbs mNamespace name ->
      "ImportItemAbs" <> braces (hsep (punctuate comma (optionalField docIENamespace mNamespace <> [docUnqualifiedName name])))
    ImportItemAll mNamespace name ->
      "ImportItemAll" <> braces (hsep (punctuate comma (optionalField docIENamespace mNamespace <> [docUnqualifiedName name])))
    ImportItemWith mNamespace name members ->
      "ImportItemWith" <> braces (hsep (punctuate comma fields))
      where
        fields =
          optionalField docIENamespace mNamespace
            <> [docUnqualifiedName name, brackets (hsep (punctuate comma (map docExportMember members)))]
    ImportItemAllWith mNamespace name wildcardIndex members ->
      "ImportItemAllWith" <> braces (hsep (punctuate comma fields))
      where
        fields =
          optionalField docIENamespace mNamespace
            <> [docUnqualifiedName name, pretty wildcardIndex, brackets (hsep (punctuate comma (map docExportMember members)))]

docIENamespace :: IEEntityNamespace -> Doc ann
docIENamespace namespace =
  case namespace of
    IEEntityNamespaceType -> "IEEntityNamespaceType"
    IEEntityNamespacePattern -> "IEEntityNamespacePattern"
    IEEntityNamespaceData -> "IEEntityNamespaceData"

docIEBundledNamespace :: IEBundledNamespace -> Doc ann
docIEBundledNamespace namespace =
  case namespace of
    IEBundledNamespaceType -> "IEBundledNamespaceType"
    IEBundledNamespaceData -> "IEBundledNamespaceData"

docExportMember :: IEBundledMember -> Doc ann
docExportMember (IEBundledMember mNamespace name) =
  "IEBundledMember" <> braces (hsep (punctuate comma (optionalField docIEBundledNamespace mNamespace <> [docName name])))

-- Declarations

docDecl :: Decl -> Doc ann
docDecl decl =
  case decl of
    DeclAnn _ sub -> docDecl sub
    DeclValue vdecl -> "DeclValue" <+> parens (docValueDecl vdecl)
    DeclTypeSig names ty -> "DeclTypeSig" <+> brackets (hsep (punctuate comma (map docUnqualifiedNameText names))) <+> parens (docType ty)
    DeclPatSyn ps -> "DeclPatSyn" <+> parens (docPatSynDecl ps)
    DeclPatSynSig names ty -> "DeclPatSynSig" <+> brackets (hsep (punctuate comma (map docUnqualifiedName names))) <+> parens (docType ty)
    DeclStandaloneKindSig name kind -> "DeclStandaloneKindSig" <+> parens (docUnqualifiedName name) <+> parens (docType kind)
    DeclFixity assoc mNamespace mPrec ops -> "DeclFixity" <+> docFixityAssoc assoc <+> maybe "Nothing" docIENamespace mNamespace <+> maybe "Nothing" pretty mPrec <+> brackets (hsep (punctuate comma (map docUnqualifiedName ops)))
    DeclRoleAnnotation ann -> "DeclRoleAnnotation" <+> parens (docRoleAnnotation ann)
    DeclTypeSyn syn -> "DeclTypeSyn" <+> parens (docTypeSynDecl syn)
    DeclData dd -> "DeclData" <+> parens (docDataDecl dd)
    DeclTypeData dd -> "DeclTypeData" <+> parens (docDataDecl dd)
    DeclNewtype nd -> "DeclNewtype" <+> parens (docNewtypeDecl nd)
    DeclClass cd -> "DeclClass" <+> parens (docClassDecl cd)
    DeclInstance inst -> "DeclInstance" <+> parens (docInstanceDecl inst)
    DeclStandaloneDeriving sd -> "DeclStandaloneDeriving" <+> parens (docStandaloneDerivingDecl sd)
    DeclDefault tys -> "DeclDefault" <+> brackets (hsep (punctuate comma (map docType tys)))
    DeclForeign fd -> "DeclForeign" <+> parens (docForeignDecl fd)
    DeclSplice body -> "DeclSplice" <+> parens (docExpr body)
    DeclTypeFamilyDecl tf -> "DeclTypeFamilyDecl" <+> parens (docTypeFamilyDecl tf)
    DeclDataFamilyDecl df -> "DeclDataFamilyDecl" <+> parens (docDataFamilyDecl df)
    DeclTypeFamilyInst tfi -> "DeclTypeFamilyInst" <+> parens (docTypeFamilyInst tfi)
    DeclDataFamilyInst dfi -> "DeclDataFamilyInst" <+> parens (docDataFamilyInst dfi)
    DeclPragma pragma -> "DeclPragma" <+> docPragma pragma

docValueDecl :: ValueDecl -> Doc ann
docValueDecl vdecl =
  case vdecl of
    FunctionBind name matches -> "FunctionBind" <+> docUnqualifiedNameText name <+> brackets (hsep (punctuate comma (map docMatch matches)))
    PatternBind multTag pat rhs -> "PatternBind" <+> hsep (docPatternBindFields multTag pat rhs)

docPatternBindFields :: MultiplicityTag -> Pattern -> Rhs Expr -> [Doc ann]
docPatternBindFields multTag pat rhs =
  multiplicityFields <> [parens (docPattern pat), parens (docRhs rhs)]
  where
    multiplicityFields =
      case multTag of
        NoMultiplicityTag -> []
        _ -> [docMultiplicityTag multTag]

docMultiplicityTag :: MultiplicityTag -> Doc ann
docMultiplicityTag NoMultiplicityTag = "NoMultiplicityTag"
docMultiplicityTag LinearMultiplicityTag = "LinearMultiplicityTag"
docMultiplicityTag (ExplicitMultiplicityTag ty) = "ExplicitMultiplicityTag" <+> parens (docType ty)

docArrowKind :: ArrowKind -> Doc ann
docArrowKind ArrowUnrestricted = "ArrowUnrestricted"
docArrowKind ArrowLinear = "ArrowLinear"
docArrowKind (ArrowExplicit ty) = "ArrowExplicit" <+> parens (docType ty)

docPatSynDecl :: PatSynDecl -> Doc ann
docPatSynDecl ps =
  "PatSynDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [docUnqualifiedName (patSynDeclName ps)]
        <> [docPatSynArgs (patSynDeclArgs ps)]
        <> [docPattern (patSynDeclPat ps)]
        <> [docPatSynDir (patSynDeclDir ps)]

docPatSynDir :: PatSynDir -> Doc ann
docPatSynDir dir =
  case dir of
    PatSynUnidirectional -> "PatSynUnidirectional"
    PatSynBidirectional -> "PatSynBidirectional"
    PatSynExplicitBidirectional matches ->
      "PatSynExplicitBidirectional" <+> brackets (hsep (punctuate comma (map docMatch matches)))

docPatSynArgs :: PatSynArgs -> Doc ann
docPatSynArgs args =
  case args of
    PatSynPrefixArgs vars -> "PatSynPrefixArgs" <+> docTextList vars
    PatSynInfixArgs lhs rhs -> "PatSynInfixArgs" <+> docText lhs <+> docText rhs
    PatSynRecordArgs fields' -> "PatSynRecordArgs" <+> docTextList fields'

docMatch :: Match -> Doc ann
docMatch m =
  "Match" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [ docMatchHeadForm (matchHeadForm m)
      ]
        <> listField docPattern (matchPats m)
        <> [docRhs (matchRhs m)]

docMatchHeadForm :: MatchHeadForm -> Doc ann
docMatchHeadForm headForm =
  case headForm of
    MatchHeadPrefix -> "MatchHeadPrefix"
    MatchHeadInfix -> "MatchHeadInfix"

docRhsWith :: (body -> Doc ann) -> Rhs body -> Doc ann
docRhsWith docBody rhs =
  case rhs of
    UnguardedRhs _ body Nothing -> docBody body
    UnguardedRhs _ body (Just decls) -> docBody body <+> "Just" <+> brackets (hsep (punctuate comma (map docDecl decls)))
    GuardedRhss _ grhss Nothing -> "GuardedRhss" <+> brackets (hsep (punctuate comma (map (docGuardedRhsWith docBody) grhss)))
    GuardedRhss _ grhss (Just decls) -> "GuardedRhss" <+> brackets (hsep (punctuate comma (map (docGuardedRhsWith docBody) grhss))) <+> "Just" <+> brackets (hsep (punctuate comma (map docDecl decls)))

docRhs :: Rhs Expr -> Doc ann
docRhs = docRhsWith docExpr

docGuardedRhsWith :: (body -> Doc ann) -> GuardedRhs body -> Doc ann
docGuardedRhsWith docBody grhs =
  "GuardedRhs" <+> braces (hsep (punctuate comma [brackets (hsep (punctuate comma (map docGuardQualifier (guardedRhsGuards grhs)))), docBody (guardedRhsBody grhs)]))

docGuardedRhs :: GuardedRhs Expr -> Doc ann
docGuardedRhs = docGuardedRhsWith docExpr

docGuardQualifier :: GuardQualifier -> Doc ann
docGuardQualifier gq =
  case gq of
    GuardAnn _ inner -> docGuardQualifier inner
    GuardExpr expr -> "GuardExpr" <+> parens (docExpr expr)
    GuardPat pat expr -> "GuardPat" <+> parens (docPattern pat) <+> parens (docExpr expr)
    GuardLet decls -> "GuardLet" <+> brackets (hsep (punctuate comma (map docDecl decls)))

docTypeSynDecl :: TypeSynDecl -> Doc ann
docTypeSynDecl syn =
  "TypeSynDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [docBinderHeadValue (typeSynHead syn)]
        <> [docType (typeSynBody syn)]

docRoleAnnotation :: RoleAnnotation -> Doc ann
docRoleAnnotation ann =
  "RoleAnnotation" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [docUnqualifiedName (roleAnnotationName ann)]
        <> [brackets (hsep (punctuate comma (map docRole (roleAnnotationRoles ann))))]

docRole :: Role -> Doc ann
docRole role =
  case role of
    RoleNominal -> "RoleNominal"
    RoleRepresentational -> "RoleRepresentational"
    RolePhantom -> "RolePhantom"
    RoleInfer -> "RoleInfer"

docDataDecl :: DataDecl -> Doc ann
docDataDecl dd =
  "DataDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      optionalField docPragma (dataDeclCTypePragma dd)
        <> take 1 binderFields
        <> listField docType (dataDeclContext dd)
        <> drop 1 binderFields
        <> optionalField docType (dataDeclKind dd)
        <> listField docDataConDecl (dataDeclConstructors dd)
        <> listField docDerivingClause (dataDeclDeriving dd)
    binderFields = docBinderHead (dataDeclHead dd)

docNewtypeDecl :: NewtypeDecl -> Doc ann
docNewtypeDecl nd =
  "NewtypeDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      optionalField docPragma (newtypeDeclCTypePragma nd)
        <> take 1 binderFields
        <> listField docType (newtypeDeclContext nd)
        <> drop 1 binderFields
        <> optionalField docType (newtypeDeclKind nd)
        <> optionalField docDataConDecl (newtypeDeclConstructor nd)
        <> listField docDerivingClause (newtypeDeclDeriving nd)
    binderFields = docBinderHead (newtypeDeclHead nd)

docDataConDecl :: DataConDecl -> Doc ann
docDataConDecl dcd =
  case dcd of
    DataConAnn _ inner -> docDataConDecl inner
    PrefixCon forallVars constraints name fields' ->
      "PrefixCon" <+> braces (hsep (punctuate comma ([docUnqualifiedName name] <> listField docTyVarBinder forallVars <> listField docType constraints <> listField docBangType fields')))
    InfixCon forallVars constraints lhs op rhs ->
      "InfixCon" <+> braces (hsep (punctuate comma (listField docTyVarBinder forallVars <> listField docType constraints <> [docBangType lhs, docUnqualifiedName op, docBangType rhs])))
    RecordCon forallVars constraints name fields' ->
      "RecordCon" <+> hsep (docRecordConFields forallVars constraints name fields')
    GadtCon forallBinders constraints names body ->
      "GadtCon" <+> braces (hsep (punctuate comma (listField docForallTelescope forallBinders <> listField docType constraints <> listField docUnqualifiedName names <> [docGadtBody body])))
    TupleCon forallVars constraints flavor fields' ->
      "TupleCon" <+> braces (hsep (punctuate comma (listField docTyVarBinder forallVars <> listField docType constraints <> [pretty (show flavor)] <> listField docBangType fields')))
    UnboxedSumCon forallVars constraints pos arity field' ->
      "UnboxedSumCon" <+> braces (hsep (punctuate comma (listField docTyVarBinder forallVars <> listField docType constraints <> [pretty (show pos), pretty (show arity), docBangType field'])))
    ListCon forallVars constraints ->
      "ListCon" <+> braces (hsep (punctuate comma (listField docTyVarBinder forallVars <> listField docType constraints)))

-- | Document a GADT body
docGadtBody :: GadtBody -> Doc ann
docGadtBody body =
  case body of
    GadtPrefixBody args resultTy ->
      "GadtPrefixBody" <+> braces (hsep (punctuate comma (listField docGadtArg args <> [docType resultTy])))
    GadtRecordBody fields' resultTy ->
      "GadtRecordBody" <+> braces (hsep (punctuate comma (listField docFieldDecl fields' <> [docType resultTy])))

docGadtArg :: (BangType, ArrowKind) -> Doc ann
docGadtArg (bt, ArrowUnrestricted) = parens (docBangType bt)
docGadtArg (bt, ak) = parens (docBangType bt <+> "," <+> docArrowKind ak)

docBangType :: BangType -> Doc ann
docBangType bt =
  "BangType" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      listField docPragma (bangPragmas bt)
        <> boolField (bangStrict bt)
        <> boolField (bangLazy bt)
        <> [docType (bangType bt)]

docFieldDecl :: FieldDecl -> Doc ann
docFieldDecl fd =
  "FieldDecl" <+> brackets (hsep (punctuate comma (map docUnqualifiedNameText (fieldNames fd)))) <+> parens (docFieldDeclType (fieldType fd))

docFieldDeclType :: BangType -> Doc ann
docFieldDeclType bt
  | null (bangPragmas bt),
    not (bangStrict bt),
    not (bangLazy bt) =
      docType (bangType bt)
  | otherwise = docBangType bt

docRecordConFields :: [TyVarBinder] -> [Type] -> UnqualifiedName -> [FieldDecl] -> [Doc ann]
docRecordConFields forallVars constraints name fields' =
  docUnqualifiedNameText name
    : listField docTyVarBinder forallVars
      <> listField docType constraints
      <> [brackets (hsep (punctuate comma (map docFieldDecl fields')))]

docDerivingClause :: DerivingClause -> Doc ann
docDerivingClause dc =
  "DerivingClause" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      optionalField docDerivingStrategy (derivingStrategy dc)
        <> [docDerivingClasses (derivingClasses dc)]

docDerivingClasses :: Either Name [Type] -> Doc ann
docDerivingClasses classes =
  case classes of
    Left name -> docName name
    Right types -> brackets (hsep (punctuate comma (map docType types)))

docDerivingStrategy :: DerivingStrategy -> Doc ann
docDerivingStrategy ds =
  case ds of
    DerivingStock -> "DerivingStock"
    DerivingNewtype -> "DerivingNewtype"
    DerivingAnyclass -> "DerivingAnyclass"
    DerivingVia ty -> "DerivingVia" <+> docType ty

docClassDecl :: ClassDecl -> Doc ann
docClassDecl cd =
  "ClassDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      optionalField (brackets . hsep . punctuate comma . map docType) (classDeclContext cd)
        <> binderFields
        <> listField docFunctionalDependency (classDeclFundeps cd)
        <> listField docClassDeclItem (classDeclItems cd)
    binderFields = docBinderHead (classDeclHead cd)

docFunctionalDependency :: FunctionalDependency -> Doc ann
docFunctionalDependency dep =
  "FunctionalDependency" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      listField docText (functionalDependencyDeterminers dep)
        <> listField docText (functionalDependencyDetermined dep)

docTypeFamilyInjectivity :: TypeFamilyInjectivity -> Doc ann
docTypeFamilyInjectivity injectivity =
  "TypeFamilyInjectivity" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [ docText (typeFamilyInjectivityResult injectivity)
      ]
        <> listField docText (typeFamilyInjectivityDetermined injectivity)

docTypeFamilyResultSig :: TypeFamilyResultSig -> Doc ann
docTypeFamilyResultSig sig =
  case sig of
    TypeFamilyKindSig kind -> "TypeFamilyKindSig" <+> parens (docType kind)
    TypeFamilyTyVarSig result ->
      "TypeFamilyTyVarSig" <+> braces (hsep (punctuate comma [docTyVarBinder result]))
    TypeFamilyInjectiveSig result injectivity ->
      "TypeFamilyInjectiveSig" <+> braces (hsep (punctuate comma [docTyVarBinder result, docTypeFamilyInjectivity injectivity]))

docClassDeclItem :: ClassDeclItem -> Doc ann
docClassDeclItem item =
  case item of
    ClassItemAnn _ sub -> docClassDeclItem sub
    ClassItemTypeSig names ty -> "ClassItemTypeSig" <+> braces (hsep (punctuate comma [brackets (hsep (punctuate comma (map docUnqualifiedName names))), docType ty]))
    ClassItemDefaultSig name ty -> "ClassItemDefaultSig" <+> braces (hsep (punctuate comma [docUnqualifiedName name, docType ty]))
    ClassItemFixity assoc mNamespace mPrec ops -> "ClassItemFixity" <+> braces (hsep (punctuate comma ([docFixityAssoc assoc] <> optionalField docIENamespace mNamespace <> optionalField pretty mPrec <> [brackets (hsep (punctuate comma (map docUnqualifiedName ops)))])))
    ClassItemDefault vdecl -> "ClassItemDefault" <+> parens (docValueDecl vdecl)
    ClassItemTypeFamilyDecl tf -> "ClassItemTypeFamilyDecl" <+> parens (docTypeFamilyDecl tf)
    ClassItemDataFamilyDecl df -> "ClassItemDataFamilyDecl" <+> parens (docDataFamilyDecl df)
    ClassItemDefaultTypeInst tfi -> "ClassItemDefaultTypeInst" <+> parens (docTypeFamilyInst tfi)
    ClassItemPragma pragma -> "ClassItemPragma" <+> docPragma pragma

docInstanceDecl :: InstanceDecl -> Doc ann
docInstanceDecl inst =
  "InstanceDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      listField docPragma (instanceDeclPragmas inst)
        <> optionalField docPragma (instanceDeclWarning inst)
        <> listField docTyVarBinder (instanceDeclForall inst)
        <> listField docType (instanceDeclContext inst)
        <> [docType (instanceDeclHead inst)]
        <> listField docInstanceDeclItem (instanceDeclItems inst)

docInstanceDeclItem :: InstanceDeclItem -> Doc ann
docInstanceDeclItem item =
  case item of
    InstanceItemAnn _ inner -> docInstanceDeclItem inner
    InstanceItemBind vdecl -> "InstanceItemBind" <+> parens (docValueDecl vdecl)
    InstanceItemTypeSig names ty -> "InstanceItemTypeSig" <+> braces (hsep (punctuate comma [brackets (hsep (punctuate comma (map docUnqualifiedName names))), docType ty]))
    InstanceItemFixity assoc mNamespace mPrec ops -> "InstanceItemFixity" <+> braces (hsep (punctuate comma ([docFixityAssoc assoc] <> optionalField docIENamespace mNamespace <> optionalField pretty mPrec <> [brackets (hsep (punctuate comma (map docUnqualifiedName ops)))])))
    InstanceItemTypeFamilyInst tfi -> "InstanceItemTypeFamilyInst" <+> parens (docTypeFamilyInst tfi)
    InstanceItemDataFamilyInst dfi -> "InstanceItemDataFamilyInst" <+> parens (docDataFamilyInst dfi)
    InstanceItemPragma pragma -> "InstanceItemPragma" <+> docPragma pragma

docStandaloneDerivingDecl :: StandaloneDerivingDecl -> Doc ann
docStandaloneDerivingDecl sd =
  "StandaloneDerivingDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      optionalField docDerivingStrategy (standaloneDerivingStrategy sd)
        <> listField docPragma (standaloneDerivingPragmas sd)
        <> optionalField docPragma (standaloneDerivingWarning sd)
        <> listField docType (standaloneDerivingContext sd)
        <> [docType (standaloneDerivingHead sd)]

docInstanceOverlapPragma :: InstanceOverlapPragma -> Doc ann
docInstanceOverlapPragma pragma' =
  case pragma' of
    Overlapping -> "Overlapping"
    Overlappable -> "Overlappable"
    Overlaps -> "Overlaps"
    Incoherent -> "Incoherent"

docPragmaUnpackKind :: PragmaUnpackKind -> Doc ann
docPragmaUnpackKind kind =
  case kind of
    UnpackPragma -> "UnpackPragma"
    NoUnpackPragma -> "NoUnpackPragma"

docPragmaType :: PragmaType -> Doc ann
docPragmaType pt =
  case pt of
    PragmaLanguage settings -> "PragmaLanguage" <+> brackets (hsep (punctuate comma (map docExtensionSetting settings)))
    PragmaInstanceOverlap overlapPragma -> "PragmaInstanceOverlap" <+> docInstanceOverlapPragma overlapPragma
    PragmaWarning msg -> "PragmaWarning" <+> docText msg
    PragmaDeprecated msg -> "PragmaDeprecated" <+> docText msg
    PragmaInline kind body -> "PragmaInline" <+> docText kind <+> docText body
    PragmaUnpack unpackKind -> "PragmaUnpack" <+> docPragmaUnpackKind unpackKind
    PragmaSource sourceText _ -> "PragmaSource" <+> docText sourceText
    PragmaSCC label -> "PragmaSCC" <+> docText label
    PragmaUnknown text -> "PragmaUnknown" <+> docText text

docPragma :: Pragma -> Doc ann
docPragma pragma = docPragmaType (pragmaType pragma)

docForeignDecl :: ForeignDecl -> Doc ann
docForeignDecl fd =
  "ForeignDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [docForeignDirection (foreignDirection fd)]
        <> [docCallConv (foreignCallConv fd)]
        <> optionalField docForeignSafety (foreignSafety fd)
        <> [docForeignEntitySpec (foreignEntity fd)]
        <> [docUnqualifiedName (foreignName fd)]
        <> [docType (foreignType fd)]

docForeignDirection :: ForeignDirection -> Doc ann
docForeignDirection fd =
  case fd of
    ForeignImport -> "ForeignImport"
    ForeignExport -> "ForeignExport"

docCallConv :: CallConv -> Doc ann
docCallConv cc =
  case cc of
    CCall -> "CCall"
    StdCall -> "StdCall"
    CApi -> "CApi"
    CPrim -> "CPrim"
    JavaScript -> "JavaScript"

docForeignSafety :: ForeignSafety -> Doc ann
docForeignSafety fs =
  case fs of
    Safe -> "Safe"
    Unsafe -> "Unsafe"
    Interruptible -> "Interruptible"

docForeignEntitySpec :: ForeignEntitySpec -> Doc ann
docForeignEntitySpec spec =
  case spec of
    ForeignEntityDynamic -> "ForeignEntityDynamic"
    ForeignEntityWrapper -> "ForeignEntityWrapper"
    ForeignEntityStatic mName -> "ForeignEntityStatic" <> optionalField' docText mName
    ForeignEntityAddress mName -> "ForeignEntityAddress" <> optionalField' docText mName
    ForeignEntityNamed name -> "ForeignEntityNamed" <+> docText name
    ForeignEntityOmitted -> "ForeignEntityOmitted"

docFixityAssoc :: FixityAssoc -> Doc ann
docFixityAssoc fa =
  case fa of
    Infix -> "Infix"
    InfixL -> "InfixL"
    InfixR -> "InfixR"

-- Types

docType :: Type -> Doc ann
docType ty =
  case ty of
    TVar name -> "TVar" <+> docUnqualifiedNameText name
    TCon name promoted ->
      "TCon"
        <+> docName name
        <> (if promoted == Promoted then " Promoted" else "")
    TBuiltinCon con -> "TBuiltinCon" <+> pretty (show con)
    TImplicitParam name inner -> "TImplicitParam" <+> docText name <+> parens (docType inner)
    TTypeLit lit -> "TTypeLit" <+> docTypeLiteral lit
    TStar {} -> "TStar"
    TQuasiQuote quoter body -> "TQuasiQuote" <+> docText quoter <+> docText body
    TForall telescope inner ->
      case forallTelescopeVisibility telescope of
        ForallInvisible ->
          "TForall"
            <+> brackets (hsep (punctuate comma (map docTyVarBinder (forallTelescopeBinders telescope))))
            <+> parens (docType inner)
        ForallVisible -> "TForall" <+> parens (docForallTelescope telescope) <+> parens (docType inner)
    TApp f x -> "TApp" <+> parens (docType f) <+> parens (docType x)
    TTypeApp f x -> "TTypeApp" <+> parens (docType f) <+> parens (docType x)
    TInfix lhs op promoted rhs ->
      "TInfix"
        <+> parens (docType lhs)
        <+> docName op
        <> (if promoted == Promoted then " Promoted" else "")
        <+> parens (docType rhs)
    TFun arrowKind a b -> "TFun" <+> hsep (docFunctionTypeFields arrowKind a b)
    TTuple tupleFlavor promoted elems ->
      "TTuple" <+> hsep (docTypeTupleFields tupleFlavor promoted elems)
    TUnboxedSum elems ->
      "TUnboxedSum"
        <+> brackets (hsep (punctuate comma (map docType elems)))
    TList promoted elems ->
      "TList" <+> hsep (docTypeListFields promoted elems)
    TParen inner -> "TParen" <+> parens (docType inner)
    TKindSig ty' kind -> "TKindSig" <+> parens (docType ty') <+> parens (docType kind)
    TContext constraints inner -> "TContext" <+> brackets (hsep (punctuate comma (map docType constraints))) <+> parens (docType inner)
    TSplice body -> "TSplice" <+> parens (docExpr body)
    TWildcard -> "TWildcard"
    TAnn _ sub -> docType sub

docTypeLiteral :: TypeLiteral -> Doc ann
docTypeLiteral lit =
  case lit of
    TypeLitInteger n _ -> "TypeLitInteger" <+> pretty n
    TypeLitSymbol s _ -> "TypeLitSymbol" <+> docText s
    TypeLitChar c _ -> "TypeLitChar" <+> pretty (show c)

docFunctionTypeFields :: ArrowKind -> Type -> Type -> [Doc ann]
docFunctionTypeFields arrowKind a b =
  arrowFields <> [parens (docType a), parens (docType b)]
  where
    arrowFields =
      case arrowKind of
        ArrowUnrestricted -> []
        _ -> [docArrowKind arrowKind]

docTypeListFields :: TypePromotion -> [Type] -> [Doc ann]
docTypeListFields promoted elems =
  promotedFields <> [brackets (hsep (punctuate comma (map docType elems)))]
  where
    promotedFields =
      case promoted of
        Unpromoted -> []
        Promoted -> ["Promoted"]

docTypeTupleFields :: TupleFlavor -> TypePromotion -> [Type] -> [Doc ann]
docTypeTupleFields tupleFlavor promoted elems =
  flavorFields <> promotedFields <> [brackets (hsep (punctuate comma (map docType elems)))]
  where
    flavorFields =
      case tupleFlavor of
        Boxed -> []
        _ -> [pretty (show tupleFlavor)]

    promotedFields =
      case promoted of
        Unpromoted -> []
        Promoted -> ["Promoted"]

docTyVarBinder :: TyVarBinder -> Doc ann
docTyVarBinder tvb =
  "TyVarBinder" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [docText (tyVarBinderName tvb)]
        <> optionalField (\kind -> "Just" <+> parens (docType kind)) (tyVarBinderKind tvb)
        <> optionalField docTyVarBSpecificity (specificityField tvb)
        <> optionalField docTyVarBVisibility (visibilityField tvb)

    specificityField binder =
      case tyVarBinderSpecificity binder of
        TyVarBSpecified -> Nothing
        specificity -> Just specificity

    visibilityField binder =
      case tyVarBinderVisibility binder of
        TyVarBVisible -> Nothing
        visibility -> Just visibility

docTyVarBSpecificity :: TyVarBSpecificity -> Doc ann
docTyVarBSpecificity specificity =
  case specificity of
    TyVarBInferred -> "TyVarBInferred"
    TyVarBSpecified -> "TyVarBSpecified"

docTyVarBVisibility :: TyVarBVisibility -> Doc ann
docTyVarBVisibility visibility =
  case visibility of
    TyVarBVisible -> "TyVarBVisible"
    TyVarBInvisible -> "TyVarBInvisible"

docForallVis :: ForallVis -> Doc ann
docForallVis visibility =
  case visibility of
    ForallInvisible -> "ForallInvisible"
    ForallVisible -> "ForallVisible"

docForallTelescope :: ForallTelescope -> Doc ann
docForallTelescope telescope =
  "ForallTelescope"
    <+> braces
      ( hsep
          ( punctuate
              comma
              ( [docForallVis (forallTelescopeVisibility telescope)]
                  <> listField docTyVarBinder (forallTelescopeBinders telescope)
              )
          )
      )

-- Patterns

docPattern :: Pattern -> Doc ann
docPattern pat =
  case pat of
    PAnn _ sub -> docPattern sub
    PVar name -> "PVar" <+> docUnqualifiedNameText name
    PTypeBinder binder -> "PTypeBinder" <+> parens (docTyVarBinder binder)
    PTypeSyntax form ty -> "PTypeSyntax" <+> docTypeSyntaxForm form <+> parens (docType ty)
    PWildcard -> "PWildcard"
    PLit lit -> "PLit" <+> parens (docLiteral lit)
    PQuasiQuote quoter body -> "PQuasiQuote" <+> docText quoter <+> docText body
    PTuple tupleFlavor elems ->
      "PTuple" <+> hsep (docPatternTupleFields tupleFlavor elems)
    PUnboxedSum altIdx arity inner ->
      "PUnboxedSum" <+> pretty altIdx <+> pretty arity <+> docPattern inner
    PList elems -> "PList" <+> brackets (hsep (punctuate comma (map docPattern elems)))
    PCon name typeArgs args ->
      case typeArgs of
        [] -> "PCon" <+> docName name <+> brackets (hsep (punctuate comma (map docPattern args)))
        _ ->
          "PCon"
            <+> docName name
            <+> braces
              ( hsep
                  ( punctuate
                      comma
                      ( listField docType typeArgs
                          <> listField docPattern args
                      )
                  )
              )
    PInfix lhs op rhs -> "PInfix" <+> parens (docPattern lhs) <+> docName op <+> parens (docPattern rhs)
    PView expr inner -> "PView" <+> parens (docExpr expr) <+> parens (docPattern inner)
    PAs name inner -> "PAs" <+> docUnqualifiedName name <+> parens (docPattern inner)
    PStrict inner -> "PStrict" <+> parens (docPattern inner)
    PIrrefutable inner -> "PIrrefutable" <+> parens (docPattern inner)
    PNegLit lit -> "PNegLit" <+> parens (docLiteral lit)
    PParen inner -> "PParen" <+> parens (docPattern inner)
    PRecord name fields' hasWildcard -> "PRecord" <+> docName name <+> braces (hsep (punctuate comma ([docPatternRecordField recordField | recordField <- fields'] ++ [".." | hasWildcard])))
    PTypeSig inner ty -> "PTypeSig" <+> parens (docPattern inner) <+> parens (docType ty)
    PSplice body -> "PSplice" <+> parens (docExpr body)

docPatternTupleFields :: TupleFlavor -> [Pattern] -> [Doc ann]
docPatternTupleFields tupleFlavor elems =
  flavorFields <> [brackets (hsep (punctuate comma (map docPattern elems)))]
  where
    flavorFields =
      case tupleFlavor of
        Boxed -> []
        _ -> [pretty (show tupleFlavor)]

docLiteral :: Literal -> Doc ann
docLiteral lit =
  case peelLiteralAnn lit of
    LitInt n nt _ -> "LitInt" <+> pretty n <+> docNumericType nt
    LitFloat n ft _ -> "LitFloat" <+> pretty (show n) <+> docFloatType ft
    LitChar c _ -> "LitChar" <+> pretty (show c)
    LitCharHash c repr -> "LitCharHash" <+> pretty (show c) <+> docText repr
    LitString s _ -> "LitString" <+> docText s
    LitStringHash s repr -> "LitStringHash" <+> docText s <+> docText repr
    LitAnn {} -> error "unreachable"

-- Expressions

docExpr :: Expr -> Doc ann
docExpr expr =
  case expr of
    EVar name -> "EVar" <+> docName name
    ETypeSyntax form ty -> "ETypeSyntax" <+> docTypeSyntaxForm form <+> parens (docType ty)
    EInt n nt _ -> "EInt" <+> pretty n <+> docNumericType nt
    EFloat n ft _ -> "EFloat" <+> pretty (show n) <+> docFloatType ft
    EChar c _ -> "EChar" <+> pretty (show c)
    ECharHash c repr -> "ECharHash" <+> pretty (show c) <+> docText repr
    EString s _ -> "EString" <+> docText s
    EStringHash s repr -> "EStringHash" <+> docText s <+> docText repr
    EOverloadedLabel label raw -> "EOverloadedLabel" <+> docText label <+> docText raw
    EQuasiQuote quoter body -> "EQuasiQuote" <+> docText quoter <+> docText body
    ETHExpQuote body -> "ETHExpQuote" <+> parens (docExpr body)
    ETHTypedQuote body -> "ETHTypedQuote" <+> parens (docExpr body)
    ETHDeclQuote decls -> "ETHDeclQuote" <+> brackets (hsep (punctuate comma (map docDecl decls)))
    ETHTypeQuote ty -> "ETHTypeQuote" <+> parens (docType ty)
    ETHPatQuote pat -> "ETHPatQuote" <+> parens (docPattern pat)
    ETHNameQuote body -> "ETHNameQuote" <+> parens (docExpr body)
    ETHTypeNameQuote ty -> "ETHTypeNameQuote" <+> parens (docType ty)
    ETHSplice body -> "ETHSplice" <+> parens (docExpr body)
    ETHTypedSplice body -> "ETHTypedSplice" <+> parens (docExpr body)
    EIf cond yes no -> "EIf" <+> parens (docExpr cond) <+> parens (docExpr yes) <+> parens (docExpr no)
    EMultiWayIf rhss -> "EMultiWayIf" <+> brackets (hsep (punctuate comma (map docGuardedRhs rhss)))
    ELambdaPats pats body -> "ELambdaPats" <+> brackets (hsep (punctuate comma (map docPattern pats))) <+> parens (docExpr body)
    ELambdaCase alts -> "ELambdaCase" <+> brackets (hsep (punctuate comma (map docCaseAlt alts)))
    ELambdaCases alts -> "ELambdaCases" <+> brackets (hsep (punctuate comma (map docLambdaCaseAlt alts)))
    EInfix lhs op rhs -> "EInfix" <+> parens (docExpr lhs) <+> docName op <+> parens (docExpr rhs)
    ENegate inner -> "ENegate" <+> parens (docExpr inner)
    ESectionL lhs op -> "ESectionL" <+> parens (docExpr lhs) <+> docName op
    ESectionR op rhs -> "ESectionR" <+> docName op <+> parens (docExpr rhs)
    ELetDecls decls body -> "ELetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls))) <+> parens (docExpr body)
    ECase scrutinee alts -> "ECase" <+> parens (docExpr scrutinee) <+> brackets (hsep (punctuate comma (map docCaseAlt alts)))
    EDo stmts flavor -> "EDo" <+> hsep (brackets (hsep (punctuate comma (map docDoStmt stmts))) : docDoFlavorFields flavor)
    EListComp body quals -> "EListComp" <+> parens (docExpr body) <+> brackets (hsep (punctuate comma (map docCompStmt quals)))
    EListCompParallel body qualGroups -> "EListCompParallel" <+> parens (docExpr body) <+> brackets (hsep (punctuate "|" [brackets (hsep (punctuate comma (map docCompStmt qs))) | qs <- qualGroups]))
    EArithSeq seqInfo -> "EArithSeq" <+> parens (docArithSeq seqInfo)
    ERecordCon name fields' hasWildcard -> "ERecordCon" <+> docName name <+> braces (hsep (punctuate comma ([docExprRecordField recordField | recordField <- fields'] ++ [".." | hasWildcard])))
    ERecordUpd base fields' -> "ERecordUpd" <+> parens (docExpr base) <+> braces (hsep (punctuate comma [docExprRecordField recordField | recordField <- fields']))
    EGetField base fieldName -> "EGetField" <+> parens (docExpr base) <+> docName fieldName
    EGetFieldProjection fields -> "EGetFieldProjection" <+> brackets (hsep (punctuate comma (map docName fields)))
    ETypeSig inner ty -> "ETypeSig" <+> parens (docExpr inner) <+> parens (docType ty)
    EParen inner -> "EParen" <+> parens (docExpr inner)
    EList elems -> "EList" <+> brackets (hsep (punctuate comma (map docExpr elems)))
    ETuple tupleFlavor elems ->
      "ETuple" <+> hsep (docExprTupleFields tupleFlavor elems)
    EUnboxedSum altIdx arity inner ->
      "EUnboxedSum" <+> pretty altIdx <+> pretty arity <+> docExpr inner
    ETypeApp inner ty -> "ETypeApp" <+> parens (docExpr inner) <+> parens (docType ty)
    EApp f x -> "EApp" <+> parens (docExpr f) <+> parens (docExpr x)
    EProc pat body -> "EProc" <+> parens (docPattern pat) <+> parens (docCmd body)
    EPragma pragma inner -> "EPragma" <+> parens (docPragma pragma) <+> parens (docExpr inner)
    EAnn _ sub -> docExpr sub

docPatternRecordField :: RecordField Pattern -> Doc ann
docPatternRecordField recordField =
  docName (recordFieldName recordField)
    <+> (if recordFieldPun recordField then "~pun" else "=")
    <+> docPattern (recordFieldValue recordField)

docExprRecordField :: RecordField Expr -> Doc ann
docExprRecordField recordField =
  docName (recordFieldName recordField)
    <+> (if recordFieldPun recordField then "~pun" else "=")
    <+> docExpr (recordFieldValue recordField)

docMaybeExpr :: Maybe Expr -> Doc ann
docMaybeExpr Nothing = "Nothing"
docMaybeExpr (Just expr) = docExpr expr

docCaseAltWith :: (body -> Doc ann) -> CaseAlt body -> Doc ann
docCaseAltWith docBody (CaseAlt _ pat rhs) =
  "CaseAlt" <+> parens (docPattern pat) <+> parens (docRhsWith docBody rhs)

docCaseAlt :: CaseAlt Expr -> Doc ann
docCaseAlt = docCaseAltWith docExpr

docLambdaCaseAlt :: LambdaCaseAlt -> Doc ann
docLambdaCaseAlt (LambdaCaseAlt _ pats rhs) =
  "LambdaCaseAlt" <+> brackets (hsep (punctuate comma (map docPattern pats))) <+> parens (docRhs rhs)

docDoFlavorFields :: DoFlavor -> [Doc ann]
docDoFlavorFields flavor =
  case flavor of
    DoPlain -> []
    DoMdo -> flavorField "DoMdo"
    DoQualified m -> flavorField ("DoQualified" <+> docText m)
    DoQualifiedMdo m -> flavorField ("DoQualifiedMdo" <+> docText m)
  where
    flavorField doc = [parens doc]

docExprTupleFields :: TupleFlavor -> [Maybe Expr] -> [Doc ann]
docExprTupleFields tupleFlavor elems =
  flavorFields <> [brackets (hsep (punctuate comma (map docMaybeExpr elems)))]
  where
    flavorFields =
      case tupleFlavor of
        Boxed -> []
        _ -> [pretty (show tupleFlavor)]

docDoStmt :: DoStmt Expr -> Doc ann
docDoStmt stmt =
  case stmt of
    DoAnn _ inner -> docDoStmt inner
    DoBind pat expr -> "DoBind" <+> parens (docPattern pat) <+> parens (docExpr expr)
    DoLetDecls decls -> "DoLetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls)))
    DoExpr expr -> "DoExpr" <+> parens (docExpr expr)
    DoRecStmt stmts -> "DoRecStmt" <+> brackets (hsep (punctuate comma (map docDoStmt stmts)))

docCompStmt :: CompStmt -> Doc ann
docCompStmt stmt =
  case stmt of
    CompAnn _ inner -> docCompStmt inner
    CompGen pat expr -> "CompGen" <+> parens (docPattern pat) <+> parens (docExpr expr)
    CompGuard expr -> "CompGuard" <+> parens (docExpr expr)
    CompLetDecls decls -> "CompLetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls)))
    CompThen f -> "CompThen" <+> parens (docExpr f)
    CompThenBy f e -> "CompThenBy" <+> parens (docExpr f) <+> parens (docExpr e)
    CompGroupUsing f -> "CompGroupUsing" <+> parens (docExpr f)
    CompGroupByUsing e f -> "CompGroupByUsing" <+> parens (docExpr e) <+> parens (docExpr f)

docCmd :: Cmd -> Doc ann
docCmd cmd =
  case cmd of
    CmdAnn _ inner -> docCmd inner
    CmdArrApp lhs HsFirstOrderApp rhs -> "CmdArrApp" <+> parens (docExpr lhs) <+> "HsFirstOrderApp" <+> parens (docExpr rhs)
    CmdArrApp lhs HsHigherOrderApp rhs -> "CmdArrApp" <+> parens (docExpr lhs) <+> "HsHigherOrderApp" <+> parens (docExpr rhs)
    CmdInfix l op r -> "CmdInfix" <+> parens (docCmd l) <+> docName op <+> parens (docCmd r)
    CmdDo stmts -> "CmdDo" <+> brackets (hsep (punctuate comma (map docCmdStmt stmts)))
    CmdIf cond yes no -> "CmdIf" <+> parens (docExpr cond) <+> parens (docCmd yes) <+> parens (docCmd no)
    CmdCase scrut alts -> "CmdCase" <+> parens (docExpr scrut) <+> brackets (hsep (punctuate comma (map docCmdCaseAlt alts)))
    CmdLet decls body -> "CmdLet" <+> brackets (hsep (punctuate comma (map docDecl decls))) <+> parens (docCmd body)
    CmdLam pats body -> "CmdLam" <+> brackets (hsep (punctuate comma (map docPattern pats))) <+> parens (docCmd body)
    CmdApp c e -> "CmdApp" <+> parens (docCmd c) <+> parens (docExpr e)
    CmdPar c -> "CmdPar" <+> parens (docCmd c)

docCmdStmt :: DoStmt Cmd -> Doc ann
docCmdStmt stmt =
  case stmt of
    DoAnn _ inner -> docCmdStmt inner
    DoBind pat cmd' -> "DoBind" <+> parens (docPattern pat) <+> parens (docCmd cmd')
    DoLetDecls decls -> "DoLetDecls" <+> brackets (hsep (punctuate comma (map docDecl decls)))
    DoExpr cmd' -> "DoExpr" <+> parens (docCmd cmd')
    DoRecStmt stmts -> "DoRecStmt" <+> brackets (hsep (punctuate comma (map docCmdStmt stmts)))

docCmdCaseAlt :: CaseAlt Cmd -> Doc ann
docCmdCaseAlt = docCaseAltWith docCmd

docArithSeq :: ArithSeq -> Doc ann
docArithSeq seqInfo =
  case seqInfo of
    ArithSeqAnn _ inner -> docArithSeq inner
    ArithSeqFrom from -> "ArithSeqFrom" <+> parens (docExpr from)
    ArithSeqFromThen from thn -> "ArithSeqFromThen" <+> parens (docExpr from) <+> parens (docExpr thn)
    ArithSeqFromTo from to -> "ArithSeqFromTo" <+> parens (docExpr from) <+> parens (docExpr to)
    ArithSeqFromThenTo from thn to -> "ArithSeqFromThenTo" <+> parens (docExpr from) <+> parens (docExpr thn) <+> parens (docExpr to)

-- Token pretty printing

docToken :: LexToken -> Doc ann
docToken tok = docTokenKind (lexTokenKind tok)

docTokenKind :: LexTokenKind -> Doc ann
docTokenKind kind =
  case kind of
    TkKeywordCase -> "TkKeywordCase"
    TkKeywordClass -> "TkKeywordClass"
    TkKeywordData -> "TkKeywordData"
    TkKeywordDefault -> "TkKeywordDefault"
    TkKeywordDeriving -> "TkKeywordDeriving"
    TkKeywordDo -> "TkKeywordDo"
    TkKeywordElse -> "TkKeywordElse"
    TkKeywordForall -> "TkKeywordForall"
    TkKeywordForeign -> "TkKeywordForeign"
    TkKeywordIf -> "TkKeywordIf"
    TkKeywordImport -> "TkKeywordImport"
    TkKeywordIn -> "TkKeywordIn"
    TkKeywordInfix -> "TkKeywordInfix"
    TkKeywordInfixl -> "TkKeywordInfixl"
    TkKeywordInfixr -> "TkKeywordInfixr"
    TkKeywordInstance -> "TkKeywordInstance"
    TkKeywordLet -> "TkKeywordLet"
    TkKeywordModule -> "TkKeywordModule"
    TkKeywordNewtype -> "TkKeywordNewtype"
    TkKeywordOf -> "TkKeywordOf"
    TkKeywordThen -> "TkKeywordThen"
    TkKeywordType -> "TkKeywordType"
    TkKeywordWhere -> "TkKeywordWhere"
    TkKeywordUnderscore -> "TkKeywordUnderscore"
    TkKeywordProc -> "TkKeywordProc"
    TkKeywordPattern -> "TkKeywordPattern"
    TkKeywordRec -> "TkKeywordRec"
    TkKeywordMdo -> "TkKeywordMdo"
    TkKeywordBy -> "TkKeywordBy"
    TkKeywordUsing -> "TkKeywordUsing"
    TkQualifiedDo modName -> "TkQualifiedDo" <+> docText modName
    TkQualifiedMdo modName -> "TkQualifiedMdo" <+> docText modName
    TkPrefixPercent -> "TkPrefixPercent"
    TkLinearArrow -> "TkLinearArrow"
    TkArrowTail -> "TkArrowTail"
    TkArrowTailReverse -> "TkArrowTailReverse"
    TkDoubleArrowTail -> "TkDoubleArrowTail"
    TkDoubleArrowTailReverse -> "TkDoubleArrowTailReverse"
    TkBananaOpen -> "TkBananaOpen"
    TkBananaClose -> "TkBananaClose"
    TkReservedDotDot -> "TkReservedDotDot"
    TkReservedColon -> "TkReservedColon"
    TkReservedDoubleColon -> "TkReservedDoubleColon"
    TkReservedEquals -> "TkReservedEquals"
    TkReservedBackslash -> "TkReservedBackslash"
    TkReservedPipe -> "TkReservedPipe"
    TkReservedLeftArrow -> "TkReservedLeftArrow"
    TkReservedRightArrow -> "TkReservedRightArrow"
    TkReservedAt -> "TkReservedAt"
    TkReservedDoubleArrow -> "TkReservedDoubleArrow"
    TkTypeApp -> "TkTypeApp"
    TkVarId name -> "TkVarId" <+> docText name
    TkConId name -> "TkConId" <+> docText name
    TkQVarId modName name -> "TkQVarId" <+> docText modName <+> docText name
    TkQConId modName name -> "TkQConId" <+> docText modName <+> docText name
    TkImplicitParam name -> "TkImplicitParam" <+> docText name
    TkVarSym name -> "TkVarSym" <+> docText name
    TkConSym name -> "TkConSym" <+> docText name
    TkQVarSym modName name -> "TkQVarSym" <+> docText modName <+> docText name
    TkQConSym modName name -> "TkQConSym" <+> docText modName <+> docText name
    TkInteger n nt -> "TkInteger" <+> pretty n <+> docNumericType nt
    TkFloat n ft -> "TkFloat" <+> pretty (show n) <+> docFloatType ft
    TkChar c -> "TkChar" <+> pretty (show c)
    TkCharHash c repr -> "TkCharHash" <+> pretty (show c) <+> docText repr
    TkString s -> "TkString" <+> docText s
    TkStringHash s repr -> "TkStringHash" <+> docText s <+> docText repr
    TkOverloadedLabel label raw -> "TkOverloadedLabel" <+> docText label <+> docText raw
    TkSpecialLParen -> "TkSpecialLParen"
    TkSpecialRParen -> "TkSpecialRParen"
    TkSpecialUnboxedLParen -> "TkSpecialUnboxedLParen"
    TkSpecialUnboxedRParen -> "TkSpecialUnboxedRParen"
    TkSpecialComma -> "TkSpecialComma"
    TkSpecialSemicolon -> "TkSpecialSemicolon"
    TkSpecialLBracket -> "TkSpecialLBracket"
    TkSpecialRBracket -> "TkSpecialRBracket"
    TkSpecialBacktick -> "TkSpecialBacktick"
    TkSpecialLBrace -> "TkSpecialLBrace"
    TkSpecialRBrace -> "TkSpecialRBrace"
    TkMinusOperator -> "TkMinusOperator"
    TkPrefixMinus -> "TkPrefixMinus"
    TkPrefixBang -> "TkPrefixBang"
    TkPrefixTilde -> "TkPrefixTilde"
    TkRecordDot -> "TkRecordDot"
    TkPragma pragma' -> "TkPragma" <+> docPragmaType (pragmaType pragma')
    TkQuasiQuote quoter body -> "TkQuasiQuote" <+> docText quoter <+> docText body
    TkLineComment -> "TkLineComment"
    TkBlockComment -> "TkBlockComment"
    TkTHExpQuoteOpen -> "TkTHExpQuoteOpen"
    TkTHExpQuoteClose -> "TkTHExpQuoteClose"
    TkTHTypedQuoteOpen -> "TkTHTypedQuoteOpen"
    TkTHTypedQuoteClose -> "TkTHTypedQuoteClose"
    TkTHDeclQuoteOpen -> "TkTHDeclQuoteOpen"
    TkTHTypeQuoteOpen -> "TkTHTypeQuoteOpen"
    TkTHPatQuoteOpen -> "TkTHPatQuoteOpen"
    TkTHQuoteTick -> "TkTHQuoteTick"
    TkTHTypeQuoteTick -> "TkTHTypeQuoteTick"
    TkTHSplice -> "TkTHSplice"
    TkTHTypedSplice -> "TkTHTypedSplice"
    TkError msg -> "TkError" <+> docText msg
    TkEOF -> "TkEOF"

docTypeSyntaxForm :: TypeSyntaxForm -> Doc ann
docTypeSyntaxForm form =
  case form of
    TypeSyntaxExplicitNamespace -> "TypeSyntaxExplicitNamespace"
    TypeSyntaxInTerm -> "TypeSyntaxInTerm"

docNumericType :: NumericType -> Doc ann
docNumericType nt =
  case nt of
    TInteger -> "TInteger"
    TIntHash -> "TIntHash"
    TWordHash -> "TWordHash"
    TInt8Hash -> "TInt8Hash"
    TInt16Hash -> "TInt16Hash"
    TInt32Hash -> "TInt32Hash"
    TInt64Hash -> "TInt64Hash"
    TWord8Hash -> "TWord8Hash"
    TWord16Hash -> "TWord16Hash"
    TWord32Hash -> "TWord32Hash"
    TWord64Hash -> "TWord64Hash"

docFloatType :: FloatType -> Doc ann
docFloatType ft =
  case ft of
    TFractional -> "TFractional"
    TFloatHash -> "TFloatHash"
    TDoubleHash -> "TDoubleHash"

optionalField :: (a -> Doc ann) -> Maybe a -> [Doc ann]
optionalField f mVal =
  case mVal of
    Just val -> [f val]
    Nothing -> []

optionalField' :: (a -> Doc ann) -> Maybe a -> Doc ann
optionalField' f mVal =
  case mVal of
    Just val -> " " <> f val
    Nothing -> ""

listField :: (a -> Doc ann) -> [a] -> [Doc ann]
listField _ [] = []
listField f xs = [brackets (hsep (punctuate comma (map f xs)))]

boolField :: Bool -> [Doc ann]
boolField False = []
boolField True = ["True"]

docText :: Text -> Doc ann
docText = pretty . show

docName :: Name -> Doc ann
docName name =
  case nameQualifier name of
    Nothing -> docText (nameText name)
    Just qualifier -> docText qualifier <+> docText (nameText name)

docUnqualifiedName :: UnqualifiedName -> Doc ann
docUnqualifiedName name =
  "UnqualifiedName" <+> braces (docText (unqualifiedNameText name))

docUnqualifiedNameText :: UnqualifiedName -> Doc ann
docUnqualifiedNameText = docText . unqualifiedNameText

docTextList :: [Text] -> Doc ann
docTextList ts = brackets (hsep (punctuate comma (map docText ts)))

docTypeFamilyDecl :: TypeFamilyDecl -> Doc ann
docTypeFamilyDecl tf =
  "TypeFamilyDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [ docTypeHeadForm (typeFamilyDeclHeadForm tf),
        if typeFamilyDeclExplicitFamilyKeyword tf then "True" else "False",
        docType (typeFamilyDeclHead tf)
      ]
        <> listField docTyVarBinder (typeFamilyDeclParams tf)
        <> optionalField docTypeFamilyResultSig (typeFamilyDeclResultSig tf)
        <> case typeFamilyDeclEquations tf of
          Nothing -> []
          Just eqs -> [brackets (hsep (punctuate comma (map docTypeFamilyEq eqs)))]

docTypeFamilyEq :: TypeFamilyEq -> Doc ann
docTypeFamilyEq eq =
  "TypeFamilyEq" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      listField docTyVarBinder (typeFamilyEqForall eq)
        <> [docTypeHeadForm (typeFamilyEqHeadForm eq), docType (typeFamilyEqLhs eq), docType (typeFamilyEqRhs eq)]

docDataFamilyDecl :: DataFamilyDecl -> Doc ann
docDataFamilyDecl df =
  "DataFamilyDecl" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      [docBinderHeadValue (dataFamilyDeclHead df)]
        <> optionalField docType (dataFamilyDeclKind df)

docBinderHead :: BinderHead UnqualifiedName -> [Doc ann]
docBinderHead head' =
  [docBinderHeadValue head']

docBinderHeadValue :: BinderHead UnqualifiedName -> Doc ann
docBinderHeadValue head' =
  case head' of
    PrefixBinderHead name params ->
      "Prefix" <+> hsep (docPrefixBinderHeadFields name params)
    InfixBinderHead lhs name rhs params ->
      "Infix" <+> hsep (docInfixBinderHeadFields lhs name rhs params)

docPrefixBinderHeadFields :: UnqualifiedName -> [TyVarBinder] -> [Doc ann]
docPrefixBinderHeadFields name params =
  docUnqualifiedNameText name : docBinderHeadParams params

docInfixBinderHeadFields :: TyVarBinder -> UnqualifiedName -> TyVarBinder -> [TyVarBinder] -> [Doc ann]
docInfixBinderHeadFields lhs name rhs params =
  [docTyVarBinderShort lhs, docUnqualifiedNameText name, docTyVarBinderShort rhs] <> docBinderHeadParams params

docBinderHeadParams :: [TyVarBinder] -> [Doc ann]
docBinderHeadParams [] = []
docBinderHeadParams params = [brackets (hsep (punctuate comma (map docTyVarBinder params)))]

docTyVarBinderShort :: TyVarBinder -> Doc ann
docTyVarBinderShort tvb
  | Nothing <- tyVarBinderKind tvb,
    TyVarBSpecified <- tyVarBinderSpecificity tvb,
    TyVarBVisible <- tyVarBinderVisibility tvb =
      docText (tyVarBinderName tvb)
  | otherwise = parens (docTyVarBinder tvb)

docTypeFamilyInst :: TypeFamilyInst -> Doc ann
docTypeFamilyInst tfi =
  "TypeFamilyInst" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      listField docTyVarBinder (typeFamilyInstForall tfi)
        <> [docTypeHeadForm (typeFamilyInstHeadForm tfi), docType (typeFamilyInstLhs tfi), docType (typeFamilyInstRhs tfi)]

docTypeHeadForm :: TypeHeadForm -> Doc ann
docTypeHeadForm headForm =
  case headForm of
    TypeHeadPrefix -> "TypeHeadPrefix"
    TypeHeadInfix -> "TypeHeadInfix"

docDataFamilyInst :: DataFamilyInst -> Doc ann
docDataFamilyInst dfi =
  "DataFamilyInst" <+> braces (hsep (punctuate comma fields))
  where
    fields =
      boolField (dataFamilyInstIsNewtype dfi)
        <> listField docTyVarBinder (dataFamilyInstForall dfi)
        <> [docType (dataFamilyInstHead dfi)]
        <> optionalField docType (dataFamilyInstKind dfi)
        <> listField docDataConDecl (dataFamilyInstConstructors dfi)
        <> listField docDerivingClause (dataFamilyInstDeriving dfi)