Metadata.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
module LLVM.Test.Metadata where

import LLVM.Prelude

import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Test.QuickCheck as QC

import LLVM.Test.Support

import Control.Monad.IO.Class
import Data.ByteString as B (readFile)
import qualified Data.ByteString.Short as BSS
import Data.Functor.Identity
import Data.Maybe (catMaybes)
import Foreign.Ptr
import Text.Show.Pretty (pPrint)

import LLVM.AST as A hiding (GlobalVariable, PointerType)
import LLVM.AST.Operand hiding (Module)
import qualified LLVM.AST.Operand as O
import qualified LLVM.AST.Operand as A (DIFlag(..), Virtuality(..), DIInheritance(..), DIAccessibility(..))
import LLVM.AST.Type as A.T hiding (PointerType)
import LLVM.AST.AddrSpace as A
import qualified LLVM.AST.Linkage as L
import qualified LLVM.AST.Visibility as V
import qualified LLVM.AST.CallingConvention as CC
import qualified LLVM.AST.Constant as C
import LLVM.AST.Global as G hiding (GlobalVariable)

import LLVM.Context
import LLVM.Module
import LLVM.Internal.Coding
import LLVM.Internal.DecodeAST
import LLVM.Internal.EncodeAST
import qualified LLVM.Internal.FFI.PtrHierarchy as FFI
import qualified LLVM.Internal.FFI.Metadata as FFI

tests = testGroup "Metadata"
  [ globalMetadata
  , namedMetadata
  , nullMetadata
  , cyclicMetadata
  , globalObjectMetadata
  , roundtripDIBasicType
  , roundtripDIDerivedType
  , roundtripDISubroutineType
  , roundtripDIArrayType
  , roundtripDIEnumerationType
  , roundtripDIStructureType
  , roundtripDIClassType
  , roundtripDIUnionType
  , roundtripDIFile
  , roundtripDINode
  , roundtripDICompileUnit
  , roundtripDIVariable
  , roundtripDIFlags
  , roundtripDISubprogram
  , roundtripDILexicalBlockBase
  , roundtripDITemplateParameter
  , roundtripDINamespace
  , roundtripDIExpression
  , diFlagName
  , testFile
  ]

arbitrarySbs :: Gen ShortByteString
arbitrarySbs = BSS.pack <$> listOf arbitrary

instance Arbitrary Encoding where
  arbitrary =
    QC.elements
      [ AddressEncoding
      , BooleanEncoding
      , FloatEncoding
      , SignedEncoding
      , SignedCharEncoding
      , UnsignedEncoding
      , UnsignedCharEncoding
      ]

instance Arbitrary ChecksumKind where
  arbitrary = QC.elements [None, MD5, SHA1]

instance Arbitrary BasicTypeTag where
  arbitrary = QC.elements [BaseType, UnspecifiedType]

instance Arbitrary DIType where
  arbitrary = oneof [DIBasicType <$> arbitrary]

instance Arbitrary DIBasicType where
  arbitrary = BasicType <$> arbitrarySbs <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary

genDIArrayType :: Maybe (MDRef DIType) -> Gen DICompositeType
genDIArrayType elTy =
  DIArrayType <$> arbitrary <*> pure elTy <*> arbitrary <*> arbitrary <*> genDIFlags

instance Arbitrary DIMacroInfo where
  arbitrary = QC.elements [Define, Undef]

genDIMacro :: Gen DIMacroNode
genDIMacro =
  DIMacro <$> arbitrary <*> arbitrary <*> arbitrarySbs <*> arbitrarySbs

roundtripDIArrayType :: TestTree
roundtripDIArrayType = testProperty "roundtrip DIArrayType" $ \elType ->
  forAll (genDIArrayType (Just (MDRef elTyID))) $ \diArrayType -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [arrayTypeID]
                , MetadataNodeDefinition arrayTypeID (DINode (DIScope (DIType (DICompositeType diArrayType))))
                , MetadataNodeDefinition elTyID (DINode (DIScope (DIType elType)))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where arrayTypeID = MetadataNodeID 0
        elTyID = MetadataNodeID 1

genDIEnumerationType :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DIType) -> Gen DICompositeType
genDIEnumerationType scope file baseTy =
  DIEnumerationType
    <$> pure scope
    <*> arbitrarySbs
    <*> pure file
    <*> arbitrary
    <*> arbitrary
    <*> pure baseTy
    <*> arbitrarySbs
    <*> arbitrary
    <*> arbitrary

