module Llvm.Syntax.Parser.Basic
    ( module Text.Parsec
    , module Llvm.Syntax.Parser.Basic
    , module Control.Monad
    , module Text.Parsec.Perm
    )
    where

import Text.Parsec 
import Control.Monad
import Llvm.Data.Ast
import qualified Text.Parsec.Token as T
import Text.Parsec.Language
import Text.Parsec.Perm
import Data.Char
import Data.Functor.Identity (Identity)
import qualified Data.Map as M
import Data.Word (Word32)

-- dummy state
-- data DummyState = DummyState

type DummyState = ()

type P a = Parsec String DummyState a

initState :: DummyState
initState = () -- DummyState 

lexer :: T.GenTokenParser String u Data.Functor.Identity.Identity
lexer = T.makeTokenParser 
        (emptyDef 
         { T.commentLine = ";"
         , T.reservedNames = 
             [ "begin", "end", "true", "false", "declare", "define", "global", "constant"
             , "dllimport", "dllexport"
             , "extern_weak", "external", "thread_local", "zeroinitializer", "undef", "null", "to", "tail"
             , "target", "triple", "deplibs", "datalayout", "volatile", "nuw", "nsw", "exact", "inbounds", "align"
             , "addrspace", "section", "alias", "module", "asm", "sideeffect", "gc", "ccc", "cc", "fastcc"
             , "coldcc", "x86_stdcallcc", "x86_fastcallcc", "x86_thiscallcc", "arm_apcscc", "arm_aapcscc", "arm_aapcs_vfpcc"
             , "msp430_intrcc", "cc", "c", "signext", "zeroext", "inreg", "sret", "nounwind", "noreturn", "noalias"
             , "nocapture", "byval", "nest", "type", "opaque", "eq", "ne", "slt", "sgt"
             , "sle", "sge", "ult", "ugt", "ule", "uge", "oeq", "one", "olt", "ogt", "ole", "oge", "ord", "uno", "ueq"
             , "une", "x", "blockaddress"
             , "add",  "fadd", "sub",  "fsub", "mul",  "fmul", "udiv", "sdiv", "fdiv", "urem", "srem", "frem"
             , "shl",  "lshr", "ashr", "and",  "or",   "xor", "icmp", "fcmp", "phi", "call", "trunc"
             , "zext", "sext", "fptrunc", "fpext", "uitofp", "sitofp", "fptoui", "fptosi", "inttoptr", "ptrtoint"
             , "bitcast", "addrspacecast", "select", "va_arg", "ret", "br", "switch", "indirectbr"
             , "invoke", "unwind", "unreachable"
             , "alloca", "malloc", "load", "store", "getelementptr", "extractelement", "insertelement", "shufflevector"
             , "getresult", "extractvalue", "insertvalue", "free", "address_safety", "nonlazybind", "landingpad", "cleanup"
             , "catch", "filter", "personality", "half", "unnamed_addr", "singlethread", "acquire"
             , "release", "acq_rel", "seq_cst", "unordered", "monotonic", "atomic"
             , "atomicrmw", "xchg", "nand", "max", "min", "umax", "umin", "x86_mmx"
             , "call", "tail", "musttail"
             -- Linkage Types                                                             
             , "private", "internal", "available_externally", "linkonce", "weak", "common", "appending", "extern_weak"
             , "linkonce_odr", "weak_odr", "external"
             -- Calling Conventions
             , "ccc", "fastcc", "coldcc", "cc", "webkit_jscc", "anyregcc", "preserve_mostcc", "preserve_allcc"
             , "spir_kernel", "spir_func", "intel_ocl_bicc", "x86_stdcallcc", "x86_fastcallcc", "x86_thiscallcc"
             , "arm_apcscc", "arm_aapcscc", "arm_aapcs_vfpcc", "msp430_intrcc", "ptx_kernel", "ptx_device"
             , "x86_64_win64cc", "x86_64_sysvcc"
             -- Visibility Styles                                                                             
             , "default", "hidden", "protected"
             -- Parameter Attributes                                                             
             , "zeroext", "signext", "inreg", "byval", "inalloca", "sret", "noalias", "nocapture", "nest", "returned"
             , "nonnull", "dereferenceable"
             -- Function Attributes
             , "alignstack", "alwaysinline", "builtin", "cold", "inlinehint", "jumptable", "minsize", "naked", "nobuiltin"
             , "noduplicate", "noimplicitfloat", "noinline", "nonlazybind", "noredzone", "noreturn", "nounwind", "optnone"
             , "optsize", "readnone", "readonly", "returns_twice", "sanitize_address", "sanitize_memory", "sanitize_thread"
             , "ssp", "sspreq", "sspstrong", "uwtable"
             -- Fast math flags
             , "nnan", "ninf", "nsz", "arcp", "fast"
             , "inteldialect"
             , "<<label>>"
             ]
         })
          

