From e2dfe388ccb346fc88d8e3c9adce5b86d01e5874 Mon Sep 17 00:00:00 2001
From: Langston Barrett <langston.barrett@gmail.com>
Date: Tue, 27 Sep 2022 11:20:57 -0400
Subject: [PATCH] Parse target triples

---
 src/Data/LLVM/BitCode/IR/Module.hs | 10 ++++++++--
 unit-test/Tests/Instances.hs       |  9 +++++++++
 2 files changed, 17 insertions(+), 2 deletions(-)

diff --git a/src/Data/LLVM/BitCode/IR/Module.hs b/src/Data/LLVM/BitCode/IR/Module.hs
index 6055993f..c9558337 100644
--- a/src/Data/LLVM/BitCode/IR/Module.hs
+++ b/src/Data/LLVM/BitCode/IR/Module.hs
@@ -16,6 +16,8 @@ import Data.LLVM.BitCode.Match
 import Data.LLVM.BitCode.Parse
 import Data.LLVM.BitCode.Record
 import Text.LLVM.AST
+import Text.LLVM.Triple.AST (TargetTriple)
+import Text.LLVM.Triple.Parse (parseTriple)
 
 import qualified Codec.Binary.UTF8.String as UTF8 (decode)
 import Control.Monad (foldM,guard,when,forM_)
@@ -34,6 +36,7 @@ data PartialModule = PartialModule
   , partialGlobals    :: GlobalList
   , partialDefines    :: DefineList
   , partialDeclares   :: DeclareList
+  , partialTriple     :: TargetTriple
   , partialDataLayout :: DataLayout
   , partialInlineAsm  :: InlineAsm
   , partialComdat     :: !(Seq (String,SelectionKind))
@@ -51,6 +54,7 @@ emptyPartialModule  = PartialModule
   , partialGlobals    = mempty
   , partialDefines    = mempty
   , partialDeclares   = mempty
+  , partialTriple     = mempty
   , partialDataLayout = mempty
   , partialInlineAsm  = mempty
   , partialAliasIx    = 0
@@ -75,6 +79,7 @@ finalizeModule pm = label "finalizeModule" $ do
   defines <- T.mapM (finalizePartialDefine lkp) (partialDefines pm)
   return emptyModule
     { modSourceName = partialSourceName pm
+    , modTriple     = partialTriple pm
     , modDataLayout = partialDataLayout pm
     , modNamedMd    = F.toList (partialNamedMd pm)
     , modUnnamedMd  = sortOn umIndex (F.toList unnamed)
@@ -167,9 +172,10 @@ parseModuleBlockEntry pm (valueSymtabBlockId -> Just _es) = do
   -- MODULE_BLOCK
   return pm
 
-parseModuleBlockEntry pm (moduleCodeTriple -> Just _) = do
+parseModuleBlockEntry pm (moduleCodeTriple -> Just r) = do
   -- MODULE_CODE_TRIPLE
-  return pm
+  triple <- UTF8.decode <$> parseFields r 0 char
+  return (pm { partialTriple = parseTriple triple })
 
 parseModuleBlockEntry pm (moduleCodeDatalayout -> Just r) = do
   -- MODULE_CODE_DATALAYOUT
diff --git a/unit-test/Tests/Instances.hs b/unit-test/Tests/Instances.hs
index d71d17de..98430591 100644
--- a/unit-test/Tests/Instances.hs
+++ b/unit-test/Tests/Instances.hs
@@ -9,10 +9,19 @@ import Test.QuickCheck.Arbitrary (Arbitrary(..))
 
 import Data.LLVM.Internal
 import Text.LLVM.AST
+import qualified Text.LLVM.Triple.AST as Triple
 
 -------------------------------------------------------------------------
 -- ** llvm-pretty
 
+instance Arbitrary Triple.Arch where arbitrary = genericArbitrary uniform
+instance Arbitrary Triple.Environment where arbitrary = genericArbitrary uniform
+instance Arbitrary Triple.OS where arbitrary = genericArbitrary uniform
+instance Arbitrary Triple.ObjectFormat where arbitrary = genericArbitrary uniform
+instance Arbitrary Triple.SubArch where arbitrary = genericArbitrary uniform
+instance Arbitrary Triple.TargetTriple where arbitrary = genericArbitrary uniform
+instance Arbitrary Triple.Vendor where arbitrary = genericArbitrary uniform
+
 instance Arbitrary Module                                             where arbitrary = genericArbitrary uniform
 instance Arbitrary NamedMd                                            where arbitrary = genericArbitrary uniform
 instance Arbitrary UnnamedMd                                          where arbitrary = genericArbitrary uniform