roundtripDIEnumerationType :: TestTree
roundtripDIEnumerationType = testProperty "roundtrip DIEnumerationType" $ \file baseType ->
  forAll (genDIEnumerationType Nothing (Just (MDRef fileID)) (Just (MDRef baseTyID))) $ \diEnumType -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [enumTypeID]
                , MetadataNodeDefinition enumTypeID (DINode (DIScope (DIType (DICompositeType diEnumType))))
                , MetadataNodeDefinition fileID (DINode (DIScope (DIFile file)))
                , MetadataNodeDefinition baseTyID (DINode (DIScope (DIType baseType)))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where enumTypeID = MetadataNodeID 0
        fileID = MetadataNodeID 1
        baseTyID = MetadataNodeID 2

genDIStructureType :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DIType) -> [MDRef (Either DIDerivedType DISubprogram)] -> Maybe (MDRef DIType) -> Gen DICompositeType
genDIStructureType scope file derivedFrom elements vtableHolder =
  DIStructureType
    <$> pure scope
    <*> arbitrarySbs
    <*> pure file
    <*> arbitrary
    <*> genDIFlags
    <*> pure derivedFrom
    <*> pure elements
    <*> arbitrary
    <*> pure vtableHolder
    <*> arbitrarySbs
    <*> arbitrary
    <*> arbitrary

roundtripDIStructureType :: TestTree
roundtripDIStructureType = testProperty "roundtrip DIStructureType" $
  forAll (genDIStructureType Nothing Nothing Nothing [] Nothing) $ \diStructureType -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [structureTypeID]
                , MetadataNodeDefinition structureTypeID (DINode (DIScope (DIType (DICompositeType diStructureType))))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where structureTypeID = MetadataNodeID 0

genDIClassType :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DIType) -> [MDRef (Either DIDerivedType DISubprogram)] -> Maybe (MDRef DIType) -> [DITemplateParameter] -> Gen DICompositeType
genDIClassType scope file derivedFrom elements vtableHolder templateParams =
  DIClassType
    <$> pure scope
    <*> arbitrarySbs
    <*> pure file
    <*> arbitrary
    <*> genDIFlags
    <*> pure derivedFrom
    <*> pure elements
    <*> pure vtableHolder
    <*> pure templateParams
    <*> arbitrarySbs
    <*> arbitrary
    <*> arbitrary

roundtripDIClassType :: TestTree
roundtripDIClassType = testProperty "roundtrip DIClassType" $
  forAll (genDIClassType Nothing Nothing Nothing [] Nothing []) $ \diClassType -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [classTypeID]
                , MetadataNodeDefinition classTypeID (DINode (DIScope (DIType (DICompositeType diClassType))))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where classTypeID = MetadataNodeID 0

genDIUnionType :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> [MDRef (Either DIDerivedType DISubprogram)] -> Gen DICompositeType
genDIUnionType scope file elements =
  DIUnionType
    <$> pure scope
    <*> arbitrarySbs
    <*> pure file
    <*> arbitrary
    <*> genDIFlags
    <*> pure elements
    <*> arbitrary
    <*> arbitrarySbs
    <*> arbitrary
    <*> arbitrary

roundtripDIUnionType :: TestTree
roundtripDIUnionType = testProperty "roundtrip DIUnionType" $
  forAll (genDIUnionType Nothing Nothing []) $ \diUnionType -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [unionTypeID]
                , MetadataNodeDefinition unionTypeID (DINode (DIScope (DIType (DICompositeType diUnionType))))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where unionTypeID = MetadataNodeID 0

instance Arbitrary DIFile where
  arbitrary =
    O.File <$> arbitrarySbs <*> arbitrarySbs <*> arbitrarySbs <*> arbitrary

instance Arbitrary DISubrange where
  arbitrary = Subrange <$> arbitrary <*> arbitrary

instance Arbitrary DIEnumerator where
  arbitrary = Enumerator <$> arbitrary <*> arbitrarySbs

instance Arbitrary DINode where
  arbitrary =
    oneof
      [ DISubrange <$> arbitrary
      , DIEnumerator <$> arbitrary
      -- TODO: Add missing constructors
      ]

roundtripDIBasicType :: TestTree
roundtripDIBasicType = testProperty "roundtrip DIBasicType" $ \diType -> ioProperty $
  withContext $ \context -> runEncodeAST context $ do
    encodedDIType <- encodeM (diType :: DIType)
    decodedDIType <- liftIO (runDecodeAST (decodeM (encodedDIType :: Ptr FFI.DIType)))
    pure (decodedDIType === diType)