integer :: P Integer
integer = T.integer lexer

unsignedInt :: P Word32
unsignedInt = liftM fromIntegral integer

decimal :: P Integer
decimal = lexeme (T.decimal lexer)


reserved :: String -> P ()
reserved = T.reserved lexer


symbol :: String -> P String
symbol = T.symbol lexer


lexeme :: P a -> P a
lexeme = T.lexeme lexer


intStrToken :: P String
intStrToken = lexeme numericLit <?> "intStringToken"


whiteSpace :: P ()
whiteSpace = T.whiteSpace lexer

ignore   :: P a -> P ()
ignore p = do { _ <- p ; return () }

chartok :: Char -> P Char
chartok = lexeme . char

complete :: P a -> P a
complete p = do { whiteSpace; x <- p; eof; return x }

-------------------------------------------------------------------------------
comma :: P String
comma = T.comma lexer

colon :: P String
colon = T.colon lexer

braces :: P a  -> P a
braces = T.braces lexer 

brackets :: P a -> P a
brackets = T.brackets lexer 

parens :: P a -> P a
parens = T.parens lexer

angles :: P a -> P a
angles = T.angles lexer

anglebraces :: P a -> P a
anglebraces p = between (symbol "<{") (symbol "}>") p


-------------------------------------------------------------------
idChar :: Char -> Bool
idChar c = isAlphaNum c || c == '$' || c == '.' || c == '_' || c == '-'    

startChar :: Char -> Bool
startChar c = isAlpha c || c == '$' || c == '.' || c == '_' || c == '-'

pAlphaNum :: P String
pAlphaNum = do { h <- satisfy startChar
               ; l <- many (satisfy idChar)
               ; return (h:l)
               }

pLocalId :: P LocalId
pLocalId = do { x <- lexeme (char '%' >> choice [ liftM LocalIdNum unsignedInt -- decimal
                                                , try $ liftM (LocalIdAlphaNum) pAlphaNum
                                                , try $ liftM (LocalIdAlphaNum) (lexeme (between (char '"') (char '"') pAlphaNum))
                                                , liftM (LocalIdDqString) pQuoteStr
                                                ])
              ; return x
              }

pGlobalId :: P GlobalId
pGlobalId = lexeme (char '@' >> choice [ liftM GlobalIdNum unsignedInt -- decimal
                                       , try $ liftM (GlobalIdAlphaNum) pAlphaNum -- (many1 (satisfy idChar))
                                       , try $ liftM GlobalIdAlphaNum (lexeme (between (char '"') (char '"') pAlphaNum))
                                       , liftM GlobalIdDqString pQuoteStr
                                       ])

pDollarId :: P DollarId
pDollarId = lexeme (char '$' >> choice [ liftM DollarIdNum unsignedInt -- decimal
                                       , try $ liftM (DollarIdAlphaNum) pId 
                                       , try $ liftM DollarIdAlphaNum (lexeme (between (char '"') (char '"') pId))
                                       , liftM (DollarIdDqString) pQuoteStr
                                       ])


pMdVar :: P MdVar
pMdVar = lexeme $ do { ignore (char '!')
                     ; n <- choice [ liftM (\x -> [x]) (satisfy isAlpha)
                                   , char '\\' >> numericLit ]
                     ; l <- many (satisfy idChar)
                     ; return $ MdVar (n++l)
                     }

pId :: P String
pId = do { n <- (satisfy isAlpha)
         ; l <- many (satisfy idChar)
         ; return $ n:l
         }
    
pGlobalOrLocalId :: P GlobalOrLocalId
pGlobalOrLocalId = do { x <- choice [liftM GolL pLocalId
                                    , liftM GolG pGlobalId ]
                      ; return x
                      }


numericLit :: P String
numericLit = many1 (satisfy isNumber)

