content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE DefaultSignatures #-}
  {-# LANGUAGE TypeSynonymInstances #-}
  {-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
  {-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}
  {-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Copyright   :  (c) Edward Kmett 2018, (c) Stephen Diehl 2014-2017, (c) Cedric Shoc 2015
  -- License     :  BSD-2-Clause OR Apache-2.0
  -- Maintainer  :  ekmett@gmail.com
  -- Stability   :  experimental
  -- Portability :  portable
  --
  -----------------------------------------------------------------------------
  
  module Console.Pretty.LLVM (
    PP(..),
    ppll,
    ppll_
  ) where
  
  
  import Control.Monad (guard)
  import Control.Monad.IO.Class
  import Control.Monad.ST
  import Data.Array.MArray hiding (index)
  import Data.Array.ST hiding (index)
  import Data.Array.Unsafe
  import qualified Data.ByteString.Char8 as BL
  import Data.ByteString.Lazy (fromStrict)
  import qualified Data.ByteString.Short as BS
  import qualified Data.ByteString.Short as SBF
  import Data.Char (chr, ord, isAscii, isControl, isLetter, isDigit)
  import Data.Default.Class
  import Data.Foldable (toList)
  import Data.List (intersperse)
  import Data.Maybe (isJust)
  import Data.String
  import Data.Text.Lazy (Text, pack)
  import Data.Text.Lazy.Encoding
  import Data.Text.Prettyprint.Doc
  import Data.Text.Prettyprint.Doc.Render.Terminal as RenderTerminal
  import GHC.Word
  import LLVM.AST
  import qualified LLVM.AST.AddrSpace as AS
  import LLVM.AST.Attribute
  import qualified LLVM.AST.CallingConvention as CC
  import LLVM.AST.COMDAT
  import qualified LLVM.AST.Constant as C
  import LLVM.AST.DataLayout
  import qualified LLVM.AST.Float as F
  import qualified LLVM.AST.FloatingPointPredicate as FP
  import LLVM.AST.FunctionAttribute as FA
  import LLVM.AST.Global
  import qualified LLVM.AST.IntegerPredicate as IP
  import qualified LLVM.AST.Linkage as L
  import LLVM.AST.ParameterAttribute as PA
  import qualified LLVM.AST.RMWOperation as RMW
  -- import LLVM.AST.Type
  import LLVM.AST.Typed
  -- import qualified LLVM.AST.Visibility as V
  import LLVM.DataLayout
  import Numeric (showHex)
  import Prelude hiding ((<$>))
  import Text.Printf
  
  import Console.Pretty
  
  -------------------------------------------------------------------------------
  -- Utils
  -------------------------------------------------------------------------------
  
  -- parensIf ::  Bool -> Doc a -> Doc a
  -- parensIf True = parens
  -- parensIf False = id
  
  commas :: [Doc a] -> Doc a
  commas  = hsep . punctuate (pretty ',')
  
  -- colons :: [Doc a] -> Doc a
  -- colons  = hcat . intersperse (pretty ':')
  
  hlinecat :: [Doc a] -> Doc a
  hlinecat = vcat . intersperse softline
  
  wrapbraces :: Doc a -> Doc a -> Doc a
  wrapbraces leadIn x = (leadIn <+> pretty '{') <$> x <$> pretty '}'
  
  (<$>) :: Doc a -> Doc a -> Doc a
  x <$> y = x <> line <> y
  
  angleBrackets :: Doc a -> Doc a
  angleBrackets x = pretty '<' <> x <> pretty '>'
  
  spacedbraces :: Doc a -> Doc a
  spacedbraces x = pretty '{' <+> x <+> pretty '}'
  
  local :: Ann a => Doc a -> Doc a
  local a = annotate annIdentifier $ "%" <> a
  
  global :: Ann a => Doc a -> Doc a
  global a = annotate annIdentifier $ "@" <> a
  
  label :: Ann a => Doc a -> Doc a
  label a = annotate annType "label" <+> annotate annIdentifier ("%" <> a)
  
  cma :: Doc a -> Doc a -> Doc a -- <,> does not work :(
  a `cma` b = a <> "," <+> b
  
  -------------------------------------------------------------------------------
  -- Classes
  -------------------------------------------------------------------------------
  
  class Ann a where
    annIdentifier, annType, annStmt, annKeyword, annComment, annString :: a
  
  instance Ann () where
    annIdentifier = ()
    annType = ()
    annStmt = ()
    annKeyword = ()
    annComment = ()
    annString = ()
  
  instance Ann AnsiStyle where
    annIdentifier = color Green
    annType = color Blue
    annStmt = colorDull Yellow
    annKeyword = underlined
    annComment = color Magenta
    annString = color Cyan
  
  astmt :: Ann a => Doc a -> Doc a
  astmt = annotate annStmt
  
  atype :: Ann a => Doc a -> Doc a
  atype = annotate annType
  
  akw :: Ann a => Doc a -> Doc a
  akw = annotate annKeyword
  
  acomment :: Ann a => Doc a -> Doc a
  acomment = annotate annComment
  
  dquoted :: Ann a => Doc a -> Doc a
  dquoted = annotate annString . dquotes
  
  class PP p where
    pp :: Ann a => p -> Doc a
    default pp :: Pretty p => p -> Doc a
    pp = pretty
  
  ppMaybe :: (PP a, Ann b) => Maybe a -> Doc b
  ppMaybe (Just x) = pp x
  ppMaybe Nothing = mempty
  
  ppBool :: Doc a -> Bool -> Doc a
  ppBool x True = x
  ppBool _ False = mempty
  
  -- XXX: horrible hack
  unShort :: BS.ShortByteString -> [Char]
  unShort xs = fmap (toEnum . fromIntegral) $ BS.unpack xs
  
  short :: Ann a => BS.ShortByteString -> Doc a
  short x = pretty (unShort x)
  
  decodeShortUtf8 :: SBF.ShortByteString -> Text
  decodeShortUtf8 = decodeUtf8 . fromStrict . SBF.fromShort
  
  instance PP Word32
  
  instance PP Word64
  
  instance PP Integer where
  
  instance PP BS.ShortByteString where
    pp = pp . unShort
  
  instance PP [Char]
  
  instance PP Name where
    pp (Name nm)
     | BS.null nm = dquoted mempty
      | isFirst first && all isRest name = pretty (pack name)
      | otherwise = dquoted . hcat . map escape $ name
      where
          name = unShort nm
          first = head name
          isFirst c = isLetter c || c == '-' || c == '_' || c == '$' || c == '.'
          isRest c = isDigit c || isFirst c
    pp (UnName x) = pretty x
  
  instance PP Parameter where
    pp (Parameter ty (UnName _) attrs) = hsep (pp ty : fmap pp attrs)
    pp (Parameter ty name attrs) = hsep (pp ty : fmap pp attrs) <+> local (pp name)
  
  instance PP [ParameterAttribute] where
    pp x = hsep $ fmap pp x
  
  instance PP ([Parameter], Bool) where
    pp (params, False) = commas (fmap pp params)
    pp (_params, True) = "TODO" -- XXX: variadic case
  
  instance PP (Operand, [ParameterAttribute]) where
    pp (op, attrs) = pp (typeOf op) <+> pp attrs <+> pp op
  
  instance PP UnnamedAddr where
    pp LocalAddr = "local_unnamed_addr"
    pp GlobalAddr = "unnamed_addr"
  
  instance PP Type where
    pp (IntegerType w) = atype $ "i" <> pp w
    pp (FloatingPointType HalfFP)      = atype "half"
    pp (FloatingPointType FloatFP )    = atype "float"
    pp (FloatingPointType DoubleFP)    = atype "double"
    pp (FloatingPointType FP128FP)     = atype "fp128"
    pp (FloatingPointType X86_FP80FP)  = atype "x86_fp80"
    pp (FloatingPointType PPC_FP128FP) = atype "ppc_fp128"
  
    pp VoidType = atype "void"
    pp (PointerType ref (AS.AddrSpace addr))
      | addr == 0 = atype $ pp ref <> "*"
      | otherwise = atype $ pp ref <+> akw "addrspace" <> parens (pp addr) <> "*"
    pp ft@(FunctionType {..}) = atype $ pp resultType <+> ppFunctionArgumentTypes ft
    pp (VectorType {..}) = atype $ "<" <> pp nVectorElements <+> "x" <+> pp elementType <> ">"
    pp (StructureType {..}) = atype $ if isPacked
                                 then "<{" <> (commas $ fmap pp elementTypes ) <> "}>"
                                 else  "{" <> (commas $ fmap pp elementTypes ) <> "}"
    pp (ArrayType {..}) = atype $ brackets $ pp nArrayElements <+> "x" <+> pp elementType
    pp (NamedTypeReference name) = atype ("%" <> pp name)
    pp MetadataType = atype "metadata"
    pp TokenType = atype "token"
    pp LabelType = atype "label"
  
  instance PP Global where
    pp Function {..} =
        case basicBlocks of
          [] -> sep
             $ pre "declare"
            ++ [pp returnType, global (pp name) <> ppParams (pp . typeOf) parameters]
            ++ post
          -- single unnamed block is special cased, and won't parse otherwise... yeah good times
          [b@(BasicBlock (UnName _) _ _)] -> sep (
               pre "define"
            ++ [pp returnType, global (pp name) <> ppParams pp parameters]
            ++ post
            ) `wrapbraces` (indent 2 $ ppSingleBlock b)
          bs -> sep (
               pre "define"
            ++ [pp returnType, global (pp name) <> ppParams pp parameters]
            ++ post
            ) `wrapbraces` (vcat $ fmap pp bs)
      where
        pre kw = akw kw : pp linkage : pp callingConvention : fmap pp returnAttributes
        post = fmap pp functionAttributes ++ align' ++ gcName ++ foldMap (\con -> [ akw "prefix", ppTyped con ]) prefix
        align' = guard (alignment /= 0) *> [akw "align", pp alignment]
        gcName = foldMap (\n -> [akw "gc", dquoted (pretty $ unShort n)]) garbageCollectorName
  
    pp GlobalVariable {..} = global (pp name) <+> "=" <+> ppLinkage hasInitializer linkage <+> ppMaybe unnamedAddr
                               <+> addrSpace' <+> kind <+> pp type' <+> ppMaybe initializer <> ppAlign alignment
      where
        hasInitializer = isJust initializer
        addrSpace' =
          case addrSpace of
            AS.AddrSpace addr
              | addr == 0 -> mempty
              | otherwise -> akw "addrspace" <> parens (pp addr)
        kind | isConstant = akw "constant"
             | otherwise  = akw "global"
  
    pp GlobalAlias {..} = global (pp name) <+> "=" <+> pp linkage <+> ppMaybe unnamedAddr <+> "alias" <+> pp typ `cma` ppTyped aliasee
      where
        typ = getElementType type'
  
  ppMetadata :: Ann a => Maybe Metadata -> Doc a
  ppMetadata Nothing = "null"
  ppMetadata (Just m) = pp m
  
  instance PP Definition where
    pp (GlobalDefinition x) = pp x
    pp (TypeDefinition nm ty) = local (pp nm) <+> "=" <+> "type" <+> maybe "opaque" pp ty
    pp (FunctionAttributes gid attrs) = "attributes" <+> pp gid <+> "=" <+> braces (hsep (fmap ppAttrInGroup attrs))
    pp (NamedMetadataDefinition nm meta) = "!" <> short nm <+> "=" <+> "!" <> braces (commas (fmap pp meta))
    pp (MetadataNodeDefinition node meta) = pp node <+> "=" <+> "!" <> braces (commas (fmap ppMetadata meta))
    pp (ModuleInlineAssembly asm) = akw "module" <+> akw "asm" <+> dquoted (pretty (pack (BL.unpack asm)))
    pp (COMDAT name selKind) = "$" <> short name <+> "=" <+> "comdat" <+> pp selKind
  
  instance PP SelectionKind where
    pp Any = "any"
    pp ExactMatch = "exactmatch"
    pp Largest = "largest"
    pp NoDuplicates = "noduplicates"
    pp SameSize = "samesize"
  
  ppAttrInGroup :: Ann a => FunctionAttribute -> Doc a
  ppAttrInGroup = \case
    StackAlignment n -> "alignstack=" <> pp n
    attr -> pp attr
  
  instance PP FunctionAttribute where
    pp = \case
     NoReturn            -> akw "noreturn"
     NoUnwind            -> akw "nounwind"
     FA.ReadNone         -> akw "readnone"
     FA.ReadOnly         -> akw "readonly"
     FA.WriteOnly        -> akw "writeonly"
     NoInline            -> akw "noinline"
     AlwaysInline        -> akw "alwaysinline"
     MinimizeSize        -> akw "minsize"
     OptimizeForSize     -> akw "optsize"
     OptimizeNone        -> akw "optnone"
     SafeStack           -> akw "safestack"
     StackProtect        -> akw "ssp"
     StackProtectReq     -> akw "sspreq"
     StackProtectStrong  -> akw "sspstrong"
     NoRedZone           -> akw "noredzone"
     NoImplicitFloat     -> akw "noimplicitfloat"
     Naked               -> akw "naked"
     InlineHint          -> akw "inlinehint"
     StackAlignment n    -> akw "alignstack" <> parens (pp n)
     ReturnsTwice        -> akw "returns_twice"
     UWTable             -> akw "uwtable"
     NonLazyBind         -> akw "nonlazybind"
     Builtin             -> akw "builtin"
     NoBuiltin           -> akw "nobuiltin"
     Cold                -> akw "cold"
     JumpTable           -> akw "jumptable"
     NoDuplicate         -> akw "noduplicate"
     SanitizeAddress     -> akw "sanitize_address"
     SanitizeThread      -> akw "sanitize_thread"
     SanitizeMemory      -> akw "sanitize_memory"
     NoRecurse           -> akw "norecurse"
     Convergent          -> akw "convergent"
     ArgMemOnly          -> akw "argmemonly"
     InaccessibleMemOnly -> akw "inaccessiblememonly"
     AllocSize a Nothing -> akw "allocsize" <> parens (pp a)
     AllocSize a (Just b) -> akw "allocsize" <> parens (commas [pp a, pp b])
     InaccessibleMemOrArgMemOnly -> akw "inaccessiblemem_or_argmemonly"
     FA.StringAttribute k v -> dquoted (short k) <> "=" <> dquoted (short v)
     Speculatable        -> akw "speculatable"
  
  instance PP ParameterAttribute where
    pp = \case
      ZeroExt                    -> akw "zeroext"
      SignExt                    -> akw "signext"
      InReg                      -> akw "inreg"
      SRet                       -> akw "sret"
      Alignment word             -> akw "align" <+> pp word
      NoAlias                    -> akw "noalias"
      ByVal                      -> akw "byval"
      NoCapture                  -> akw "nocapture"
      Nest                       -> akw "nest"
      PA.ReadNone                -> akw "readnone"
      PA.ReadOnly                -> akw "readonly"
      PA.WriteOnly               -> akw "writeonly"
      InAlloca                   -> akw "inalloca"
      NonNull                    -> akw "nonnull"
      Dereferenceable word       -> akw "dereferenceable" <> parens (pp word)
      DereferenceableOrNull word -> akw "dereferenceable_or_null" <> parens (pp word)
      Returned                   -> akw "returned"
      SwiftSelf                  -> akw "swiftself"
      SwiftError                 -> akw "swifterror"
      PA.StringAttribute k v -> dquoted (short k) <> "=" <> dquoted (short v)
  
  instance PP CC.CallingConvention where
   pp = \case
     CC.Numbered word -> cc word
     CC.C             -> akw "ccc"
     CC.Fast          -> akw "fastcc"
     CC.Cold          -> akw "coldcc"
     CC.GHC           -> cc 10
     CC.HiPE          -> cc 11
     CC.WebKit_JS     -> akw "webkit_jscc"
     CC.AnyReg        -> akw "anyregcc"
     CC.PreserveMost  -> akw "preserve_mostcc"
     CC.PreserveAll   -> akw "preserve_allcc"
     CC.Swift         -> akw "swiftcc"
     CC.CXX_FastTLS   -> akw "cxx_fast_tlscc"
     CC.X86_StdCall   -> cc 64
     CC.X86_FastCall  -> cc 65
     CC.ARM_APCS      -> cc 66
     CC.ARM_AAPCS     -> cc 67
     CC.ARM_AAPCS_VFP -> cc 68
     CC.MSP430_INTR   -> cc 69
     CC.X86_ThisCall  -> cc 70
     CC.PTX_Kernel    -> cc 71
     CC.PTX_Device    -> cc 72
     CC.SPIR_FUNC     -> cc 75
     CC.SPIR_KERNEL   -> cc 76
     CC.Intel_OCL_BI  -> cc 77
     CC.X86_64_SysV   -> cc 78
     CC.Win64         -> cc 79
     CC.X86_Intr      -> akw "x86_intrcc"
     CC.X86_RegCall   -> akw "x86_regcallcc"
     CC.X86_VectorCall -> akw "x86_vectorcallcc"
     CC.AVR_Intr      -> akw "avr_intrcc"
     CC.AVR_Signal    -> akw "avr_signalcc"
     CC.AVR_Builtin   -> cc 86
     CC.HHVM          -> akw "hhvmcc"
     CC.HHVM_C        -> akw "hhvm_ccc"
     CC.AMDGPU_VS     -> akw "amdgpu_vs"
     CC.AMDGPU_GS     -> akw "amdgpu_gs"
     CC.AMDGPU_PS     -> akw "amdgpu_ps"
     CC.AMDGPU_CS     -> akw "amdgpu_cs"
     CC.AMDGPU_HS     -> akw "amdgpu_hs"
     CC.AMDGPU_Kernel -> akw "amdgpu_kernel"
     CC.MSP430_Builtin -> akw "msp430"
    where
      cc :: Ann a => Word32 -> Doc a
      cc n = akw "cc" <+> pp n
  
  instance PP L.Linkage where
      pp = ppLinkage False
  
  ppLinkage :: Ann a => Bool -> L.Linkage -> Doc a
  ppLinkage omitExternal = \case
     L.External | omitExternal -> mempty
                | otherwise    -> akw "external"
     L.Private                 -> akw "private"
     L.Internal                -> akw "internal"
     L.ExternWeak              -> akw "extern_weak"
     L.AvailableExternally     -> akw "available_externally"
     L.LinkOnce                -> akw "linkonce"
     L.Weak                    -> akw "weak"
     L.Common                  -> akw "common"
     L.Appending               -> akw "appending"
     L.LinkOnceODR             -> akw "linkonce_odr"
     L.WeakODR                 -> akw "weak_odr"
  
  instance PP InstructionMetadata where
    pp meta = commas ["!" <> pp x <> "!" <> ("{" <> pp y <> "}") | (x,y) <- meta]
  
  instance PP MetadataNodeID where
    pp (MetadataNodeID x) = "!" <> pretty x
  
  instance PP GroupID where
    pp (GroupID x) = "#" <> pretty x
  
  instance PP BasicBlock where
    pp (BasicBlock nm instrs term) =
      lbl <$> indent 2 (vcat $ (fmap pp instrs) ++ [pp term])
      where
        lbl = case nm of
          UnName _ -> acomment $ "; <label>:" <> pp nm <> ":"
          _ -> pp nm <> ":"
  
  instance PP Terminator where
    pp = \case
      Br dest meta -> astmt "br" <+> label (pp dest) <+> ppInstrMeta meta
  
      Ret val meta -> astmt "ret" <+> maybe "void" ppTyped val <+> ppInstrMeta meta
  
      CondBr cond tdest fdest meta ->
       astmt "br" <+> ppTyped cond
       `cma` label (pp tdest)
       `cma` label (pp fdest)
       <+> ppInstrMeta meta
  
      Switch {..} -> astmt "switch" <+> ppTyped operand0'
                   `cma` label (pp defaultDest)
                   <+> brackets (hsep [ ppTyped v `cma` label (pp l) | (v,l) <- dests ])
                   <+> ppInstrMeta metadata'
  
      Unreachable {..} -> astmt "unreachable" <+> ppInstrMeta metadata'
  
      IndirectBr op dests meta -> astmt "indirectbr" <+> ppTyped op `cma`
       brackets (hsep [ label (pp l) | l <- dests ])
       <+> ppInstrMeta meta
  
      e @ Invoke {..} ->
       ppInvoke e
       <+> "to" <+> label (pp returnDest)
       <+> "unwind" <+> label (pp exceptionDest)
       <+> ppInstrMeta metadata'
  
      Resume op meta -> astmt "resume "<+> ppTyped op <+> ppInstrMeta meta
  
      CleanupRet pad dest meta ->
        astmt "cleanupret" <+> "from" <+> pp pad <+> "unwind" <+> maybe "to caller" (label . pp) dest
        <+> ppInstrMeta meta
  
      CatchRet catchPad s meta ->
        astmt "catchret" <+> "from" <+> pp catchPad <+> "to" <+> label (pp s)
        <+> ppInstrMeta meta
  
      CatchSwitch {..} ->
        astmt "catchswitch" <+> "within" <+> pp parentPad' <+>
        brackets (commas (map (label . pp) (toList catchHandlers))) <+>
        "unwind" <+> "to" <+> maybe "caller" pp defaultUnwindDest
        <+> ppInstrMeta metadata'
  
  instance PP Instruction where
    pp = \case
      Add {..}    -> astmt "add"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      Sub {..}    -> astmt "sub"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      Mul {..}    -> astmt "mul"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      Shl {..}    -> astmt "shl"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      AShr {..}   -> astmt "ashr" <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      LShr {..}   -> astmt "lshr" <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      And {..}    -> astmt "and"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      Or {..}     -> astmt "or"   <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      Xor {..}    -> astmt "xor"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      SDiv {..}   -> astmt "sdiv"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      UDiv {..}   -> astmt "udiv"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      SRem {..}   -> astmt "srem"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      URem {..}   -> astmt "urem"  <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
  
      FAdd {..}   -> astmt "fadd" <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      FSub {..}   -> astmt "fsub" <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      FMul {..}   -> astmt "fmul" <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      FDiv {..}   -> astmt "fdiv" <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      FRem {..}   -> astmt "frem" <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
      FCmp {..}   -> astmt "fcmp" <+> pp fpPredicate <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
  
      Alloca {..} -> astmt "alloca" <+> pp allocatedType <> num <> ppAlign alignment <+> ppInstrMeta metadata
        where num   = case numElements of Nothing -> mempty
                                          Just o -> "," <+> ppTyped o
      Store {..}  -> astmt "store" <+> ppTyped value `cma` ppTyped address <> ppAlign alignment
      Load {..}   -> astmt "load" <+> pp argTy `cma` ppTyped address <> ppAlign alignment <+> ppInstrMeta metadata
        where PointerType argTy _ = typeOf address
      Phi {..}    -> astmt "phi" <+> pp type' <+> commas (fmap phiIncoming incomingValues) <+> ppInstrMeta metadata
  
      ICmp {..}   -> astmt "icmp" <+> pp iPredicate <+> ppTyped operand0 `cma` pp operand1 <+> ppInstrMeta metadata
  
      c@Call {..} -> ppCall c  <+> ppInstrMeta metadata
      Select {..} -> astmt "select" <+> commas [ppTyped condition', ppTyped trueValue, ppTyped falseValue] <+> ppInstrMeta metadata
      SExt {..}   -> astmt "sext" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata <+> ppInstrMeta metadata
      ZExt {..}   -> astmt "zext" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata <+> ppInstrMeta metadata
      FPExt {..}   -> astmt "fpext" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata <+> ppInstrMeta metadata
      Trunc {..}  -> astmt "trunc" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata <+> ppInstrMeta metadata
      FPTrunc {..}  -> astmt "fptrunc" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata <+> ppInstrMeta metadata
  
      GetElementPtr {..} -> astmt "getelementptr" <+> bounds inBounds <+> commas (pp argTy : fmap ppTyped (address:indices)) <+> ppInstrMeta metadata
        where argTy = getElementType $ typeOf address
      ExtractValue {..} -> astmt "extractvalue" <+> commas (ppTyped aggregate : fmap pp indices') <+> ppInstrMeta metadata
  
      BitCast {..} -> astmt "bitcast" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata
      FPToUI {..} -> astmt "fptoui" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata
      FPToSI {..} -> astmt "fptosi" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata
      UIToFP {..} -> astmt "uitofp" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata
      SIToFP {..} -> astmt "sitofp" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata
      PtrToInt {..} -> astmt "ptrtoint" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata
      IntToPtr {..} -> astmt "inttoptr" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata
  
      InsertElement {..} -> astmt "insertelement" <+> commas [ppTyped vector, ppTyped element, ppTyped index] <+> ppInstrMeta metadata
      ShuffleVector {..} -> astmt "shufflevector" <+> commas [ppTyped operand0, ppTyped operand1, ppTyped mask] <+> ppInstrMeta metadata
      ExtractElement {..} -> astmt "extractelement" <+> commas [ppTyped vector, ppTyped index] <+> ppInstrMeta metadata
      InsertValue {..} -> astmt "insertvalue" <+> commas (ppTyped aggregate : ppTyped element : fmap pp indices') <+> ppInstrMeta metadata
  
      Fence {..} -> astmt "fence" <+> pp atomicity <+> ppInstrMeta metadata
      AtomicRMW {..} -> astmt "atomicrmw" <+> ppVolatile volatile <+> pp rmwOperation <+> ppTyped address `cma` ppTyped value <+> pp atomicity  <+> ppInstrMeta metadata
      CmpXchg {..} -> astmt "cmpxchg" <+> ppVolatile volatile <+> ppTyped address `cma` ppTyped expected `cma` ppTyped replacement
        <+> pp atomicity <+> pp failureMemoryOrdering <+> ppInstrMeta metadata
  
      AddrSpaceCast {..} -> astmt "addrspacecast" <+> ppTyped operand0 <+> "to" <+> pp type' <+> ppInstrMeta metadata
      VAArg {..} -> astmt "va_arg" <+> ppTyped argList `cma` pp type' <+> ppInstrMeta metadata
  
      LandingPad {..} ->
        astmt "landingpad" <+> pp type' <+> ppBool "cleanup" cleanup <+> ppInstrMeta metadata
        <+> commas (fmap pp clauses)
      CatchPad {..} -> astmt "catchpad" <+> "within" <+> pp catchSwitch <+> brackets (commas (map ppTyped args)) <+> ppInstrMeta metadata
      CleanupPad {..} -> astmt "cleanuppad" <+> "within" <+> pp parentPad <+> brackets (commas (map ppTyped args)) <+> ppInstrMeta metadata
  
      where
        bounds True = "inbounds"
        bounds False = mempty
  
  instance PP CallableOperand where
    pp (Left _asm) = error "CallableOperand"
    pp (Right op) = pp op
  
  instance PP LandingPadClause where
    pp = \case
      Catch c  -> "catch" <+> ppTyped c
      Filter c -> "filter" <+> ppTyped c
  
  instance PP [Either GroupID FunctionAttribute] where
    pp x = hsep $ fmap pp x
  
  instance PP (Either GroupID FunctionAttribute) where
    pp (Left gid) = pp gid
    pp (Right fattr) = pp fattr
  
  instance PP Operand where
    pp (LocalReference _ nm) = local (pp nm)
    pp (ConstantOperand con) = pp con
    pp (MetadataOperand mdata) = pp mdata
  
  instance PP Metadata where
    pp (MDString str) = "!" <> dquoted (pretty (decodeShortUtf8 str))
    pp (MDNode node) = pp node
    pp (MDValue operand) = pp operand
  
  instance PP MetadataNode where
    pp (MetadataNode xs) = "!" <> braces (commas (fmap ppMetadata xs))
    pp (MetadataNodeReference ref) = pp ref
  
  instance PP C.Constant where
    pp (C.Int _width val) = pp val
    pp (C.Float (F.Double val))      =
      if specialFP val
        then "0x" <> (pretty . pack) (showHex (doubleToWord val) "")
        else pretty (printf "%6.6e" val :: String)
    pp (C.Float (F.Single val))      =
      if specialFP val
        then "0x" <> (pretty . pack) (showHex (floatToWord val) "")
        else pretty (printf "%6.6e" val :: String)
    pp (C.Float (F.Half val))        = pretty (printf "%6.6e" val :: String)
    pp (C.Float (F.Quadruple val _)) = pretty (printf "%6.6e" val :: String)
    pp (C.Float (F.X86_FP80 val _))  = pretty (printf "%6.6e" val :: String)
    pp (C.Float (F.PPC_FP128 val _)) = pretty (printf "%6.6e" val :: String)
  
    pp (C.GlobalReference _ty nm) = "@" <> pp nm
    pp (C.Vector args) = "<" <+> commas (fmap ppTyped args) <+> ">"
  
    pp (C.Add {..})    = "add"  <+> ppTyped operand0 `cma` pp operand1
    pp (C.Sub {..})    = "sub"  <+> ppTyped operand0 `cma` pp operand1
    pp (C.Mul {..})    = "mul"  <+> ppTyped operand0 `cma` pp operand1
    pp (C.Shl {..})    = "shl"  <+> ppTyped operand0 `cma` pp operand1
    pp (C.AShr {..})   = "ashr" <+> ppTyped operand0 `cma` pp operand1
    pp (C.LShr {..})   = "lshr" <+> ppTyped operand0 `cma` pp operand1
    pp (C.And {..})    = "and"  <+> ppTyped operand0 `cma` pp operand1
    pp (C.Or {..})     = "or"   <+> ppTyped operand0 `cma` pp operand1
    pp (C.Xor {..})    = "xor"  <+> ppTyped operand0 `cma` pp operand1
    pp (C.SDiv {..})   = "sdiv"  <+> ppTyped operand0 `cma` pp operand1
    pp (C.UDiv {..})   = "udiv"  <+> ppTyped operand0 `cma` pp operand1
    pp (C.SRem {..})   = "srem"  <+> ppTyped operand0 `cma` pp operand1
    pp (C.URem {..})   = "urem"  <+> ppTyped operand0 `cma` pp operand1
  
    pp (C.FAdd {..})   = "fadd" <+> ppTyped operand0 `cma` pp operand1
    pp (C.FSub {..})   = "fsub" <+> ppTyped operand0 `cma` pp operand1
    pp (C.FMul {..})   = "fmul" <+> ppTyped operand0 `cma` pp operand1
    pp (C.FDiv {..})   = "fdiv" <+> ppTyped operand0 `cma` pp operand1
    pp (C.FRem {..})   = "frem" <+> ppTyped operand0 `cma` pp operand1
    pp (C.FCmp {..})   = "fcmp" <+> pp fpPredicate <+> ppTyped operand0 `cma` pp operand1
    pp C.ICmp {..}     = "icmp" <+> pp iPredicate <+> ppTyped operand0 `cma` pp operand1
  
    pp (C.Select {..})  = "select" <+> commas [ppTyped condition', ppTyped trueValue, ppTyped falseValue]
    pp (C.SExt {..})    = "sext" <+> ppTyped operand0 <+> "to" <+> pp type'
    pp (C.ZExt {..})    = "zext" <+> ppTyped operand0 <+> "to" <+> pp type'
    pp (C.FPExt {..})   = "fpext" <+> ppTyped operand0 <+> "to" <+> pp type'
    pp (C.Trunc {..})   = "trunc" <+> ppTyped operand0 <+> "to" <+> pp type'
    pp (C.FPTrunc {..}) = "fptrunc" <+> ppTyped operand0 <+> "to" <+> pp type'
  
    pp C.FPToUI {..} = "fptoui" <+> ppTyped operand0 <+> "to" <+> pp type'
    pp C.FPToSI {..} = "fptosi" <+> ppTyped operand0 <+> "to" <+> pp type'
    pp C.UIToFP {..} = "uitofp" <+> ppTyped operand0 <+> "to" <+> pp type'
    pp C.SIToFP {..} = "sitofp" <+> ppTyped operand0 <+> "to" <+> pp type'
  
    pp (C.Struct _ packed elems) =
      let struct = spacedbraces $ commas $ fmap ppTyped elems
      in if packed
           then angleBrackets struct
           else struct
  
    pp (C.Null constantType) = ppNullInitializer constantType
  
  #if MIN_VERSION_llvm_hs_pure(5,1,3)
    pp (C.AggregateZero _constantType) = "zeroinitializer"
  #endif
  
    pp (C.Undef {}) = "undef"
    pp (C.TokenNone {}) = "none"
    pp (C.BlockAddress fn blk) = "blockaddress" <> parens (commas (fmap pp [fn, blk]))
  
    pp C.Array {..}
      | memberType == (IntegerType 8) = "c" <> (dquoted $ hcat [ppIntAsChar val | C.Int _ val <- memberValues])
      | otherwise = brackets $ commas $ fmap ppTyped memberValues
  
    pp C.GetElementPtr {..} = "getelementptr" <+> bounds inBounds <+> parens (commas (pp argTy : fmap ppTyped (address:indices)))
      where
        PointerType argTy _ = typeOf address
        bounds True = "inbounds"
        bounds False = mempty
  
    pp C.BitCast {..} = "bitcast" <+> parens (ppTyped operand0 <+> "to" <+> pp type')
    pp C.PtrToInt {..} = "ptrtoint" <+> parens (ppTyped operand0 <+> "to" <+> pp type')
    pp C.IntToPtr {..} = "inttoptr" <+> parens (ppTyped operand0 <+> "to" <+> pp type')
    pp C.AddrSpaceCast {..} = "addrspacecast" <+> parens (ppTyped operand0 <+> "to" <+> pp type')
  
  instance PP a => PP (Named a) where
    pp (nm := a) = local (pp nm) <+> "=" <+> pp a
    pp (Do a) = pp a
  
  instance PP Module where
    pp Module {..} = hlinecat (header : layout ++ target ++ fmap pp moduleDefinitions) where
      header = acomment $ fromString $ printf "; ModuleID = '%s'" (unShort moduleName)
      target = foldMap (\tgt -> [ "target triple =" <+> dquoted (pp tgt)]) moduleTargetTriple
      layout = foldMap (\lyt -> [ "target datalayout =" <+> dquoted (pp lyt) ]) moduleDataLayout
  
  instance PP FP.FloatingPointPredicate where
    pp op = case op of
     FP.False -> "false"
     FP.OEQ   -> "oeq"
     FP.OGT   -> "ogt"
     FP.OGE   -> "oge"
     FP.OLT   -> "olt"
     FP.OLE   -> "ole"
     FP.ONE   -> "one"
     FP.ORD   -> "ord"
     FP.UEQ   -> "ueq"
     FP.UGT   -> "ugt"
     FP.UGE   -> "uge"
     FP.ULT   -> "ult"
     FP.ULE   -> "ule"
     FP.UNE   -> "une"
     FP.UNO   -> "uno"
     FP.True  -> "true"
  
  instance PP IP.IntegerPredicate where
    pp op = case op of
     IP.EQ  -> "eq"
     IP.NE  -> "ne"
     IP.UGT -> "ugt"
     IP.UGE -> "uge"
     IP.ULT -> "ult"
     IP.ULE -> "ule"
     IP.SGT -> "sgt"
     IP.SGE -> "sge"
     IP.SLT -> "slt"
     IP.SLE -> "sle"
  
  instance PP Atomicity where
    pp (scope, order) =
      pp scope <+> pp order
  
  instance PP SynchronizationScope where
    pp = \case
      SingleThread -> "syncscope(\"singlethread\")"
      System -> mempty
  
  instance PP MemoryOrdering where
    pp = \case
      Unordered              -> "unordered"
      Monotonic              -> "monotonic"
      Acquire                -> "acquire"
      Release                -> "release"
      AcquireRelease         -> "acq_rel"
      SequentiallyConsistent -> "seq_cst"
  
  instance PP RMW.RMWOperation where
    pp = \case
      RMW.Xchg -> "xchg"
      RMW.Add -> "add"
      RMW.Sub -> "sub"
      RMW.And -> "and"
      RMW.Nand -> "nand"
      RMW.Or -> "or"
      RMW.Xor -> "xor"
      RMW.Max -> "max"
      RMW.Min -> "min"
      RMW.UMax -> "umax"
      RMW.UMin -> "umin"
  
  instance PP DataLayout where
    pp x = pp (BL.unpack (dataLayoutToString x))
  
  -------------------------------------------------------------------------------
  -- Special Case Hacks
  -------------------------------------------------------------------------------
  
  escape :: Char -> Doc a
  escape '"'  = "\\22"
  escape '\\' = "\\\\"
  escape c    = if isAscii c && not (isControl c)
                then pretty c
                else "\\" <> hex c
      where
          hex :: Char -> Doc a
          hex = pad0 . ($ []) . showHex . ord
          pad0 :: String -> Doc a
          pad0 [] = "00"
          pad0 [x] = "0" <> pretty x
          pad0 xs = pretty xs
  
  ppVolatile :: Bool -> Doc a
  ppVolatile True = "volatile"
  ppVolatile False = mempty
  
  ppIntAsChar :: Integral a => a -> Doc b
  ppIntAsChar = escape . chr . fromIntegral
  
  ppAlign :: Ann a => Word32 -> Doc a
  ppAlign x | x == 0    = mempty
            | otherwise = ", align" <+> pp x
  
  -- print an operand and its type
  ppTyped :: (PP a, Typed a, Ann b) => a -> Doc b
  ppTyped a = pp (typeOf a) <+> pp a
  
  -- ppCommaTyped :: (PP a, Typed a, Ann b) => a -> Doc b
  -- ppCommaTyped a = pp (typeOf a) `cma` pp a
  
  phiIncoming :: Ann b => (Operand, Name) -> Doc b
  phiIncoming (op, nm) = brackets (pp op `cma` (local (pp nm)))
  
  ppParams :: (a -> Doc b) -> ([a], Bool) -> Doc b
  ppParams ppParam (ps, varrg) = parens . commas $ fmap ppParam ps ++ vargs
      where
          vargs = if varrg then ["..."] else []
  
  ppFunctionArgumentTypes :: Ann a => Type -> Doc a
  ppFunctionArgumentTypes FunctionType {..} = ppParams pp (argumentTypes, isVarArg)
  ppFunctionArgumentTypes _ = error "Non-function argument. (Malformed AST)"
  
  ppNullInitializer :: Ann a => Type -> Doc a
  ppNullInitializer PointerType {..} = "zeroinitializer"
  ppNullInitializer StructureType {..} = "zeroinitializer"
  ppNullInitializer FunctionType {..} = "zeroinitializer"
  ppNullInitializer ArrayType {..} = "zeroinitializer"
  ppNullInitializer _ = error "Non-pointer argument. (Malformed AST)"
  
  ppCall :: Ann a => Instruction -> Doc a
  ppCall Call { function = Right f,..}
    = tl <+> "call" <+> pp callingConvention <+> pp returnAttributes <+> pp resultType <+> ftype
      <+> pp f <> parens (commas $ fmap pp arguments) <+> pp functionAttributes
      where
        (functionType@FunctionType {..}) = referencedType (typeOf f)
        ftype = if isVarArg
                then ppFunctionArgumentTypes functionType
                else mempty
        referencedType (PointerType t _) = referencedType t
        referencedType t                 = t
  
        tl = case tailCallKind of
          Just Tail -> "tail"
          Just MustTail -> "musttail"
          Just NoTail -> "notail"
          Nothing -> mempty
  ppCall _ = error "Non-callable argument. (Malformed AST)"
  
  -- Differs from Call in record name conventions only so needs a seperate almost
  -- identical function. :(
  ppInvoke :: Ann a => Terminator -> Doc a
  ppInvoke Invoke { function' = Right f,..}
    = "invoke" <+> pp callingConvention' <+> pp resultType <+> ftype
      <+> pp f <> parens (commas $ fmap pp arguments') <+> pp functionAttributes'
      where
        (functionType@FunctionType {..}) = referencedType (typeOf f)
        ftype = if isVarArg
                then ppFunctionArgumentTypes functionType
                else mempty
        referencedType (PointerType t _) = referencedType t
        referencedType t                 = t
  ppInvoke _ = error "Non-callable argument. (Malformed AST)"
  
  ppSingleBlock :: Ann a => BasicBlock -> Doc a
  ppSingleBlock (BasicBlock _nm instrs term) = vcat $ fmap pp instrs ++ [pp term]
  
  -- According to <https://stackoverflow.com/a/7002812/3877993> this is
  -- the best way to cast floats to words.
  
  cast :: (MArray (STUArray s) a (ST s),
           MArray (STUArray s) b (ST s)) => a -> ST s b
  cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0
  
  doubleToWord :: Double -> Word64
  doubleToWord x = runST (cast x)
  
  floatToWord :: Float -> Word32
  floatToWord x = runST (cast x)
  
  specialFP :: RealFloat a => a -> Bool
  specialFP f = isNaN f || f == 1 / 0 || f == - 1 / 0
  
  ppInstrMeta :: Ann a => InstructionMetadata -> Doc a
  ppInstrMeta [] = mempty
  ppInstrMeta xs = "," <> pp xs
  
  -------------------------------------------------------------------------------
  -- Toplevel
  -------------------------------------------------------------------------------
  
  ppll :: (MonadIO m, PP a) => FancyOptions -> a -> m ()
  ppll opts a = putFancy opts (pp a <> line')
  
  -- for quick testing
  ppll_ :: (MonadIO m, PP a) => a -> m ()
  ppll_ = ppll def
  