roundtripDIDerivedType :: TestTree
roundtripDIDerivedType = testProperty "roundtrip DIDerivedType" $ \baseType ->
  forAll (genDIDerivedType Nothing Nothing (MDRef baseTypeID)) $ \diDerivedType -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [derivedTypeID]
                , MetadataNodeDefinition derivedTypeID (DINode (DIScope (DIType (DIDerivedType diDerivedType))))
                , MetadataNodeDefinition baseTypeID (DINode (DIScope (DIType baseType)))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where derivedTypeID = MetadataNodeID 0
        baseTypeID = MetadataNodeID 1

instance Arbitrary DerivedTypeTag where
  arbitrary =
    QC.elements [ Typedef, PointerType, PtrToMemberType, ReferenceType, RValueReferenceType
             , ConstType, VolatileType, RestrictType, AtomicType, Member, Inheritance, Friend
             ]

genDIDerivedType :: Maybe (MDRef DIFile) -> Maybe (MDRef DIScope) -> MDRef DIType -> Gen DIDerivedType
genDIDerivedType file scope baseType =
  DerivedType
    <$> arbitrary
    <*> arbitrarySbs
    <*> pure file
    <*> arbitrary
    <*> pure scope
    <*> pure baseType
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> genDIFlags

roundtripDISubroutineType :: TestTree
roundtripDISubroutineType = testProperty "roundtrip DISubroutineType" $ \argType ->
  forAll (genDISubroutineType [Nothing, Just (MDRef argTypeID)]) $ \diSubroutineType -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [subroutineTypeID]
                , MetadataNodeDefinition subroutineTypeID (DINode (DIScope (DIType (DISubroutineType diSubroutineType))))
                , MetadataNodeDefinition argTypeID (DINode (DIScope (DIType argType)))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where subroutineTypeID = MetadataNodeID 0
        argTypeID = MetadataNodeID 1

genDISubroutineType :: [Maybe (MDRef DIType)] -> Gen DISubroutineType
genDISubroutineType types =
  SubroutineType
    <$> genDIFlags
    <*> arbitrary
    <*> pure types

roundtripDIFile :: TestTree
roundtripDIFile = testProperty "roundtrip DIFile" $ \diFile -> ioProperty $
  withContext $ \context -> runEncodeAST context $ do
    encodedDIFile <- encodeM (diFile :: DIFile)
    decodedDIFile <- liftIO (runDecodeAST (decodeM (encodedDIFile :: Ptr FFI.DIFile)))
    pure (decodedDIFile === diFile)

roundtripDINode :: TestTree
roundtripDINode = testProperty "roundtrip DINode" $ \diNode -> ioProperty $
  withContext $ \context -> runEncodeAST context $ do
    encodedDINode <- encodeM (diNode :: DINode)
    decodedDINode <- liftIO (runDecodeAST (decodeM (encodedDINode :: Ptr FFI.DINode)))
    pure (decodedDINode === diNode)

roundtripDICompileUnit :: TestTree
roundtripDICompileUnit = testProperty "roundtrip DICompileUnit" $ \diFile retainedType ->
  forAll genDIMacro $ \diMacro ->
  forAll (genDICompileUnit (MDRef fileID) (MDRef retainedID) (MDRef macroID)) $ \diCompileUnit -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [cuID]
                , NamedMetadataDefinition "dummyMacro" [macroID]
                , NamedMetadataDefinition "dummyRetained" [retainedID]
                , MetadataNodeDefinition cuID (DINode (DIScope (DICompileUnit diCompileUnit)))
                , MetadataNodeDefinition macroID (DIMacroNode diMacro)
                , MetadataNodeDefinition retainedID (DINode (DIScope (DIType retainedType)))
                , MetadataNodeDefinition fileID (DINode (DIScope (DIFile diFile)))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where cuID = MetadataNodeID 0
        macroID = MetadataNodeID 1
        retainedID = MetadataNodeID 2
        fileID = MetadataNodeID 3

genDICompileUnit :: MDRef DIFile -> MDRef (Either DIType DISubprogram) -> MDRef DIMacroNode -> Gen DICompileUnit
genDICompileUnit file retained macro =
  CompileUnit
    <$> arbitrary
    <*> pure file
    <*> arbitrarySbs
    <*> arbitrary
    <*> arbitrarySbs
    <*> arbitrary
    <*> arbitrarySbs
    <*> arbitrary
    <*> pure []
    <*> listOf (pure retained)
    <*> pure []
    <*> pure []
    <*> listOf (pure macro)
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary

instance Arbitrary DebugEmissionKind where
  arbitrary = QC.elements [NoDebug, FullDebug, LineTablesOnly]

roundtripDIVariable :: TestTree
roundtripDIVariable = testProperty "roundtrip DIVariable" $ \diFile diType ->
  forAll (genDIVariable Nothing (Just (MDRef fileID)) (Just (MDRef typeID))) $ \diVariable -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [varID]
                , MetadataNodeDefinition varID (DINode (DIVariable diVariable))
                , MetadataNodeDefinition fileID (DINode (DIScope (DIFile diFile)))
                , MetadataNodeDefinition typeID (DINode (DIScope (DIType diType)))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where varID = MetadataNodeID 0
        fileID = MetadataNodeID 1
        typeID = MetadataNodeID 2

genDIVariable :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DIType) -> Gen DIVariable
genDIVariable diScope diFile diType =
  case diScope of
    Nothing -> DIGlobalVariable <$> globalVar
    Just scope -> oneof [DILocalVariable <$> localVar scope, DIGlobalVariable <$> globalVar]
  where
    localVar scope =
      LocalVariable
        <$> arbitrarySbs
        <*> pure scope
        <*> pure diFile
        <*> arbitrary
        <*> pure diType
        <*> genDIFlags
        <*> arbitrary
        <*> arbitrary
    globalVar =
      GlobalVariable
        <$> arbitrarySbs
        <*> pure diScope
        <*> pure diFile
        <*> arbitrary
        <*> pure diType
        <*> arbitrarySbs
        <*> arbitrary
        <*> arbitrary
        <*> pure Nothing
        <*> arbitrary

instance Arbitrary A.DIInheritance where
  arbitrary = QC.elements [A.SingleInheritance, A.MultipleInheritance, A.VirtualInheritance]

instance Arbitrary A.DIAccessibility where
  arbitrary = QC.elements [A.Public, A.Protected, A.Private]

instance Arbitrary A.DIFlag where
  arbitrary =
    oneof
      [ A.Accessibility <$> arbitrary
      , A.InheritanceFlag <$> arbitrary
      , QC.elements
          [ A.FwdDecl
          , A.AppleBlock
          , A.BlockByrefStruct
          , A.VirtualFlag
          , A.Artificial
          , A.Explicit
          , A.Prototyped
          , A.ObjcClassComplete
          , A.ObjectPointer
          , A.Vector
          , A.StaticMember
          , A.LValueReference
          , A.RValueReference
          , A.IntroducedVirtual
          , A.BitField
          , A.NoReturn
          , A.MainSubprogram
          ]
      ]

roundtripDIFlags :: TestTree
roundtripDIFlags =
  testProperty "roundtrip DIFlags" $
  forAll genDIFlags $ \diFlags ->
    let Identity encodedFlags = encodeM diFlags
        Identity decodedFlags = decodeM (encodedFlags :: FFI.DIFlags)
    in decodedFlags === diFlags

genDIFlags :: Gen [DIFlag]
genDIFlags = do
  accessibility <-
    QC.elements [Nothing, Just A.Public, Just A.Protected, Just A.Private]
  inheritance <-
    QC.elements
      [ Nothing
      , Just A.SingleInheritance
      , Just A.MultipleInheritance
      , Just A.VirtualInheritance
      ]
  maybeFlags <- traverse (\f -> QC.elements [Nothing, Just f]) flags
  pure
    (catMaybes
       ((A.Accessibility <$> accessibility) :
        (A.InheritanceFlag <$> inheritance) : maybeFlags))
  where
    flags =
      [ A.FwdDecl
      , A.AppleBlock
      , A.BlockByrefStruct
      , A.VirtualFlag
      , A.Artificial
      , A.Explicit
      , A.Prototyped
      , A.ObjcClassComplete
      , A.ObjectPointer
      , A.Vector
      , A.StaticMember
      , A.LValueReference
      , A.RValueReference
      , A.IntroducedVirtual
      , A.BitField
      , A.NoReturn
      , A.MainSubprogram
      ]

roundtripDISubprogram :: TestTree
roundtripDISubprogram = testProperty "roundtrip DISubprogram" $
  forAll (genDISubprogram Nothing Nothing Nothing Nothing Nothing [] Nothing [] []) $ \diSubprogram -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [subprogramID]
                , MetadataNodeDefinition subprogramID (DINode (DIScope (DILocalScope (DISubprogram diSubprogram))))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where subprogramID = MetadataNodeID 0