pQuoteStr :: P String
pQuoteStr = lexeme ((char '"' >> (manyTill anyChar (char '"'))))

readInteger :: String -> Either String Integer            
readInteger x = case reads x :: [(Integer, String)] of
                  [(i,s)] | s == "" -> Right i
                  [] -> Left x                  
                  _ -> Left x
                        
pLabelId :: P LabelId
pLabelId = choice [ do { s <- (many1 (satisfy lblChar))
                       ; case readInteger s of
                            Right x -> return $ LabelNumber $ fromIntegral x
                            Left x -> return $ LabelString x
                       }
                  , do { s <- pQuoteStr
                       ; case readInteger s of
                           Right x -> return $ LabelDqNumber $ fromIntegral x
                           Left x -> return $ LabelDqString x
                       }
                  ]
           where
             lblChar c = isAlphaNum c || c == '.' || c == '_' || c == '-' 
             
             
pLabelNumber :: P LabelId
pLabelNumber = do { x <- many1 (satisfy isDigit)
                  ; let i = read x:: Word32 -- Int 
                  ; return $ LabelNumber i
                  }
             
pAddrNaming :: P AddrNaming
pAddrNaming = option NamedAddr (reserved "unnamed_addr" >> return UnnamedAddr)
          
pPercentLabel :: P PercentLabel
pPercentLabel = lexeme (char '%' >> liftM PercentLabel pLabelId)

pTargetLabel :: P TargetLabel
pTargetLabel = reserved "label" >> liftM TargetLabel pPercentLabel

pExplicitBlockLabel :: P BlockLabel
pExplicitBlockLabel = lexeme (do { x <- pLabelId 
                                 ; _ <- char ':'
                                 ; return $ ExplicitBlockLabel x
                                 })
              
pImplicitBlockLabel :: P BlockLabel              
pImplicitBlockLabel = do { pos <- getPosition
                         ; return $ ImplicitBlockLabel (sourceName pos, sourceLine pos, sourceColumn pos)
                         }
                      

pBlockLabel :: P BlockLabel                      
pBlockLabel = choice [ try pExplicitBlockLabel
                     , pImplicitBlockLabel ]

pParamAttr :: P ParamAttr
pParamAttr = choice [ reserved "zeroext" >> return PaZeroExt
                    , reserved "signext" >> return PaSignExt
                    , reserved "inreg" >> return PaInReg
                    , reserved "byval" >> return PaByVal
                    , reserved "inalloca" >> return PaInAlloca
                    , reserved "sret" >> return PaSRet
                    , reserved "noalias" >> return PaNoAlias
                    , reserved "nocapture" >> return PaNoCapture
                    , reserved "nest" >> return PaNest
                    , reserved "returned" >> return PaReturned
                    , reserved "nonnull" >> return PaNonNull
                    , reserved "dereferenceable" >> liftM PaDereferenceable (parens unsignedInt) -- decimal)
                    , reserved "readonly" >> return PaReadOnly
                    , reserved "readnone" >> return PaReadNone
                    , reserved "align" >> liftM PaAlign unsignedInt -- decimal
                    ]

pConvertOp :: P ConvertOp
pConvertOp = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList convertOpMap

pCallConv :: P CallConv
pCallConv = choice [ try (reserved "ccc") >> return Ccc
                   , try (string "cc" >> liftM Cc intStrToken)
                   , reserved "cc" >> liftM Cc intStrToken
                   , reserved "fastcc" >> return CcFast
                   , reserved "coldcc" >> return CcCold
                   , reserved "webkit_jscc" >> return CcWebkit_Js
                   , reserved "anyregcc" >> return CcAnyReg
                   , reserved "preserve_mostcc" >> return CcPreserveMost
                   , reserved "preserve_allcc" >> return CcPreserveAll
                   , reserved "spir_kernel" >> return CcSpir_Kernel
                   , reserved "spir_func" >> return CcSpir_Func
                   , reserved "intel_ocl_bicc" >> return CcIntel_Ocl_Bi
                   , reserved "x86_stdcallcc" >> return CcX86_StdCall
                   , reserved "x86_fastcallcc" >> return CcX86_FastCall
                   , reserved "x86_thiscallcc" >> return CcX86_ThisCall
                   , reserved "arm_apcscc" >> return CcArm_Apcs
                   , reserved "arm_aapcscc" >> return CcArm_Aapcs
                   , reserved "arm_aapcs_vfpcc" >> return CcArm_Aapcs_Vfp
                   , reserved "msp430_intrcc" >> return CcMsp430_Intr
                   , reserved "ptx_kernel" >> return CcPtx_Kernel
                   , reserved "ptx_device" >> return CcPtx_Device
                   , reserved "x86_64_win64cc" >> return CcX86_64_Win64
                   , reserved "x86_64_sysvcc" >> return CcX86_64_SysV
                   ]


