{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE GADTs #-}
module Llvm.Syntax.Printer.SharedEntityPrint where
import Prelude (($),fmap, Maybe(..),maybe, (.),null,(++),error, show,fromIntegral,String,Integral)

import Llvm.Syntax.Printer.Common 
import Llvm.Data.Shared
import Llvm.Util.Mapping (getValOrImplError)
import qualified Data.Map as M

class Print a where
  print :: a -> Doc

instance Print Endianness where
  print LittleEndian = char 'e'
  print BigEndian = char 'E'
  
instance Print LayoutAddrSpace where  
  print (LayoutAddrSpace n) = integral n
  print (LayoutAddrSpaceUnspecified) = empty
  
instance Print SizeInBit where  
  print (SizeInBit n) = integral n
  
instance Print AlignInBit where  
  print (AlignInBit n) = integral n
  
instance Print StackAlign where  
  print (StackAlign n) = print n
  print StackAlignUnspecified = char '0'
  
instance Print Mangling where
  print x = case x of
    ManglingE -> char 'e'
    ManglingM -> char 'm'
    ManglingO -> char 'o'
    ManglingW -> char 'w'
    
instance Print AbiAlign where    
  print (AbiAlign n) = print n

instance Print PrefAlign where
  print (PrefAlign n) = print n
  

integral :: Integral a => a -> Doc
integral = integer . fromIntegral

instance Print LayoutSpec where  
  print ls = case ls of
      DlE x -> print x
      DlS x -> char 'S' <> (print x)
      DlLittleS s1 s2 s3 -> char 's' <> (maybe empty integral s1) 
                            <> sepMaybe integral colonSep s2
                            <> sepMaybe integral colonSep s3
      DlP as s a n -> char 'p' <> (print as) 
                      <> colonSep (print s) 
                      <> colonSep (print a) 
                      <> sepMaybe print colonSep n
      DlI s a n -> char 'i' <> (print s)
                   <> colonSep (print a)
                   <> sepMaybe print colonSep n
      DlF s a n -> char 'f' <> (print s)
                 <> colonSep (print a)
                 <> sepMaybe print colonSep n
      DlV s a n -> char 'v' <> (print s)
                   <> colonSep (print a)
                   <> sepMaybe print colonSep n
      DlA s a n -> char 'a' <> (maybe empty print s)
                   <> colonSep (print a)
                   <> sepMaybe print colonSep n
      DlM m -> char 'm' <> colonSep (print m)
      DlN l -> char 'n' <> (hcat $ punctuate (char ':') $ fmap print l)
    where 
      colonSep = (char ':' <>)
  
instance Print DataLayout where
  print (DataLayout l) = doubleQuotes (hcat $ punctuate (char '-') $ fmap print l)
  
instance Print IcmpOp where
  print x = text $ getValOrImplError (icmpOpMap, "icmpOpMap") x

instance Print FcmpOp where
  print x = text $ getValOrImplError (fcmpOpMap, "fcmpOpMap") x

{-
instance Print ConvertOp where
  print x = text $ getValOrImplError (convertOpMap, "convertOpMap") x
-}

instance Print Linkage where
  print LinkagePrivate = text "private"
  print LinkageInternal = text "internal"
  print LinkageAvailableExternally = text "available_externally"
  print LinkageExternal = text "external"
  print LinkageLinkonce = text "linkonce"
  print LinkageWeak = text "weak"
  print LinkageCommon = text "common"
  print LinkageAppending = text "appending"
  print LinkageExternWeak = text "extern_weak"
  print LinkageLinkonceOdr = text "linkonce_odr"
  print LinkageWeakOdr = text "weak_odr"
  
instance Print CallConv where
  print Ccc = text "ccc"
  print CcFast = text "fastcc"
  print CcCold = text "coldcc"
  print CcWebkit_Js = text "webkit_jscc"
  print CcAnyReg = text "anyregcc"
  print CcPreserveMost = text "preserve_mostcc"
  print CcPreserveAll = text "preserve_allcc"
  print (Cc s) = text "cc" <> text s
  print CcSpir_Kernel = text "spir_kernel"
  print CcSpir_Func = text "spir_func"
  print CcIntel_Ocl_Bi = text "intel_ocl_bicc"
  print CcX86_StdCall = text "x86_stdcallcc"
  print CcX86_FastCall = text "x86_fastcallcc"
  print CcX86_ThisCall = text "x86_thiscallcc"
  print CcArm_Apcs = text "arm_apcscc"
  print CcArm_Aapcs = text "arm_aapcscc"
  print CcArm_Aapcs_Vfp = text "arm_aapcs_vfpcc"
  print CcMsp430_Intr = text "msp430_intrcc"
  print CcPtx_Kernel = text "ptx_kernel"
  print CcPtx_Device = text "ptx_device"
  print CcX86_64_Win64 = text "x86_64_win64cc"
  print CcX86_64_SysV = text "x86_64_sysvcc"

instance Print Visibility where
  print VisDefault = text "default"
  print VisHidden = text "hidden"
  print VisProtected = text "protected"


instance Print DllStorageClass where
  print DscImport = text "dllimport"
  print DscExport = text "dllexport"
  
instance Print ThreadLocalStorage where  
  print x = let d = case x of 
                   TlsLocalDynamic -> text "localdynamic"
                   TlsInitialExec -> text "initialexec"
                   TlsLocalExec -> text "localexec"
                   TlsNone -> empty
             in if isEmpty d then text "thread_local"
                else text "thread_local" <+> parens d 

instance Print ParamAttr where
  print PaZeroExt = text "zeroext"
  print PaSignExt = text "signext"
  print PaInReg = text "inreg"
  print PaByVal = text "byval"
  print PaInAlloca = text "inalloca"
  print PaSRet = text "sret"
  print PaNoAlias = text "noalias"
  print PaNoCapture = text "nocapture"
  print PaNest = text "nest"
  print PaReturned = text "returned"
  print PaNonNull = text "nonnull"
  print (PaDereferenceable n) = (text "dereferenceable") <> (parens $ integral n)
  print PaReadOnly = text "readonly"
  print PaReadNone = text "readnone"
  print (PaAlign n) = text "align" <+> integral n


instance Print FunAttr where
  print (FaAlignStack n) = (text "alignstack") <> (parens $ integral n)
  print FaAlwaysInline = text "alwaysinline"
  print FaBuiltin = text "builtin"
  print FaCold = text "cold"
  print FaInlineHint = text "inlinehint"
  print FaJumpTable = text "jumptable"
  print FaMinSize = text "minsize"
  print FaNaked = text "naked"
  print FaNoBuiltin = text "nobuiltin"
  print FaNoDuplicate = text "noduplicate"
  print FaNoImplicitFloat = text "noimplicitfloat"
  print FaNoInline = text "noinline"
  print FaNonLazyBind = text "nonlazybind"
  print FaNoRedZone = text "noredzone"
  print FaNoReturn = text "noreturn"
  print FaNoUnwind = text "nounwind"
  print FaOptNone = text "optnone"
  print FaOptSize = text "optsize"
  print FaReadNone = text "readnone"
  print FaReadOnly = text "readonly"
  print FaReturnsTwice = text "returns_twice"
  print FaSanitizeAddress = text "sanitize_address"
  print FaSanitizeMemory = text "sanitize_memory"
  print FaSanitizeThread = text "sanitize_thread"
  print FaSsp = text "ssp"
  print FaSspReq = text "sspreq"
  print FaSspStrong = text "sspstrong"
  print FaUwTable = text "uwtable"
  print (FaPair s1 s2) = print s1 <> (maybe empty ((equals<>) . print) s2)
  print (FaAlign n) = text "align" <+> integral n
  print (FaGroup n) = char '#'<> (integral n)
  
instance Print SelectionKind where  
  print x = text $ getValOrImplError (selectionKindMap, "selectionKindMap") x
   
instance Print AddrNaming where
  print UnnamedAddr = text "unnamed_addr"
  print NamedAddr = empty

instance Print DqString where
  print (DqString x) = doubleQuotes $ text x

instance Print Section where
  print (Section s) = text "section" <+> (print s)

instance Print Alignment where
    print (Alignment s) = text "align" <+>  (integral s)

instance Print Gc where
    print (Gc s) = text "gc" <+> (print s)

instance Print GlobalType where
    print (GlobalType s) = text s


instance Print GlobalOrLocalId where
  print (GolG g) = print g
  print (GolL l) = print l
                    
instance Print LocalId where
  print (LocalIdNum s) = char '%'<>(integral s)
  print (LocalIdAlphaNum s) = char '%' <> text s
  print (LocalIdDqString s) = char '%' <> (doubleQuotes $ text s)
                      
instance Print GlobalId where
  print (GlobalIdNum s) = char '@'<>(integral s)
  print (GlobalIdAlphaNum s) = char '@'<> text s
  print (GlobalIdDqString s) = char '@'<> (doubleQuotes $ text s)

instance Print SimpleConstant where
  print x = case x of
    CpInt i -> text i
    CpUhexInt i -> text "u0x" <> (text i)
    CpShexInt i -> text "s0x" <> (text i)
    CpFloat s -> text s
    CpNull -> text "null"
    CpUndef -> text "undef"
    CpTrue -> text "true"
    CpFalse -> text "false"
    CpZeroInitializer -> text "zeroinitializer"
    CpGlobalAddr g -> print g
    CpStr s -> char 'c'<> (doubleQuotes $ text s)
    CpBconst bc -> print bc
                          
instance Print BinaryConstant where
  print x = case x of
    BconstUint8 v -> integral v
    BconstUint16 v -> integral v
    BconstUint32 v -> integral v
    BconstUint64 v -> integral v
    BconstUint96 v -> integral v
    BconstUint128 v -> integral v
    BconstInt8 v -> integral v
    BconstInt16 v -> integral v
    BconstInt32 v -> integral v
    BconstInt64 v -> integral v
    BconstInt96 v -> integral v
    BconstInt128 v -> integral v

instance Print AtomicMemoryOrdering where
  print x = text $ getValOrImplError (atomicMemoryOrderingMap, "atomicMemoryOrderingMap") x

instance Print AtomicOp where
  print x = text $ getValOrImplError (atomicOpMap, "atomicOpMap") x
    
instance Print Fparam where
  print (FimplicitParam) = text "; implicit param\n"
  print (FexplicitParam x) = print x
  
instance Print InAllocaAttr where
  print s = case s of
    InAllocaAttr -> text "inalloca"
    
    
instance Print Volatile where
  print Volatile = text "volatile"

instance Print Weak where
  print Weak = text "weak"
  
instance Print SingleThread where
  print SingleThread = text "singlethread"

instance Print InBounds where
  print InBounds = text "inbounds"
  
instance Print a => Print (IsOrIsNot a) where
  print s = case s of
    Is x -> print x
    IsNot _ -> empty

instance Print Nontemporal where    
  print (Nontemporal i) = char '!'<>(text "nontemporal") <+> char '!'<>(integral i)
  
instance Print InvariantLoad where
  print (InvariantLoad i) = char '!'<>(text "invariant.load") <+> char '!'<>(integral i)
  
instance Print Nonnull where
  print (Nonnull i) = char '!'<>(text "nonnull") <+> char '!'<>(integral i)
  
  
instance Print TailCall where
  print x = case x of
    TcNon -> empty
    TcTailCall -> text "tail"
    TcMustTailCall -> text "musttail"
    
instance Print DollarId where
  print (DollarIdNum n) = char '$' <> (integral n)
  print (DollarIdAlphaNum s) = char '$' <> (text s)
  print (DollarIdDqString s) = char '$' <> (doubleQuotes $ text s)
                                    
                        
instance Print Comdat where
  print (Comdat l) = text "comdat" <+> (maybe empty print l)
    
instance Print FastMathFlag where
  print x = text $ getValOrImplError (fastMathFlagMap, "fastMathFlagMap") x 
                
instance Print FastMathFlags where                
  print (FastMathFlags l) = hsep $ fmap print l
  
instance Print ExternallyInitialized where  
  print ExternallyInitialized = text "externally_initialized"
  
  
instance Print AsmDialect where  
  print x = case x of
    AsmDialectAtt -> empty
    AsmDialectIntel -> text "inteldialect"
  
  
instance Print SideEffect where
  print SideEffect = text "sideeffect"
  
instance Print AlignStack where  
  print AlignStack = text "alignstack"
  
instance Print VarArgParam where
  print VarArgParam = text "..."
  
instance Print Cleanup where
  print Cleanup = text "cleanup"

instance Print Arch where
  print arch = case arch of
    Arch_i386 -> text "i386"
    Arch_i686 -> text "i686"
    Arch_x86 -> text "x86"
    Arch_x86_64 -> text "x86_64"
    Arch_PowerPc -> text "powerpc"
    Arch_PowerPc64 -> text "powerpc64"
    Arch_Arm s -> text "arm" <> text s
    Arch_ThumbV7 -> text "thumbv7"
    Arch_Itanium -> text "itanium"
    Arch_Mips s -> text "mips" <> text s
    Arch_String s -> text s
    
instance Print Vendor where
  print v = case v of
    Vendor_Pc -> text "pc"
    Vendor_Apple -> text "apple"
    Vendor_Unknown -> text "unknown"
    Vendor_String s -> text s
    
instance Print Os where    
  print v = case v of
    Os_Linux -> text "linux"
    Os_Windows -> text "windows"
    Os_Win32 -> text "win32"
    Os_Darwin s -> text "darwin" <> text s
    Os_FreeBsd s -> text "freebsd" <> text s
    Os_Macosx s -> text "macosx" <> text s
    Os_Ios s -> text "ios" <> text s
    Os_Mingw32 -> text "mingw32"
    Os_Unknown -> text "unknown"
    Os_String s -> text s
    
instance Print OsEnv where    
  print v = case v of
    OsEnv_Gnu -> text "gnu"
    OsEnv_String s -> text s

instance Print TargetTriple where
  print (TargetTriple arch ven os env) = 
    doubleQuotes (hcat $ punctuate (char '-') 
                  ([print arch] ++ mb ven ++ mb os ++ mb env))
    where mb v = maybe [] (\x -> [print x]) v

instance Print DataLayoutInfo where
  print (DataLayoutInfo e sa ptrs is fs as ni ml _) = text "datalayout"