genDISubprogram :: Maybe (MDRef DIScope) -> Maybe (MDRef DIFile) -> Maybe (MDRef DISubroutineType) ->
                   Maybe (MDRef DIType) -> Maybe (MDRef DICompileUnit) -> [MDRef DITemplateParameter] ->
                   Maybe (MDRef DISubprogram) ->
                   [MDRef DILocalVariable] -> [MDRef DIType] -> Gen DISubprogram
genDISubprogram scope file type' containingType unit templateParams decl vars thrownTypes =
  Subprogram
    <$> pure scope
    <*> arbitrarySbs
    <*> arbitrarySbs
    <*> pure file
    <*> arbitrary
    <*> pure type'
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> pure containingType
    <*> arbitrary
    <*> arbitrary
    <*> arbitrary
    <*> genDIFlags
    <*> arbitrary
    <*> pure unit
    <*> pure templateParams
    <*> pure decl
    <*> pure vars
    <*> pure thrownTypes

roundtripDILexicalBlockBase :: TestTree
roundtripDILexicalBlockBase = testProperty "roundtrip DILexicalBlockBase" $ \diFile ->
  forAll (genDISubprogram Nothing Nothing Nothing Nothing Nothing [] Nothing [] []) $ \diSubprogram ->
  forAll (genDILexicalBlockBase (MDRef subprogramID) (Just (MDRef fileID))) $ \block -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [blockID]
                , MetadataNodeDefinition blockID (DINode (DIScope (DILocalScope (DILexicalBlockBase block))))
                , MetadataNodeDefinition subprogramID (DINode (DIScope (DILocalScope (DISubprogram diSubprogram))))
                , MetadataNodeDefinition fileID (DINode (DIScope (DIFile diFile)))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where blockID = MetadataNodeID 0
        subprogramID = MetadataNodeID 1
        fileID = MetadataNodeID 2

genDILexicalBlockBase :: MDRef DILocalScope -> Maybe (MDRef DIFile) -> Gen DILexicalBlockBase
genDILexicalBlockBase scope file =
  oneof
    [ DILexicalBlock scope file <$> arbitrary <*> arbitrary
    , DILexicalBlockFile scope file <$> arbitrary
    ]

instance Arbitrary Virtuality where
  arbitrary = QC.elements [A.NoVirtuality, A.Virtual, A.PureVirtual]

roundtripDITemplateParameter :: TestTree
roundtripDITemplateParameter = testProperty "rountrip DITemplateParameter" $ \diType ->
  forAll (genDITemplateParameter (MDValue (ConstantOperand (C.Int 32 1))) (MDRef tyID)) $ \param -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [paramID]
                , MetadataNodeDefinition paramID (DINode (DITemplateParameter param))
                , MetadataNodeDefinition tyID (DINode (DIScope (DIType diType)))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where paramID = MetadataNodeID 0
        tyID = MetadataNodeID 1

instance Arbitrary TemplateValueParameterTag where
  arbitrary = QC.elements [TemplateValueParameter, GNUTemplateTemplateParam, GNUTemplateParameterPack]

genDITemplateParameter :: Metadata -> MDRef DIType -> Gen DITemplateParameter
genDITemplateParameter value ty =
  oneof [ DITemplateTypeParameter <$> arbitrarySbs <*> pure ty
        , DITemplateValueParameter <$> arbitrarySbs <*> pure ty <*> pure value <*> arbitrary
        ]