pVisibility :: P Visibility
pVisibility = (reserved "default" >> return VisDefault)
              <|> (reserved "hidden" >> return VisHidden)
              <|> (reserved "protected" >> return VisProtected)


pLinkage :: P Linkage
pLinkage = choice [ reserved "linker_private_weak_def_auto" >> return LinkagePrivate
                  , reserved "linker_private_weak" >> return LinkagePrivate
                  , reserved "private" >> return LinkagePrivate
                  , reserved "linker_private" >> return LinkagePrivate
                  , reserved "internal" >> return LinkageInternal
                  , reserved "external" >> return LinkageExternal
                  , reserved "available_externally" >> return LinkageAvailableExternally
                  , reserved "linkonce" >> return LinkageLinkonce
                  , reserved "weak" >> return LinkageWeak
                  , reserved "common" >> return LinkageCommon
                  , reserved "appending" >> return LinkageAppending
                  , reserved "extern_weak" >> return LinkageExternWeak
                  , reserved "linkonce_odr" >> return LinkageLinkonceOdr
                  , reserved "weak_odr" >> return LinkageWeakOdr
                  ]


opt :: P a -> P (Maybe a)
opt p = option Nothing (liftM Just (try p))


optCommaSep :: P a -> P (Maybe a)
optCommaSep p = opt (try (comma >> p))



pIbinaryOperator :: P IbinOp
pIbinaryOperator = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList ibinOpMap

pFbinaryOperator :: P FbinOp
pFbinaryOperator = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList fbinOpMap

pIcmpOp :: P IcmpOp
pIcmpOp = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList icmpOpMap

pFcmpOp :: P FcmpOp
pFcmpOp = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList fcmpOpMap


pAliasLinkage :: P Linkage
pAliasLinkage = choice [ reserved "private" >> return LinkagePrivate
                       , reserved "internal" >> return LinkageInternal
                       , reserved "available_externally" >> return LinkageAvailableExternally
                       , reserved "linkonce" >> return LinkageLinkonce
                       , reserved "weak" >> return LinkageWeak
                       , reserved "common" >> return LinkageCommon
                       , reserved "appending" >> return LinkageAppending
                       , reserved "extern_weak" >> return LinkageExternWeak
                       , reserved "linkonce_odr" >> return LinkageLinkonceOdr
                       , reserved "weak_odr" >> return LinkageWeakOdr
                       , reserved "external" >> return LinkageExternal
                       ]

pDllStorageClass :: P DllStorageClass
pDllStorageClass = choice [ reserved "dllimport" >> return DscImport
                          , reserved "dllexport" >> return DscExport
                          ] 
pThreadLocalStorageClass :: P ThreadLocalStorage                   
pThreadLocalStorageClass = reserved "thread_local" >> option TlsNone (parens (choice [ reserved "localdynamic" >> return TlsLocalDynamic
                                                                                     , reserved "initialexec" >> return TlsInitialExec
                                                                                     , reserved "localexec" >> return TlsLocalExec
                                                                                     ]
                                                                             ))

pTailCall :: P TailCall
pTailCall = choice [ reserved "tail" >> return TcTailCall
                   , reserved "musttail" >> return TcMustTailCall
                   ]
