llvm-hs-pretty (empty) → 0.1.0.0
raw patch · 7 files changed
+1192/−0 lines, 7 filesdep +arraydep +basedep +bytestring
Dependencies added: array, base, bytestring, directory, filepath, llvm-hs, llvm-hs-pretty, llvm-hs-pure, mtl, pretty-show, tasty, tasty-golden, tasty-hspec, tasty-hunit, text, transformers, wl-pprint-text
Files
- LICENSE +21/−0
- README.md +147/−0
- llvm-hs-pretty.cabal +57/−0
- src/LLVM/Pretty.hs +785/−0
- src/LLVM/Token.hs +3/−0
- src/LLVM/Typed.hs +123/−0
- tests/Main.hs +56/−0
+ LICENSE view
@@ -0,0 +1,21 @@+Copyright (c) 2014-2017 Stephen Diehl+Copyright (c) 2015 Cedric Shock++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,147 @@+llvm-hs-pretty+--------------++[](https://travis-ci.org/llvm-hs/llvm-hs-pretty)++A pretty printer for ``llvm-hs-pure``. Goal is to be able to pretty print a+sufficiently large subset of the LLVM AST from pure Haskell without having to go+through the C++ API.++Usage+-----++```bash+sudo apt-get install llvm-dev-5.0+```++There is a single function ``ppllvm`` that maps a LLVM.AST.Module to a+String.++```haskell+import LLVM.AST+import LLVM.Pretty (ppllvm)++ppllvm :: Module -> Text+```++Tests+-----++The test suite currently consists of round tripping a LLVM IR from correct IR+outputted by the llc toolchain, parsing into llvm-general AST and then printing+it back out and comparing it with the original textual form to see if the pretty+printer faithfully preserves the structure. The sample modules are in+``tests/``.++Using stack:++```bash+$ stac build+$ stack test+```++Using cabal:++```bash+$ cabal run+$ cabal run -- tests/simple.ll+```++If you're using Nix then:++```bash+$ nix-shell+$ cabal run+```++Example+-------++To try out the standalone example run:++```bash+$ stack repl+$ :load Example.hs+main+```++Consider the basic example LLVM module.++```llvm+; ModuleID = 'example-llvm-module'++define i8 @f(i8 %x){+entry:+ ret i8 %x+}+```++Using the LLVM.AST we construct the type and feed it to the pretty+printer.++```haskell+module Standalone where++-- Pretty Printer+import LLVM.Pretty (ppllvm)++-- AST+import qualified LLVM.AST as AST+import qualified LLVM.AST.Linkage as Linkage+import qualified LLVM.AST.Visibility as Visibility+import qualified LLVM.AST.CallingConvention as Convention++import Data.Text.Lazy.IO as TIO++astModule :: AST.Module+astModule = AST.Module+ { AST.moduleName = "example-llvm-module"+ , AST.moduleDataLayout = Nothing+ , AST.moduleTargetTriple = Nothing+ , AST.moduleDefinitions =+ [ AST.GlobalDefinition+ (AST.Function+ Linkage.External+ Visibility.Default+ Nothing+ Convention.C+ []+ (AST.IntegerType 8)+ (AST.Name "f")+ ([AST.Parameter (AST.IntegerType 8) (AST.Name "x") []], False)+ []+ Nothing+ Nothing+ 0+ Nothing+ Nothing+ [ AST.BasicBlock+ (AST.Name "entry")+ []+ (AST.Do+ (AST.Ret+ (Just+ (AST.LocalReference+ (AST.IntegerType 8)+ (AST.Name "x")+ )+ )+ []+ )+ )+ ]+ )+ ]+ }++main :: IO ()+main = TIO.putStrLn (ppllvm astModule)+```++License+-------++Released under the MIT License.++Copyright (c) 2014-2017, Stephen Diehl+Copyright (c) 2015 Cedric Shock
+ llvm-hs-pretty.cabal view
@@ -0,0 +1,57 @@+name: llvm-hs-pretty+version: 0.1.0.0+license: MIT+license-file: LICENSE+author: Stephen Diehl+maintainer: stephen.m.diehl@gmail.com+build-type: Simple+category: Compilers+extra-source-files: README.md+cabal-version: >=1.10+homepage: https://github.com/llvm-hs/llvm-hs-pretty++Synopsis: Pretty printer for LLVM IR.+Description:+ Pretty printer for LLVM IR.++Source-Repository head+ Type: git+ Location: git@github.com:llvm-hs/llvm-hs-pretty.git++library+ hs-source-dirs: src+ exposed-modules: + LLVM.Pretty+ LLVM.Typed+ LLVM.Token+ ghc-options:+ -fwarn-incomplete-patterns+ default-language: Haskell2010+ build-depends:+ array >= 0.5,+ base >= 4.6 && < 5.0,+ bytestring >= 0.10,+ llvm-hs-pure >= 5.1,+ text >= 0.1,+ wl-pprint-text >= 1.1++Test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Main.hs+ default-language: Haskell2010+ build-depends: + base >= 4.6 && < 5.0,+ text >= 0.1,+ mtl >= 2.2,+ transformers >= 0.3 && < 0.6,+ directory >= 1.2,+ filepath >= 1.3,+ pretty-show >= 1.6 && < 1.7,+ tasty >= 0.11,+ tasty-hspec >= 1.1,+ tasty-hunit -any,+ tasty-golden >= 1.1,+ llvm-hs-pretty -any,+ llvm-hs >= 5.1,+ llvm-hs-pure >= 5.0
+ src/LLVM/Pretty.hs view
@@ -0,0 +1,785 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}++module LLVM.Pretty (+ ppllvm,+ ppll,+) where++import Prelude hiding ((<$>))+import GHC.Word++import LLVM.Typed++import LLVM.AST+import LLVM.AST.Global+import LLVM.AST.Type++import LLVM.AST.Attribute+import LLVM.AST.COMDAT+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 qualified LLVM.AST.FloatingPointPredicate as FP+import qualified LLVM.AST.IntegerPredicate as IP+import qualified LLVM.AST.AddrSpace as AS+import qualified LLVM.AST.Float as F+import qualified LLVM.AST.RMWOperation as RMW+import LLVM.AST.ParameterAttribute as PA+import LLVM.AST.FunctionAttribute as FA++import Data.String++import Text.Printf+import Data.Text.Lazy.Encoding+import Data.Text.Lazy (Text, pack, unpack)+import qualified Data.ByteString.Short as SBF+import qualified Data.ByteString.Lazy.Char8 as BF+import Data.ByteString.Lazy (fromStrict)+import Data.ByteString.Internal (w2c)+import Text.PrettyPrint.Leijen.Text++import qualified Data.ByteString.Char8 as BL+import qualified Data.ByteString.Short as BS+import Data.Char (chr, ord, isAscii, isControl, isLetter, isDigit)+import Data.Foldable (toList)+import Data.List (intersperse)+import Data.Maybe (isJust)+import Numeric (showHex)++import Data.Array.Unsafe+import Data.Array.MArray+import Data.Array.ST+import Control.Monad.ST++-------------------------------------------------------------------------------+-- Utils+-------------------------------------------------------------------------------++parensIf :: Bool -> Doc -> Doc+parensIf True = parens+parensIf False = id++commas :: [Doc] -> Doc+commas = hsep . punctuate (char ',')++colons :: [Doc] -> Doc+colons = hcat . intersperse (char ':')++hlinecat :: [Doc] -> Doc+hlinecat = vcat . intersperse softbreak++wrapbraces :: Doc -> Doc -> Doc+wrapbraces leadIn x = (leadIn <> char '{') <$> x <$> char '}'++angleBrackets :: Doc -> Doc+angleBrackets x = char '<' <> x <> char '>'++spacedbraces :: Doc -> Doc+spacedbraces x = char '{' <+> x <+> char '}'++local :: Doc -> Doc+local a = "%" <> a++global :: Doc -> Doc+global a = "@" <> a++label :: Doc -> Doc+label a = "label" <+> "%" <> a++cma :: Doc -> Doc -> Doc -- <,> does not work :(+a `cma` b = a <> "," <+> b++-------------------------------------------------------------------------------+-- Classes+-------------------------------------------------------------------------------++class PP p where+ pp :: p -> Doc++ppMaybe :: PP a => Maybe a -> Doc+ppMaybe (Just x) = pp x+ppMaybe Nothing = empty++ppBool :: Doc -> Bool -> Doc+ppBool x True = x+ppBool x False = empty++-- XXX: horrible hack+unShort :: BS.ShortByteString -> [Char]+unShort xs = fmap (toEnum . fromIntegral) $ BS.unpack xs++short :: BS.ShortByteString -> Doc+short x = string (pack (unShort x))++decodeShortUtf8 :: SBF.ShortByteString -> Text+decodeShortUtf8 = decodeUtf8 . fromStrict . SBF.fromShort++instance PP Word32 where+ pp x = int (fromIntegral x)++instance PP Word64 where+ pp x = int (fromIntegral x)++instance PP Integer where+ pp = integer++instance PP Name where+ pp (Name nm)+ | BS.null nm = dquotes empty+ | isFirst first && all isRest name = text (pack name)+ | otherwise = dquotes . 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) = int (fromIntegral x)++instance PP Parameter where+ pp (Parameter ty (UnName _) attrs) = pp ty <+> pp attrs+ pp (Parameter ty name attrs) = pp ty <+> 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 width) = "i" <> pp width+ pp (FloatingPointType HalfFP) = "half"+ pp (FloatingPointType FloatFP ) = "float"+ pp (FloatingPointType DoubleFP) = "double"+ pp (FloatingPointType FP128FP) = "fp128"+ pp (FloatingPointType X86_FP80FP) = "x86_fp80"+ pp (FloatingPointType PPC_FP128FP) = "ppc_fp128"++ pp VoidType = "void"+ pp (PointerType ref (AS.AddrSpace addr))+ | addr == 0 = pp ref <> "*"+ | otherwise = pp ref <+> "addrspace" <> parens (pp addr) <> "*"+ pp ft@(FunctionType {..}) = pp resultType <+> ppFunctionArgumentTypes ft+ pp (VectorType {..}) = "<" <> pp nVectorElements <+> "x" <+> pp elementType <> ">"+ pp (StructureType {..}) = if isPacked+ then "<{" <> (commas $ fmap pp elementTypes ) <> "}>"+ else "{" <> (commas $ fmap pp elementTypes ) <> "}"+ pp (ArrayType {..}) = brackets $ pp nArrayElements <+> "x" <+> pp elementType+ pp (NamedTypeReference name) = "%" <> pp name+ pp MetadataType = "metadata"+ pp TokenType = "token"+ pp LabelType = "label"++instance PP Global where+ pp Function {..} =+ case basicBlocks of+ [] ->+ ("declare" <+> pp linkage <+> pp callingConvention+ <+> pp returnAttributes <+> pp returnType <+> global (pp name)+ <> ppParams (pp . typeOf) parameters <+> pp functionAttributes <+> align <+> gcName)++ -- single unnamed block is special cased, and won't parse otherwise... yeah good times+ [b@(BasicBlock (UnName _) _ _)] ->+ ("define" <+> pp linkage <+> pp callingConvention+ <+> pp returnAttributes <+> pp returnType <+> global (pp name)+ <> ppParams pp parameters <+> pp functionAttributes <+> align <+> gcName)+ `wrapbraces` (indent 2 $ ppSingleBlock b)++ bs ->+ ("define" <+> pp linkage <+> pp callingConvention+ <+> pp returnAttributes <+> pp returnType <+> global (pp name)+ <> ppParams pp parameters <+> pp functionAttributes <+> align <+> gcName)+ `wrapbraces` (vcat $ fmap pp bs)+ where+ align | alignment == 0 = empty+ | otherwise = "align" <+> pp alignment+ gcName = maybe empty (\n -> "gc" <+> dquotes (text $ pack n)) (fmap unShort 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 -> "addrspace" <> parens (pp addr)+ kind | isConstant = "constant"+ | otherwise = "global"++ pp GlobalAlias {..} = global (pp name) <+> "=" <+> pp linkage <+> ppMaybe unnamedAddr <+> "alias" <+> pp typ `cma` ppTyped aliasee+ where+ typ = getElementType type'++ppMetadata :: Maybe Metadata -> Doc+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) = "module asm" <+> dquotes (text (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 :: FunctionAttribute -> Doc+ppAttrInGroup = \case+ StackAlignment n -> "alignstack=" <> pp n+ attr -> pp attr++instance PP FunctionAttribute where+ pp = \case+ NoReturn -> "noreturn"+ NoUnwind -> "nounwind"+ FA.ReadNone -> "readnone"+ FA.ReadOnly -> "readonly"+ FA.WriteOnly -> "writeonly"+ NoInline -> "noinline"+ AlwaysInline -> "alwaysinline"+ MinimizeSize -> "minsize"+ OptimizeForSize -> "optsize"+ OptimizeNone -> "optnone"+ SafeStack -> "safestack"+ StackProtect -> "ssp"+ StackProtectReq -> "sspreq"+ StackProtectStrong -> "sspstrong"+ NoRedZone -> "noredzone"+ NoImplicitFloat -> "noimplicitfloat"+ Naked -> "naked"+ InlineHint -> "inlinehint"+ StackAlignment n -> "alignstack" <> parens (pp n)+ ReturnsTwice -> "returns_twice"+ UWTable -> "uwtable"+ NonLazyBind -> "nonlazybind"+ Builtin -> "builtin"+ NoBuiltin -> "nobuiltin"+ Cold -> "cold"+ JumpTable -> "jumptable"+ NoDuplicate -> "noduplicate"+ SanitizeAddress -> "sanitize_address"+ SanitizeThread -> "sanitize_thread"+ SanitizeMemory -> "sanitize_memory"+ NoRecurse -> "norecurse"+ Convergent -> "convergent"+ ArgMemOnly -> "argmemonly"+ InaccessibleMemOnly -> "inaccessiblememonly"+ AllocSize a Nothing -> "allocsize" <> parens (pp a)+ AllocSize a (Just b) -> "allocsize" <> parens (commas [pp a, pp b])+ InaccessibleMemOrArgMemOnly -> "inaccessiblemem_or_argmemonly"+ FA.StringAttribute k v -> dquotes (short k) <> "=" <> dquotes (short v)+ Speculatable -> "speculatable"++instance PP ParameterAttribute where+ pp = \case+ ZeroExt -> "zeroext"+ SignExt -> "signext"+ InReg -> "inreg"+ SRet -> "sret"+ Alignment word -> "align" <+> pp word+ NoAlias -> "noalias"+ ByVal -> "byval"+ NoCapture -> "nocapture"+ Nest -> "nest"+ PA.ReadNone -> "readnone"+ PA.ReadOnly -> "readonly"+ PA.WriteOnly -> "writeonly"+ InAlloca -> "inalloca"+ NonNull -> "nonnull"+ Dereferenceable word -> "dereferenceable" <> parens (pp word)+ DereferenceableOrNull word -> "dereferenceable_or_null" <> parens (pp word)+ Returned -> "returned"+ SwiftSelf -> "swiftself"+ SwiftError -> "swifterror"+ PA.StringAttribute k v -> dquotes (short k) <> "=" <> dquotes (short v)++instance PP CC.CallingConvention where+ pp = \case+ CC.Numbered word -> "cc" <+> pp word+ CC.C -> "ccc"+ CC.Fast -> "fastcc"+ CC.Cold -> "coldcc"+ CC.GHC -> "cc 10"+ CC.HiPE -> "cc 11"+ CC.WebKit_JS -> "webkit_jscc"+ CC.AnyReg -> "anyregcc"+ CC.PreserveMost -> "preserve_mostcc"+ CC.PreserveAll -> "preserve_allcc"+ CC.Swift -> "swiftcc"+ CC.CXX_FastTLS -> "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 -> "x86_intrcc"+ CC.X86_RegCall -> "x86_regcallcc"+ CC.X86_VectorCall -> "x86_vectorcallcc"+ CC.AVR_Intr -> "avr_intrcc"+ CC.AVR_Signal -> "avr_signalcc"+ CC.AVR_Builtin -> "cc 86"+ CC.HHVM -> "hhvmcc"+ CC.HHVM_C -> "hhvm_ccc"+ CC.AMDGPU_VS -> "amdgpu_vs"+ CC.AMDGPU_GS -> "amdgpu_gs"+ CC.AMDGPU_PS -> "amdgpu_ps"+ CC.AMDGPU_CS -> "amdgpu_cs"+ CC.AMDGPU_HS -> "amdgpu_hs"+ CC.AMDGPU_Kernel -> "amdgpu_kernel"+ CC.MSP430_Builtin -> "msp430"++instance PP L.Linkage where+ pp = ppLinkage False++ppLinkage :: Bool -> L.Linkage -> Doc+ppLinkage omitExternal = \case+ L.External | omitExternal -> empty+ | otherwise -> "external"+ L.Private -> "private"+ L.Internal -> "internal"+ L.ExternWeak -> "extern_weak"+ L.AvailableExternally -> "available_externally"+ L.LinkOnce -> "linkonce"+ L.Weak -> "weak"+ L.Common -> "common"+ L.Appending -> "appending"+ L.LinkOnceODR -> "linkonce_odr"+ L.WeakODR -> "weak_odr"++instance PP MetadataNodeID where+ pp (MetadataNodeID x) = "!" <> int (fromIntegral x)++instance PP GroupID where+ pp (GroupID x) = "#" <> int (fromIntegral x)++instance PP BasicBlock where+ pp (BasicBlock nm instrs term) =+ label <$> indent 2 (vcat $ (fmap pp instrs) ++ [pp term])+ where+ label = case nm of+ UnName _ -> "; <label>:" <> pp nm <> ":"+ _ -> pp nm <> ":"++instance PP Terminator where+ pp = \case+ Br dest meta -> "br" <+> label (pp dest)+ Ret val meta -> "ret" <+> maybe "void" ppTyped val+ CondBr cond tdest fdest meta ->+ "br" <+> ppTyped cond+ `cma` label (pp tdest)+ `cma` label (pp fdest)+ Switch {..} -> "switch" <+> ppTyped operand0'+ `cma` label (pp defaultDest)+ <+> brackets (hsep [ ppTyped v `cma` label (pp l) | (v,l) <- dests ])+ Unreachable {..} -> "unreachable"+ IndirectBr op dests meta -> "indirectbr" <+> ppTyped op `cma`+ brackets (hsep [ label (pp l) | l <- dests ])++ e @ Invoke {..} ->+ ppInvoke e+ <+> "to" <+> label (pp returnDest)+ <+> "unwind" <+> label (pp exceptionDest)+ Resume op meta -> "resume "<+> ppTyped op+ CleanupRet pad dest meta ->+ "cleanupret" <+> "from" <+> pp pad <+> "unwind" <+> maybe "to caller" (label . pp) dest+ CatchRet catchPad succ meta ->+ "catchret" <+> "from" <+> pp catchPad <+> "to" <+> label (pp succ)+ CatchSwitch {..} ->+ "catchswitch" <+> "within" <+> pp parentPad' <+>+ brackets (commas (map (label . pp) (toList catchHandlers))) <+>+ "unwind" <+> "to" <+> maybe "caller" pp defaultUnwindDest++instance PP Instruction where+ pp = \case+ Add {..} -> "add" <+> ppTyped operand0 `cma` pp operand1+ Sub {..} -> "sub" <+> ppTyped operand0 `cma` pp operand1+ Mul {..} -> "mul" <+> ppTyped operand0 `cma` pp operand1+ Shl {..} -> "shl" <+> ppTyped operand0 `cma` pp operand1+ AShr {..} -> "ashr" <+> ppTyped operand0 `cma` pp operand1+ LShr {..} -> "lshr" <+> ppTyped operand0 `cma` pp operand1+ And {..} -> "and" <+> ppTyped operand0 `cma` pp operand1+ Or {..} -> "or" <+> ppTyped operand0 `cma` pp operand1+ Xor {..} -> "xor" <+> ppTyped operand0 `cma` pp operand1+ SDiv {..} -> "sdiv" <+> ppTyped operand0 `cma` pp operand1+ UDiv {..} -> "udiv" <+> ppTyped operand0 `cma` pp operand1+ SRem {..} -> "srem" <+> ppTyped operand0 `cma` pp operand1+ URem {..} -> "urem" <+> ppTyped operand0 `cma` pp operand1++ FAdd {..} -> "fadd" <+> ppTyped operand0 `cma` pp operand1+ FSub {..} -> "fsub" <+> ppTyped operand0 `cma` pp operand1+ FMul {..} -> "fmul" <+> ppTyped operand0 `cma` pp operand1+ FDiv {..} -> "fdiv" <+> ppTyped operand0 `cma` pp operand1+ FRem {..} -> "frem" <+> ppTyped operand0 `cma` pp operand1+ FCmp {..} -> "fcmp" <+> pp fpPredicate <+> ppTyped operand0 `cma` pp operand1++ Alloca {..} -> "alloca" <+> pp allocatedType <> num <> ppAlign alignment+ where num = case numElements of Nothing -> empty+ Just o -> "," <+> ppTyped o+ Store {..} -> "store" <+> ppTyped value `cma` ppTyped address <> ppAlign alignment+ Load {..} -> "load" <+> pp argTy `cma` ppTyped address <> ppAlign alignment+ where PointerType argTy _ = typeOf address+ Phi {..} -> "phi" <+> pp type' <+> commas (fmap phiIncoming incomingValues)++ ICmp {..} -> "icmp" <+> pp iPredicate <+> ppTyped operand0 `cma` pp operand1++ c@Call {..} -> ppCall c+ Select {..} -> "select" <+> commas [ppTyped condition', ppTyped trueValue, ppTyped falseValue]+ SExt {..} -> "sext" <+> ppTyped operand0 <+> "to" <+> pp type'+ ZExt {..} -> "zext" <+> ppTyped operand0 <+> "to" <+> pp type'+ FPExt {..} -> "fpext" <+> ppTyped operand0 <+> "to" <+> pp type'+ Trunc {..} -> "trunc" <+> ppTyped operand0 <+> "to" <+> pp type'+ FPTrunc {..} -> "fptrunc" <+> ppTyped operand0 <+> "to" <+> pp type'++ GetElementPtr {..} -> "getelementptr" <+> bounds inBounds <+> commas (pp argTy : fmap ppTyped (address:indices))+ where argTy = getElementType $ typeOf address+ ExtractValue {..} -> "extractvalue" <+> commas (ppTyped aggregate : fmap pp indices')++ BitCast {..} -> "bitcast" <+> ppTyped operand0 <+> "to" <+> pp type'+ FPToUI {..} -> "fptoui" <+> ppTyped operand0 <+> "to" <+> pp type'+ FPToSI {..} -> "fptosi" <+> ppTyped operand0 <+> "to" <+> pp type'+ UIToFP {..} -> "uitofp" <+> ppTyped operand0 <+> "to" <+> pp type'+ SIToFP {..} -> "sitofp" <+> ppTyped operand0 <+> "to" <+> pp type'+ PtrToInt {..} -> "ptrtoint" <+> ppTyped operand0 <+> "to" <+> pp type'+ IntToPtr {..} -> "inttoptr" <+> ppTyped operand0 <+> "to" <+> pp type'++ InsertElement {..} -> "insertelement" <+> commas [ppTyped vector, ppTyped element, ppTyped index]+ ShuffleVector {..} -> "shufflevector" <+> commas [ppTyped operand0, ppTyped operand1, ppTyped mask]+ ExtractElement {..} -> "extractelement" <+> commas [ppTyped vector, ppTyped index]+ InsertValue {..} -> "insertvalue" <+> commas (ppTyped aggregate : ppTyped element : fmap pp indices')++ Fence {..} -> "fence" <+> pp atomicity+ AtomicRMW {..} -> "atomicrmw" <+> ppVolatile volatile <+> pp rmwOperation <+> ppTyped address `cma` ppTyped value <+> pp atomicity+ CmpXchg {..} -> "cmpxchg" <+> ppVolatile volatile <+> ppTyped address `cma` ppTyped expected `cma` ppTyped replacement+ <+> pp atomicity <+> pp failureMemoryOrdering++ AddrSpaceCast {..} -> "addrspacecast" <+> ppTyped operand0 <+> "to" <+> pp type'+ VAArg {..} -> "va_arg" <+> ppTyped argList `cma` pp type'++ LandingPad {..} ->+ "landingpad" <+> pp type' <+> ppBool "cleanup" cleanup+ <+> commas (fmap pp clauses)+ CatchPad {..} -> "catchpad" <+> "within" <+> pp catchSwitch <+> brackets (commas (map ppTyped args))+ CleanupPad {..} -> "cleanuppad" <+> "within" <+> pp parentPad <+> brackets (commas (map ppTyped args))++ where+ bounds True = "inbounds"+ bounds False = empty++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) = "!" <> dquotes (text (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" <> (text . pack) (showHex (doubleToWord val) "")+ else text $ pack $ printf "%6.6e" val+ pp (C.Float (F.Single val)) =+ if specialFP val+ then "0x" <> (text . pack) (showHex (floatToWord val) "")+ else text $ pack $ printf "%6.6e" val+ pp (C.Float (F.Half val)) = text $ pack $ printf "%6.6e" val+ pp (C.Float (F.Quadruple val _)) = text $ pack $ printf "%6.6e" val+ pp (C.Float (F.X86_FP80 val _)) = text $ pack $ printf "%6.6e" val+ pp (C.Float (F.PPC_FP128 val _)) = text $ pack $ printf "%6.6e" val++ 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 {}) = "zeroinitializer"+ 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" <> (dquotes $ 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 = empty++ 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) = "%" <> pp nm <+> "=" <+> pp a+ pp (Do a) = pp a++instance PP Module where+ pp Module {..} =+ let header = printf "; ModuleID = '%s'" (unShort moduleName) in+ hlinecat (fromString header : (fmap pp moduleDefinitions))++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(\"singlethreaded\")"+ 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"++-------------------------------------------------------------------------------+-- Special Case Hacks+-------------------------------------------------------------------------------++escape :: Char -> Doc+escape '"' = "\\22"+escape '\\' = "\\\\"+escape c = if isAscii c && not (isControl c)+ then char c+ else "\\" <> hex c+ where+ hex :: Char -> Doc+ hex = pad0 . ($ []) . showHex . ord+ pad0 :: String -> Doc+ pad0 [] = "00"+ pad0 [x] = "0" <> char x+ pad0 xs = text (pack xs)++ppVolatile :: Bool -> Doc+ppVolatile True = "volatile"+ppVolatile False = mempty++ppIntAsChar :: Integral a => a -> Doc+ppIntAsChar = escape . chr . fromIntegral++ppAlign :: Word32 -> Doc+ppAlign x | x == 0 = empty+ | otherwise = ", align" <+> pp x++-- print an operand and its type+ppTyped :: (PP a, Typed a) => a -> Doc+ppTyped a = pp (typeOf a) <+> pp a++ppCommaTyped :: (PP a, Typed a) => a -> Doc+ppCommaTyped a = pp (typeOf a) `cma` pp a++phiIncoming :: (Operand, Name) -> Doc+phiIncoming (op, nm) = brackets (pp op `cma` (local (pp nm)))++ppParams :: (a -> Doc) -> ([a], Bool) -> Doc+ppParams ppParam (ps, varrg) = parens . commas $ fmap ppParam ps ++ vargs+ where+ vargs = if varrg then ["..."] else []++ppFunctionArgumentTypes :: Type -> Doc+ppFunctionArgumentTypes FunctionType {..} = ppParams pp (argumentTypes, isVarArg)+ppFunctionArgumentTypes _ = error "Non-function argument. (Malformed AST)"++ppCall :: Instruction -> Doc+ppCall Call { function = Right f,..}+ = tail <+> "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 empty+ referencedType (PointerType t _) = referencedType t+ referencedType t = t++ tail = case tailCallKind of+ Just Tail -> "tail"+ Just MustTail -> "musttail"+ Just NoTail -> "notail"+ Nothing -> empty+ppCall x = error "Non-callable argument. (Malformed AST)"++-- Differs from Call in record name conventions only so needs a seperate almost+-- identical function. :(+ppInvoke :: Terminator -> Doc+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 empty+ referencedType (PointerType t _) = referencedType t+ referencedType t = t+ppInvoke x = error "Non-callable argument. (Malformed AST)"++ppSingleBlock :: BasicBlock -> Doc+ppSingleBlock (BasicBlock nm instrs term) = (vcat $ (fmap pp instrs) ++ [pp term])++ppllvm :: Module -> Text+ppllvm = displayT . renderPretty 0.4 100 . pp++ppll :: PP a => a -> Text+ppll = displayT . renderPretty 0.4 100 . pp++-- 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
+ src/LLVM/Token.hs view
@@ -0,0 +1,3 @@+module LLVM.Token where++import Data.Text
+ src/LLVM/Typed.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}++module LLVM.Typed (+ Typed(..),+ getElementType,+) where++import LLVM.AST+import LLVM.AST.Global+import LLVM.AST.Type++import qualified LLVM.AST.Constant as C+import qualified LLVM.AST.Float as F++-----+-- Reasoning about types+-----++class Typed a where+ typeOf :: a -> Type++instance Typed Operand where+ typeOf (LocalReference t _) = t+ typeOf (ConstantOperand c) = typeOf c+ typeOf _ = MetadataType++instance Typed CallableOperand where+ typeOf (Right op) = typeOf op+ typeOf (Left asm) = error "typeOf inline assembler is not defined. (Malformed AST)"++instance Typed C.Constant where+ typeOf (C.Int bits _) = IntegerType bits+ typeOf (C.Float float) = typeOf float+ typeOf (C.Null t) = t+ typeOf (C.Struct {..}) = StructureType isPacked (map typeOf memberValues)+ typeOf (C.Array {..}) = ArrayType (fromIntegral $ length memberValues) memberType+ typeOf (C.Vector {..}) = VectorType (fromIntegral $ length memberValues) $+ case memberValues of+ [] -> VoidType {- error "Vectors of size zero are not allowed" -}+ (x:_) -> typeOf x+ typeOf (C.Undef t) = t+ typeOf (C.BlockAddress {..}) = ptr i8+ typeOf (C.GlobalReference t _) = t+ typeOf (C.Add {..}) = typeOf operand0+ typeOf (C.FAdd {..}) = typeOf operand0+ typeOf (C.FDiv {..}) = typeOf operand0+ typeOf (C.FRem {..}) = typeOf operand0+ typeOf (C.Sub {..}) = typeOf operand0+ typeOf (C.FSub {..}) = typeOf operand0+ typeOf (C.Mul {..}) = typeOf operand0+ typeOf (C.FMul {..}) = typeOf operand0+ typeOf (C.UDiv {..}) = typeOf operand0+ typeOf (C.SDiv {..}) = typeOf operand0+ typeOf (C.URem {..}) = typeOf operand0+ typeOf (C.SRem {..}) = typeOf operand0+ typeOf (C.Shl {..}) = typeOf operand0+ typeOf (C.LShr {..}) = typeOf operand0+ typeOf (C.AShr {..}) = typeOf operand0+ typeOf (C.And {..}) = typeOf operand0+ typeOf (C.Or {..}) = typeOf operand0+ typeOf (C.Xor {..}) = typeOf operand0+ typeOf (C.GetElementPtr {..}) = getElementPtrType (typeOf address) indices+ typeOf (C.Trunc {..}) = type'+ typeOf (C.ZExt {..}) = type'+ typeOf (C.SExt {..}) = type'+ typeOf (C.FPToUI {..}) = type'+ typeOf (C.FPToSI {..}) = type'+ typeOf (C.UIToFP {..}) = type'+ typeOf (C.SIToFP {..}) = type'+ typeOf (C.FPTrunc {..}) = type'+ typeOf (C.FPExt {..}) = type'+ typeOf (C.PtrToInt {..}) = type'+ typeOf (C.IntToPtr {..}) = type'+ typeOf (C.BitCast {..}) = type'+ typeOf (C.ICmp {..}) = case (typeOf operand0) of+ (VectorType n _) -> VectorType n i1+ _ -> i1+ typeOf (C.FCmp {..}) = case (typeOf operand0) of+ (VectorType n _) -> VectorType n i1+ _ -> i1+ typeOf (C.Select {..}) = typeOf trueValue+ typeOf (C.ExtractElement {..}) = case typeOf vector of+ (VectorType _ t) -> t+ _ -> VoidType {- error "The first operand of an extractelement instruction is a value of vector type." -}+ typeOf (C.InsertElement {..}) = typeOf vector+ typeOf (C.ShuffleVector {..}) = case (typeOf operand0, typeOf mask) of+ (VectorType _ t, VectorType m _) -> VectorType m t+ _ -> VoidType {- error -}+ typeOf (C.ExtractValue {..}) = extractValueType (typeOf aggregate) indices+ typeOf (C.InsertValue {..}) = typeOf aggregate+ typeOf (C.TokenNone) = TokenType+ typeOf (C.AddrSpaceCast {..}) = type'++getElementPtrType :: Type -> [C.Constant] -> Type+getElementPtrType ty [] = ptr ty+getElementPtrType (PointerType ty _) (_:is) = getElementPtrType ty is+getElementPtrType (StructureType _ elTys) (C.Int 32 val:is) =+ getElementPtrType (elTys !! fromIntegral val) is+getElementPtrType (VectorType _ elTy) (_:is) = getElementPtrType elTy is+getElementPtrType (ArrayType _ elTy) (_:is) = getElementPtrType elTy is++getElementType :: Type -> Type+getElementType (PointerType t _) = t+getElementType t = error $ "this should be a pointer type" ++ show t++extractValueType = error "extract"++instance Typed F.SomeFloat where+ typeOf (F.Half _) = FloatingPointType HalfFP+ typeOf (F.Single _) = FloatingPointType FloatFP+ typeOf (F.Double _) = FloatingPointType DoubleFP+ typeOf (F.Quadruple _ _) = FloatingPointType FP128FP+ typeOf (F.X86_FP80 _ _) = FloatingPointType X86_FP80FP+ typeOf (F.PPC_FP128 _ _) = FloatingPointType PPC_FP128FP++instance Typed Global where+ typeOf (GlobalVariable {..}) = type'+ typeOf (GlobalAlias {..}) = type'+ typeOf (Function {..}) = let (params, isVarArg) = parameters+ in FunctionType returnType (map typeOf params) isVarArg+instance Typed Parameter where+ typeOf (Parameter t _ _) = t
+ tests/Main.hs view
@@ -0,0 +1,56 @@+module Main where++import LLVM.Context+import LLVM.Pretty (ppllvm)+import qualified LLVM.Module as M++import Control.Monad (filterM)+import Control.Monad.Except++import Data.Functor+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T+import Text.Show.Pretty (ppShow)++import System.IO+import System.Exit+import System.Directory+import System.FilePath+import System.Environment++import Test.Tasty+import Test.Tasty.HUnit++-------------------------------------------------------------------------------+-- Harness+-------------------------------------------------------------------------------++llvmFile :: FilePath -> IO Bool+llvmFile fname = do+ str <- readFile fname+ withContext $ \ctx -> do+ res <- M.withModuleFromLLVMAssembly ctx str $ \mod -> do+ ast <- M.moduleAST mod+ let str = ppllvm ast+ T.writeFile ("tests/output" </> takeFileName fname) str+ trip <- M.withModuleFromLLVMAssembly ctx (T.unpack str) (const $ return ())+ {-T.putStrLn str-}+ pure ()+ return True++makeTest :: FilePath -> TestTree+makeTest fname = testCase fname $ assert (llvmFile fname)++testPath :: FilePath+testPath = "tests/input/"++suite :: IO TestTree+suite = do+ dirFiles <- listDirectory testPath+ let testFiles = fmap (\x -> testPath </> x) dirFiles+ pure $ testGroup "Test Suite" [+ testGroup "Roundtrip Tests" $ fmap makeTest testFiles+ ]++main :: IO ()+main = defaultMain =<< suite