roundtripDINamespace :: TestTree
roundtripDINamespace = testProperty "rountrip DINamespace" $ \diFile ->
  forAll (genDINamespace (MDRef fileID)) $ \diNamespace -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      let mod = defaultModule
            { moduleDefinitions =
                [ NamedMetadataDefinition "dummy" [namespaceID]
                , NamedMetadataDefinition "dummy2" [fileID]
                , MetadataNodeDefinition namespaceID (DINode (DIScope (DINamespace diNamespace)))
                , MetadataNodeDefinition fileID (DINode (DIScope (DIFile diFile)))
                ]
            }
      mod' <- liftIO (withModuleFromAST context mod moduleAST)
      pure (mod' === mod)
  where namespaceID = MetadataNodeID 0
        fileID = MetadataNodeID 1

genDINamespace :: MDRef DIScope -> Gen DINamespace
genDINamespace scope = Namespace <$> arbitrarySbs <*> QC.elements [Nothing, Just scope] <*> arbitrary

diFlagName :: TestTree
diFlagName =
  testProperty "LLVM and llvm-hs agree on encoding of DIFlag" $ \diFlag ->
    ioProperty $
    withContext $ \context ->
      runEncodeAST context $ do
        encoded <- encodeM [diFlag]
        flagName' <- encodeM ("DIFlag" <> flagName diFlag)
        encodedByName <- liftIO (FFI.getDIFlag flagName')
        pure (encoded === encodedByName)
  where
    flagName (A.Accessibility f) = show f
    flagName (A.InheritanceFlag f) = show f
    flagName A.VirtualFlag = "Virtual"
    flagName f = show f

roundtripDIExpression :: TestTree
roundtripDIExpression = testProperty "roundtrip DIExpression" $
  forAll genDIExpression $ \expr -> ioProperty $
    withContext $ \context -> runEncodeAST context $ do
      encodedExpr <- encodeM expr
      decodedExpr <- liftIO (runDecodeAST (decodeM (encodedExpr :: Ptr FFI.DIExpression)))
      pure (decodedExpr === expr)

genDIExpression :: Gen DIExpression
genDIExpression = Expression <$> arbitrary

instance Arbitrary DWOp where
  arbitrary =
    oneof
      [ DwOpFragment <$> (DW_OP_LLVM_Fragment <$> arbitrary <*> arbitrary)
      , pure DW_OP_StackValue
      , pure DW_OP_Swap
      , DW_OP_ConstU <$> arbitrary
      , DW_OP_PlusUConst <$> arbitrary
      , pure DW_OP_Plus
      , pure DW_OP_Minus
      , pure DW_OP_Mul
      , pure DW_OP_Deref
      , pure DW_OP_XDeref
      ]

testFile :: TestTree
testFile = do
  testGroup "file parsing and decoding"
    [ testCase "test/debug_metadata_1.ll" $ do
        fStr <- B.readFile "test/debug_metadata_1.ll"
        withContext $ \context -> do
          a <- withModuleFromLLVMAssembly' context fStr moduleAST
          pure ()
    ,  testCase "test/debug_metadata_2.ll" $ do
         fStr <- B.readFile "test/debug_metadata_2.ll"
         withContext $ \context -> do
           a <- withModuleFromLLVMAssembly' context fStr moduleAST
           pure ()
    ]

globalMetadata = testCase "global" $ do
    let ast = Module "<string>" "<string>" Nothing Nothing [
          GlobalDefinition $ functionDefaults {
            G.returnType = i32,
            G.name = Name "foo",
            G.basicBlocks = [
              BasicBlock (UnName 0) [
              ] (
                Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [
                  ("my-metadatum", A.MDRef (MetadataNodeID 0))
                ]
              )
             ]
            },
          MetadataNodeDefinition (MetadataNodeID 0) (MDTuple [ Just $ MDValue $ ConstantOperand (C.Int 32 1) ])
         ]
    let s = "; ModuleID = '<string>'\n\
            \source_filename = \"<string>\"\n\
            \\n\
            \define i32 @foo() {\n\
            \  ret i32 0, !my-metadatum !0\n\
            \}\n\
            \\n\
            \!0 = !{i32 1}\n"
    strCheck ast s

namedMetadata = testCase "named" $ do
    let ast = Module "<string>" "<string>" Nothing Nothing [
          NamedMetadataDefinition "my-module-metadata" [ MetadataNodeID 0 ],
          MetadataNodeDefinition (MetadataNodeID 0) (MDTuple [ Just $ MDValue $ ConstantOperand (C.Int 32 1) ])
         ]
    let s = "; ModuleID = '<string>'\n\
            \source_filename = \"<string>\"\n\
            \\n\
            \!my-module-metadata = !{!0}\n\
            \\n\
            \!0 = !{i32 1}\n"
    strCheck ast s

nullMetadata = testCase "null" $ do
    let ast = Module "<string>" "<string>" Nothing Nothing [
          NamedMetadataDefinition "my-module-metadata" [ MetadataNodeID 0 ],
          MetadataNodeDefinition (MetadataNodeID 0) (MDTuple [ Nothing ])
         ]
    let s = "; ModuleID = '<string>'\n\
            \source_filename = \"<string>\"\n\
            \\n\
            \!my-module-metadata = !{!0}\n\
            \\n\
            \!0 = !{null}\n"
    strCheck ast s

cyclicMetadata = testGroup "cyclic" [
    testCase "metadata-only" $ do
      let ast = Module "<string>" "<string>" Nothing Nothing [
            NamedMetadataDefinition "my-module-metadata" [MetadataNodeID 0],
            MetadataNodeDefinition
              (MetadataNodeID 0)
              (MDTuple [Just $ MDNode (MDRef (MetadataNodeID 1))]),
            MetadataNodeDefinition
              (MetadataNodeID 1)
              (MDTuple [Just $ MDNode (MDRef (MetadataNodeID 0))])
           ]
      let s = "; ModuleID = '<string>'\n\
              \source_filename = \"<string>\"\n\
              \\n\
              \!my-module-metadata = !{!0}\n\
              \\n\
              \!0 = !{!1}\n\
              \!1 = !{!0}\n"
      strCheck ast s,

    testCase "metadata-global" $ do
      let ast = Module "<string>" "<string>" Nothing Nothing [
            GlobalDefinition $ functionDefaults {
              G.returnType = A.T.void,
              G.name = Name "foo",
              G.basicBlocks = [
                BasicBlock (UnName 0) [
                 ] (
                   Do $ Ret Nothing [ ("my-metadatum", MDRef (MetadataNodeID 0)) ]
                 )
               ]
             },
            MetadataNodeDefinition
              (MetadataNodeID 0)
              (MDTuple [Just $ MDValue $ ConstantOperand (C.GlobalReference (ptr (FunctionType A.T.void [] False)) (Name "foo"))])
           ]
      let s = "; ModuleID = '<string>'\n\
              \source_filename = \"<string>\"\n\
              \\n\
              \define void @foo() {\n\
              \  ret void, !my-metadatum !0\n\
              \}\n\
              \\n\
              \!0 = !{void ()* @foo}\n"
      strCheck ast s
   ]

globalObjectMetadata = testGroup "Metadata on GlobalObject" $
  [ testCase "metadata on functions" $ do
      let ast = Module "<string>" "<string>" Nothing Nothing
                  [ GlobalDefinition
                      functionDefaults
                        { G.name = "main"
                        , G.returnType = A.T.void
                        , basicBlocks = [ BasicBlock (UnName 0) [] (Do (Ret Nothing [])) ]
                        , G.metadata = [("dbg", MDRef (MetadataNodeID 0))]
                        }
                  , NamedMetadataDefinition "llvm.module.flags" [MetadataNodeID 1]
                  , NamedMetadataDefinition "llvm.dbg.cu" [MetadataNodeID 2]
                  , MetadataNodeDefinition (MetadataNodeID 0) $
                    DINode .DIScope .DILocalScope . DISubprogram $
                    Subprogram
                      { scope = Nothing
                      , name = "main"
                      , linkageName = ""
                      , file = Nothing
                      , line = 0
                      , type' = Nothing
                      , localToUnit = False
                      , definition = True
                      , scopeLine = 0
                      , containingType = Nothing
                      , virtuality = NoVirtuality
                      , virtualityIndex = 0
                      , thisAdjustment = 0
                      , flags = []
                      , optimized = False
                      , unit = Just (MDRef (MetadataNodeID 2))
                      , O.templateParams = []
                      , declaration = Nothing
                      , variables = []
                      , thrownTypes = []
                      }
                  , MetadataNodeDefinition (MetadataNodeID 1)
                    (MDTuple [ Just (MDValue (ConstantOperand (C.Int 32 2)))
                             , Just (MDString "Debug Info Version")
                             , Just (MDValue (ConstantOperand (C.Int 32 3)))
                             ])
                  , MetadataNodeDefinition (MetadataNodeID 2) $
                    DINode . DIScope . DICompileUnit $
                    CompileUnit
                      { language = 12
                      , file = MDRef (MetadataNodeID 3)
                      , producer = "clang version 6.0.0 (tags/RELEASE_600/final)"
                      , optimized = True
                      , flags = ""
                      , runtimeVersion = 0
                      , splitDebugFileName = ""
                      , emissionKind = FullDebug
                      , enums = []
                      , retainedTypes = []
                      , globals = []
                      , imports = []
                      , macros = []
                      , dWOId = 0
                      , splitDebugInlining = True
                      , debugInfoForProfiling = False
                      , gnuPubnames = False
                      }
                  , MetadataNodeDefinition (MetadataNodeID 3) $
                    DINode . DIScope . DIFile $
                    O.File "main.c" "/" "" None
                  ]
          s =
            "; ModuleID = '<string>'\n\
            \source_filename = \"<string>\"\n\
            \\n\
            \define void @main() !dbg !3 {\n\
            \  ret void\n\
            \}\n\
            \\n\
            \!llvm.module.flags = !{!0}\n\
            \!llvm.dbg.cu = !{!1}\n\
            \\n\
            \!0 = !{i32 2, !\"Debug Info Version\", i32 3}\n\
            \!1 = distinct !DICompileUnit(language: DW_LANG_C99, file: !2, producer: \"clang version 6.0.0 (tags/RELEASE_600/final)\", isOptimized: true, runtimeVersion: 0, emissionKind: FullDebug)\n\
            \!2 = !DIFile(filename: \"main.c\", directory: \"/\")\n\
            \!3 = distinct !DISubprogram(name: \"main\", scope: null, isLocal: false, isDefinition: true, isOptimized: false, unit: !1)\n"
      strCheck ast s,
   testCase "metadata on global variables" $ do
      let ast = Module "<string>" "<string>" Nothing Nothing
                  [ GlobalDefinition
                      globalVariableDefaults
                        { G.name = "g"
                        , G.type' = A.T.i32
                        , G.linkage = L.Common
                        , G.alignment = 4
                        , G.initializer = Just (C.Int 32 0)
                        , G.metadata = [("dbg", MDRef (MetadataNodeID 0))]
                        }
                  , NamedMetadataDefinition "llvm.module.flags" [MetadataNodeID 1]
                  , NamedMetadataDefinition "llvm.dbg.cu" [MetadataNodeID 2]
                  , MetadataNodeDefinition (MetadataNodeID 0) $
                    DIGlobalVariableExpression $ GlobalVariableExpression (MDRef (MetadataNodeID 3)) (MDRef (MetadataNodeID 4))
                  , MetadataNodeDefinition (MetadataNodeID 1)
                    (MDTuple [ Just (MDValue (ConstantOperand (C.Int 32 2)))
                             , Just (MDString "Debug Info Version")
                             , Just (MDValue (ConstantOperand (C.Int 32 3)))
                             ])
                  , MetadataNodeDefinition (MetadataNodeID 2) $
                    DINode . DIScope . DICompileUnit $
                    CompileUnit
                      { language = 12
                      , file = MDRef (MetadataNodeID 5)
                      , producer = "clang version 6.0.0 (tags/RELEASE_600/final)"
                      , optimized = True
                      , flags = ""
                      , runtimeVersion = 0
                      , splitDebugFileName = ""
                      , emissionKind = FullDebug
                      , enums = []
                      , retainedTypes = []
                      , globals = []
                      , imports = []
                      , macros = []
                      , dWOId = 0
                      , splitDebugInlining = True
                      , debugInfoForProfiling = False
                      , gnuPubnames = False
                      }
                  , MetadataNodeDefinition (MetadataNodeID 3) $
                    DINode . DIVariable . DIGlobalVariable $
                    GlobalVariable
                      { name = "g"
                      , scope = Nothing
                      , file = Nothing
                      , line = 0
                      , type' = Just (MDRef (MetadataNodeID 6))
                      , linkageName = ""
                      , local = False
                      , definition = True
                      , staticDataMemberDeclaration = Nothing
                      , alignInBits = 0
                      }
                  , MetadataNodeDefinition (MetadataNodeID 4) (DIExpression (Expression []))
                  , MetadataNodeDefinition (MetadataNodeID 5) $
                    DINode . DIScope . DIFile $
                    O.File "main.c" "/" "" None
                  , MetadataNodeDefinition (MetadataNodeID 6) $
                    DINode . DIScope . DIType . DIBasicType $
                    BasicType "" 0 0 Nothing BaseType
                  ]
          s =
            "; ModuleID = '<string>'\n\
            \source_filename = \"<string>\"\n\
            \\n\
            \@g = common global i32 0, align 4, !dbg !0\n\
            \\n\
            \!llvm.module.flags = !{!3}\n\
            \!llvm.dbg.cu = !{!4}\n\
            \\n\
            \!0 = !DIGlobalVariableExpression(var: !1, expr: !DIExpression())\n\
            \!1 = !DIGlobalVariable(name: \"g\", scope: null, type: !2, isLocal: false, isDefinition: true)\n\
            \!2 = !DIBasicType()\n\
            \!3 = !{i32 2, !\"Debug Info Version\", i32 3}\n\
            \!4 = distinct !DICompileUnit(language: DW_LANG_C99, file: !5, producer: \"clang version 6.0.0 (tags/RELEASE_600/final)\", isOptimized: true, runtimeVersion: 0, emissionKind: FullDebug)\n\
            \!5 = !DIFile(filename: \"main.c\", directory: \"/\")\n"
      strCheck ast s
  ]