pFunAttr :: P FunAttr
pFunAttr =  choice [ reserved "alignstack" >> liftM FaAlignStack (parens unsignedInt) -- decimal)
                   , reserved "alwaysinline" >> return FaAlwaysInline
                   , reserved "builtin" >> return FaBuiltin
                   , reserved "cold" >> return FaCold
                   , reserved "inlinehint" >> return FaInlineHint
                   , reserved "jumptable" >> return FaJumpTable
                   , reserved "minsize" >> return FaMinSize
                   , reserved "naked" >> return FaNaked
                   , reserved "nobuiltin" >> return FaNoBuiltin
                   , reserved "noduplicate" >> return FaNoDuplicate
                   , reserved "noimplicitfloat" >> return FaNoImplicitFloat
                   , reserved "noinline" >> return FaNoInline
                   , reserved "nonlazybind" >> return FaNonLazyBind
                   , reserved "noredzone" >> return FaNoRedZone
                   , reserved "noreturn" >> return FaNoReturn
                   , reserved "nounwind" >> return FaNoUnwind
                   , reserved "optnone" >> return FaOptNone
                   , reserved "optsize" >> return FaOptSize
                   , reserved "readnone" >> return FaReadNone
                   , reserved "readonly" >> return FaReadOnly
                   , reserved "returns_twice" >> return FaReturnsTwice
                   , reserved "sanitize_address" >> return FaSanitizeAddress
                   , reserved "sanitize_memory" >> return FaSanitizeMemory
                   , reserved "sanitize_thread" >> return FaSanitizeThread
                   , reserved "ssp" >> return FaSsp
                   , reserved "sspreq" >> return FaSspReq
                   , reserved "sspstrong" >> return FaSspStrong
                   , reserved "uwtable" >> return FaUwTable
                   , reserved "align" >> liftM FaAlign unsignedInt -- integer
                   , liftM DqString pQuoteStr >>= \s1 -> opt (symbol "=" >> liftM DqString pQuoteStr) >>= \s2 -> return (FaPair s1 s2)
                   ]

pCarry :: P TrapFlag
pCarry = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList trapFlagMap


pAlign :: P Alignment
pAlign = reserved "align" >> liftM Alignment unsignedInt -- decimal

pComdat :: P Comdat
pComdat = reserved "comdat" >> liftM Comdat (opt pDollarId)

pNontemporal :: P Nontemporal
pNontemporal =  char '!' >> reserved "nontemporal" >> char '!' >> liftM Nontemporal unsignedInt -- decimal 

pInvariantLoad :: P InvariantLoad
pInvariantLoad = char '!' >> reserved "invariant.load" >> char '!' >> liftM InvariantLoad unsignedInt -- decimal

pNonnull :: P Nonnull
pNonnull = char '!' >> reserved "nonnull" >> char '!' >> liftM Nonnull unsignedInt -- decimal

pSection :: P Section
pSection =  reserved "section" >> liftM (Section . DqString) pQuoteStr

pSelectionKind :: P SelectionKind
pSelectionKind = choice $ fmap (\(x, y) -> reserved y >> return x) $ M.toList selectionKindMap 

pAddrSpace :: P AddrSpace
pAddrSpace = reserved "addrspace" >> liftM (AddrSpace . fromIntegral) (parens decimal)
             
pGlobalType :: P GlobalType 
pGlobalType = choice [ reserved "constant" >> return (GlobalType "constant")
                     , reserved "global" >> return (GlobalType "global")
                     ]

pFenceOrder :: P AtomicMemoryOrdering
pFenceOrder =  choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList atomicMemoryOrderingMap

pAtomicOp :: P AtomicOp
pAtomicOp = choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList atomicOpMap

pFunAttrCollection :: P [FunAttr] -- Collection          
pFunAttrCollection = many $ choice [ char '#' >> liftM FaGroup unsignedInt -- decimal
                                   , pFunAttr
                                   ]

pTuple2 :: P a -> P b -> P (a, b)
pTuple2 p1 p2 = do { a1 <- p1
                   ; ignore comma
                   ; a2 <- p2
                   ; return (a1, a2)
                   }

pTriple3 :: P a -> P b -> P c -> P (a, b, c)
pTriple3 p1 p2 p3 = do { a1 <- p1
                       ; ignore comma
                       ; a2 <- p2
                       ; ignore comma
                       ; a3 <- p3
                       ; return (a1, a2, a3)
                       }


pTuple :: P a -> P (a, a)
pTuple p = pTuple2 p p

pTriple :: P a -> P (a, a, a)
pTriple p = pTriple3 p p p

uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d 
uncurry3 f (a1, b1, c1) = f a1 b1 c1
    
                          
pFastMathFlag :: P FastMathFlag
pFastMathFlag =  choice $ fmap (\(x,y) -> reserved y >> return x) $ M.toList fastMathFlagMap
                
pFastMathFlags :: P FastMathFlags                
pFastMathFlags = liftM FastMathFlags (many pFastMathFlag)