diff --git a/llvm-general.cabal b/llvm-general.cabal --- a/llvm-general.cabal +++ b/llvm-general.cabal @@ -1,5 +1,5 @@ name: llvm-general -version: 3.2.4.4 +version: 3.2.4.5 license: BSD3 license-file: LICENSE author: Benjamin S.Scarlet @@ -16,7 +16,7 @@ handles almost all of the stateful complexities of using the LLVM API to build IR; and it supports moving IR not only from Haskell into LLVM C++ objects, but the other direction - from LLVM C++ into Haskell. . - For haddock, see . + For haddock, see . extra-source-files: src/LLVM/General/Internal/FFI/Analysis.h src/LLVM/General/Internal/FFI/Function.h @@ -36,7 +36,7 @@ type: git location: git://github.com/bscarlet/llvm-general.git branch: llvm-3.2 - tag: v3.2.4.4 + tag: v3.2.4.5 flag shared-llvm description: link against llvm shared rather than static library @@ -59,7 +59,8 @@ containers >= 0.4.2.1, parsec >= 3.1.3, array >= 0.4.0.0, - setenv >= 0.1.0 + setenv >= 0.1.0, + pretty >= 1.1.1.0 extra-libraries: stdc++ hs-source-dirs: src extensions: @@ -98,6 +99,7 @@ LLVM.General.ExecutionEngine LLVM.General.Module LLVM.General.PassManager + LLVM.General.PrettyPrint LLVM.General.Relocation LLVM.General.Target LLVM.General.Target.Options @@ -132,6 +134,7 @@ LLVM.General.Internal.Module LLVM.General.Internal.Operand LLVM.General.Internal.PassManager + LLVM.General.Internal.PrettyPrint LLVM.General.Internal.RMWOperation LLVM.General.Internal.String LLVM.General.Internal.Target @@ -218,6 +221,7 @@ LLVM.General.Test.Metadata LLVM.General.Test.Module LLVM.General.Test.Optimization + LLVM.General.Test.PrettyPrint LLVM.General.Test.Support LLVM.General.Test.Target LLVM.General.Test.Tests diff --git a/src/LLVM/General/Internal/PrettyPrint.hs b/src/LLVM/General/Internal/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/Internal/PrettyPrint.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE + TemplateHaskell, + QuasiQuotes, + ViewPatterns, + OverloadedStrings + #-} +module LLVM.General.Internal.PrettyPrint where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Data.Monoid +import Data.String +import Data.Data +import Data.Word +import Data.Maybe + +import Data.List +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Applicative ((<$>),(<*>)) +import Control.Monad.Reader + +data Branch + = Fixed String + | Variable String String + | IndentGroup Tree + deriving (Eq, Ord, Show) + +type Tree = [Branch] + +data PrettyShowEnv = PrettyShowEnv { + prefixes :: Map String (Maybe String), + precedence :: Int + } + deriving (Show) + +defaultPrettyShowEnv :: PrettyShowEnv +defaultPrettyShowEnv = PrettyShowEnv { + prefixes = Map.empty, + precedence = 0 + } + +type Qual a = Reader PrettyShowEnv a + +prec :: Int -> Qual a -> Qual a +prec p = local (\env -> env { precedence = p }) + +type QTree = Qual Tree + +variable :: String -> String -> QTree +variable t f = return [Variable t f] + +indentGroup :: QTree -> QTree +indentGroup = fmap (return . IndentGroup) + +instance IsString QTree where + fromString = return . return . Fixed + +instance Monoid QTree where + mempty = return mempty + mappend a b = mappend <$> a <*> b + +renderEx :: Int -> String -> PrettyShowEnv -> QTree -> String +renderEx threshold indent env ts = + (\(l, t, f) -> if (l < threshold) then t else f) $ fit 0 (runReader ts env) + where + ind i = concat $ replicate i indent + fit i branches = (sum ls, concat ts, concat fs) + where + bit (Fixed s) = (length s, s, s) + bit (Variable t f) = (length f, f, concat [ s:(if s == '\n' then ind i else "") | s <- t ]) + bit (IndentGroup tree) = + let (l, t, f) = fit (i+1) tree + in (l, t, if (l < threshold) then t else "\n" ++ ind (i+1) ++ f ++ "\n" ++ ind i) + (ls, ts, fs) = unzip3 . map bit $ branches + +render = renderEx 80 " " defaultPrettyShowEnv + +comma = "," <> variable "\n" " " +a <+> b = a <> " " <> b + +punctuate :: QTree -> [QTree] -> QTree +punctuate a as = intercalate <$> a <*> sequence as + +gParens o c content = o <> prec 0 (indentGroup content) <> c +parens = gParens "(" ")" +brackets = gParens "[" "]" +braces = gParens ("{" <> variable "" " ") (variable "" " " <> "}") + +record :: QTree -> [(QTree,QTree)] -> QTree +record name fields = do + name <+> braces (punctuate comma [ n <+> "=" <+> v | (n,v) <- fields ]) + +ctor :: QTree -> [QTree] -> QTree +ctor name fields = do + p <- asks precedence + parensIfNeeded appPrec (foldl (<+>) name fields) + +class Show a => PrettyShow a where + prettyShow :: a -> QTree + prettyShowList :: [a] -> QTree + + prettyShow = fromString . show + prettyShowList = brackets . punctuate comma . map prettyShow + +instance PrettyShow a => PrettyShow [a] where + prettyShow = prettyShowList + + +appPrec = 10 +appPrec1 = 11 + +parensIfNeeded p' b = do + p <- asks precedence + let b' = prec (p'+1) b + if (p > p') then parens b' else b' + +instance PrettyShow Int +instance PrettyShow Bool +instance PrettyShow Integer +instance PrettyShow Double +instance PrettyShow Float +instance PrettyShow Word +instance PrettyShow Word16 +instance PrettyShow Word32 +instance PrettyShow Word64 + +instance PrettyShow Char where + prettyShowList = fromString . show + +instance PrettyShow a => PrettyShow (Set a) where + prettyShow s = ctor "Set.fromList" [prettyShow (Set.toList s)] + +instance (PrettyShow a, PrettyShow b) => PrettyShow (a, b) where + prettyShow (a,b) = parens (prec appPrec1 (prettyShow a <> comma <> prettyShow b)) + +instance (PrettyShow k, PrettyShow a) => PrettyShow (Map k a) where + prettyShow m = ctor "Map.fromList" [prettyShow (Map.toList m)] + +data SimpleName = SimpleName (Maybe String) String + deriving (Eq, Ord, Read, Show) + +instance PrettyShow SimpleName where + prettyShow (SimpleName mMod n) = do + prs <- asks prefixes + fromString $ fromMaybe n $ do + mod <- mMod + pr <- Map.findWithDefault (Just mod) mod prs + return $ pr ++ "." ++ n + +simpleName :: Name -> ExpQ +simpleName n = do + let d :: Data d => d -> ExpQ + d = dataToExpQ (const Nothing) + [| prettyShow (SimpleName $(d (nameModule n)) $(d (nameBase n))) |] + +makePrettyShowInstance :: Name -> DecsQ +makePrettyShowInstance n = do + info <- reify n + let (tvb, cons) = + case info of + TyConI (DataD _ _ tvb cons _) -> (tvb, cons) + TyConI (NewtypeD _ _ tvb con _) -> (tvb, [con]) + x -> error $ "unexpected info: " ++ show x + cs <- mapM (const $ newName "a") tvb + let cvs = map varT cs + sequence . return $ instanceD (cxt [classP (mkName "PrettyShow") [cv] | cv <- cvs]) [t| PrettyShow $(foldl appT (conT n) cvs) |] [ + funD (mkName "prettyShow") [ + clause + [varP (mkName "a")] ( + normalB $ caseE (dyn "a") $ flip map cons $ \con -> do + case con of + RecC conName (unzip3 -> (ns, _, _)) -> do + pvs <- mapM (const $ newName "f") ns + let ss = [| record $(simpleName conName) $(listE [[|($(simpleName n), prettyShow $(varE pv))|] | (n, pv) <- zip ns pvs]) |] + match + (conP conName (map varP pvs)) + (normalB ss) + [] + NormalC conName fs -> do + pvs <- mapM (const $ newName "f") fs + let ss = [| ctor $(simpleName conName) $(listE [[| prettyShow $(varE pv)|] | pv <- pvs]) |] + match + (conP conName (map varP pvs)) + (normalB ss) + [] + InfixC (_, n0) conName (_, n1) -> do + DataConI _ _ _ (Fixity prec _) <- reify conName + let ns = [n0, n1] + [p0,p1] <- mapM (const $ newName "f") ns + let ss = [| parensIfNeeded prec (prettyShow $(varE p0) <+> $(simpleName conName) <+> prettyShow $(varE p1)) |] + match + (uInfixP (varP p0) conName (varP p1)) + (normalB ss) + [] + x -> error $ "unexpected constructor pattern: " ++ show x + ) + [] + ] + ] + + + diff --git a/src/LLVM/General/PassManager.hs b/src/LLVM/General/PassManager.hs --- a/src/LLVM/General/PassManager.hs +++ b/src/LLVM/General/PassManager.hs @@ -1,5 +1,5 @@ -- | A 'PassManager' holds collection of passes, to be run on 'Module's. --- Build one with 'createPassManager': +-- Build one with 'withPassManager': -- -- * from a 'CuratedPassSetSpec' if you want optimization but not to play with your compiler -- diff --git a/src/LLVM/General/PrettyPrint.hs b/src/LLVM/General/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/General/PrettyPrint.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE + TemplateHaskell, + GeneralizedNewtypeDeriving + #-} +-- | Tools for printing out AST.'LLVM.General.AST.Module' code so that it's actually useful. +module LLVM.General.PrettyPrint ( + showPretty, + showPrettyEx, + PrefixScheme(..), + shortPrefixScheme, + longPrefixScheme, + defaultPrefixScheme, + basePrefixScheme, + shortASTPrefixScheme, + longASTPrefixScheme, + imports + ) where + +import Control.Monad +import Data.Functor +import Data.Monoid +import Data.Map (Map) +import qualified Data.Map as Map +import LLVM.General.Internal.PrettyPrint + +import qualified LLVM.General.AST as A +import qualified LLVM.General.AST.DataLayout as A +import qualified LLVM.General.AST.Constant as A.C +import qualified LLVM.General.AST.AddrSpace as A +import qualified LLVM.General.AST.Float as A +import qualified LLVM.General.AST.FloatingPointPredicate as A +import qualified LLVM.General.AST.IntegerPredicate as A +import qualified LLVM.General.AST.Attribute as A +import qualified LLVM.General.AST.CallingConvention as A +import qualified LLVM.General.AST.Visibility as A +import qualified LLVM.General.AST.Linkage as A +import qualified LLVM.General.AST.InlineAssembly as A +import qualified LLVM.General.AST.RMWOperation as A + +liftM concat $ mapM makePrettyShowInstance [ + ''A.Module, + ''A.Definition, + ''A.DataLayout, + ''A.Operand, + ''A.MetadataNodeID, + ''A.MetadataNode, + ''A.Type, + ''A.Name, + ''A.Global, + ''A.AlignmentInfo, + ''A.AlignType, + ''A.C.Constant, + ''A.AddrSpace, + ''A.Endianness, + ''A.BasicBlock, + ''A.FloatingPointPredicate, + ''A.IntegerPredicate, + ''A.FloatingPointFormat, + ''A.FunctionAttribute, + ''A.ParameterAttribute, + ''A.Parameter, + ''A.CallingConvention, + ''A.Visibility, + ''A.Linkage, + ''A.SomeFloat, + ''A.Named, + ''A.Terminator, + ''A.Instruction, + ''A.LandingPadClause, + ''A.InlineAssembly, + ''A.RMWOperation, + ''A.Atomicity, + ''A.Dialect, + ''A.MemoryOrdering, + ''Either, + ''Maybe + ] + +-- | Show an AST.'LLVM.General.AST.Module' or part thereof both with qualified +-- identifiers (resolving some ambiguity, making the output usable Haskell) and +-- with indentation (making the output readable). +showPretty :: PrettyShow a => a -> String +showPretty = showPrettyEx 80 " " defaultPrefixScheme + +-- | Like 'showPretty' but allowing configuration of the format +showPrettyEx + :: PrettyShow a + => Int -- ^ line length before attempting breaking + -> String -- ^ one unit of indentation + -> PrefixScheme -- ^ prefixes to use for qualifying names + -> a + -> String +showPrettyEx width indent (PrefixScheme ps) = renderEx width indent (defaultPrettyShowEnv { prefixes = ps }) . prettyShow + +-- | A 'PrefixScheme' is a mapping between haskell module names and +-- the prefixes with which they should be rendered when printing code. +newtype PrefixScheme = PrefixScheme (Map String (Maybe String)) + deriving (Eq, Ord, Read, Show, Monoid) + +-- | a 'PrefixScheme' for types not of llvm-general, but nevertheless used +-- in the AST. Useful for building other 'PrefixScheme's. +basePrefixScheme :: PrefixScheme +basePrefixScheme = PrefixScheme $ Map.fromList [ + ("Data.Maybe", Nothing), + ("Data.Map", Just "Map"), + ("Data.Set", Just "Set") + ] + +-- | a terse 'PrefixScheme' for types in the AST, leaving most names unqualified. +-- Useful for building other 'PrefixScheme's. If you think you want to use this, you +-- probably want 'shortPrefixScheme' instead. +shortASTPrefixScheme :: PrefixScheme +shortASTPrefixScheme = PrefixScheme $ Map.fromList [ + ("LLVM.General.AST", Nothing), + ("LLVM.General.AST.AddrSpace", Nothing), + ("LLVM.General.AST.DataLayout", Nothing), + ("LLVM.General.AST.Float", Nothing), + ("LLVM.General.AST.InlineAssembly", Nothing), + ("LLVM.General.AST.Instruction", Nothing), + ("LLVM.General.AST.Name", Nothing), + ("LLVM.General.AST.Operand", Nothing), + ("LLVM.General.AST.Type", Nothing), + ("LLVM.General.AST.FloatingPointPredicate", Just "FPred"), + ("LLVM.General.AST.IntegerPredicate", Just "IPred"), + ("LLVM.General.AST.Constant", Just "C"), + ("LLVM.General.AST.Attribute", Just "A"), + ("LLVM.General.AST.Global", Just "G"), + ("LLVM.General.AST.CallingConvention", Just "CC"), + ("LLVM.General.AST.Visibility", Just "V"), + ("LLVM.General.AST.Linkage", Just "L") + ] + +-- | a conservative 'PrefixScheme' for types in the AST which qualifies everything. +-- Useful for building other 'PrefixScheme's. If you think you want to use this, you +-- probably want 'longPrefixScheme' instead. +longASTPrefixScheme :: PrefixScheme +longASTPrefixScheme = case shortASTPrefixScheme of + PrefixScheme m -> PrefixScheme $ maybe (Just "A") (Just . ("A."++)) <$> m + +-- | a terse 'PrefixScheme', leaving most names unqualified. +shortPrefixScheme :: PrefixScheme +shortPrefixScheme = shortASTPrefixScheme <> basePrefixScheme + +-- | a conservative 'PrefixScheme' which qualifies everything. +longPrefixScheme :: PrefixScheme +longPrefixScheme = longASTPrefixScheme <> basePrefixScheme + +-- | the default 'PrefixScheme' used by 'showPretty' +defaultPrefixScheme :: PrefixScheme +defaultPrefixScheme = longPrefixScheme + +-- | print Haskell imports to define the correct prefixes for use with the output +-- of a given 'PrefixScheme'. +imports :: PrefixScheme -> String +imports (PrefixScheme p) = unlines . flip map (Map.toList p) $ \(mod, mAbbr) -> + "import " ++ maybe mod (\abbr -> "qualified " ++ mod ++ " as " ++ abbr) mAbbr + + diff --git a/src/LLVM/General/Target.hs b/src/LLVM/General/Target.hs --- a/src/LLVM/General/Target.hs +++ b/src/LLVM/General/Target.hs @@ -4,7 +4,7 @@ module LLVM.General.Target ( lookupTarget, TargetOptions, - TargetMachine, + Target, TargetMachine, TargetLowering, CPUFeature(..), withTargetOptions, peekTargetOptions, pokeTargetOptions, withTargetMachine, withDefaultTargetMachine, diff --git a/test/LLVM/General/Test/DataLayout.hs b/test/LLVM/General/Test/DataLayout.hs --- a/test/LLVM/General/Test/DataLayout.hs +++ b/test/LLVM/General/Test/DataLayout.hs @@ -6,6 +6,7 @@ import LLVM.General.Test.Support +import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map @@ -16,16 +17,19 @@ import LLVM.General.AST.AddrSpace import qualified LLVM.General.AST.Global as G +m s = "; ModuleID = ''\n" ++ s +t s = "target datalayout = \"" ++ s ++ "\"\n" + tests = testGroup "DataLayout" [ - testCase name $ strCheck (Module "" mdl Nothing []) ("; ModuleID = ''\n" ++ sdl) - | (name, mdl, sdl) <- [ - ("none",Nothing, "") + testCase name $ strCheckC (Module "" mdl Nothing []) (m sdl) (m sdlc) + | (name, mdl, sdl, sdlc) <- [ + ("none", Nothing, "", "") ] ++ [ - (name, Just mdl, "target datalayout = \"" ++ sdl ++ "\"\n") - | (name, mdl, sdl) <- [ - ("little-endian", defaultDataLayout { endianness = Just LittleEndian }, "e"), - ("big-endian", defaultDataLayout { endianness = Just BigEndian }, "E"), - ("native", defaultDataLayout { nativeSizes = Just (Set.fromList [8,32]) }, "n8:32"), + (name, Just mdl, t sdl, t (fromMaybe sdl msdlc)) + | (name, mdl, sdl, msdlc) <- [ + ("little-endian", defaultDataLayout { endianness = Just LittleEndian }, "e", Nothing), + ("big-endian", defaultDataLayout { endianness = Just BigEndian }, "E", Nothing), + ("native", defaultDataLayout { nativeSizes = Just (Set.fromList [8,32]) }, "n8:32", Nothing), ( "no pref", defaultDataLayout { @@ -40,7 +44,8 @@ } ) }, - "p:8:64" + "p:8:64", + Nothing ), ( "no pref", defaultDataLayout { @@ -55,7 +60,34 @@ } ) }, - "p1:8:32:64" + "p1:8:32:64", + Nothing + ), ( + "big", + DataLayout { + endianness = Just LittleEndian, + stackAlignment = Just 128, + pointerLayouts = Map.fromList [ + (AddrSpace 0, (64, AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64})) + ], + typeLayouts = Map.fromList [ + ((IntegerAlign, 1), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}), + ((IntegerAlign, 8), AlignmentInfo {abiAlignment = 8, preferredAlignment = Just 8}), + ((IntegerAlign, 16), AlignmentInfo {abiAlignment = 16, preferredAlignment = Just 16}), + ((IntegerAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}), + ((IntegerAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), + ((VectorAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), + ((VectorAlign, 128), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}), + ((FloatAlign, 32), AlignmentInfo {abiAlignment = 32, preferredAlignment = Just 32}), + ((FloatAlign, 64), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}), + ((FloatAlign, 80), AlignmentInfo {abiAlignment = 128, preferredAlignment = Just 128}), + ((AggregateAlign, 0), AlignmentInfo {abiAlignment = 0, preferredAlignment = Just 64}), + ((StackAlign, 0), AlignmentInfo {abiAlignment = 64, preferredAlignment = Just 64}) + ], + nativeSizes = Just (Set.fromList [8,16,32,64]) + }, + "e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64-S128", + Just "e-S128-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-v64:64:64-v128:128:128-f32:32:32-f64:64:64-f80:128:128-a0:0:64-s0:64:64-n8:16:32:64" ) ] ] diff --git a/test/LLVM/General/Test/Module.hs b/test/LLVM/General/Test/Module.hs --- a/test/LLVM/General/Test/Module.hs +++ b/test/LLVM/General/Test/Module.hs @@ -366,6 +366,35 @@ ] ] t <- runErrorT $ withModuleFromAST context badAST $ \_ -> return True - t @?= Left "reference to undefined block: Name \"not here\"" + t @?= Left "reference to undefined block: Name \"not here\"", + + testCase "multiple" $ withContext $ \context -> do + let badAST = Module "" Nothing Nothing [ + GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([ + ],False) + [] Nothing 0 + [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = False, + nuw = False, + operand0 = LocalReference (Name "unknown"), + operand1 = ConstantOperand (C.Int 32 1), + metadata = [] + }, + UnName 2 := Mul { + nsw = False, + nuw = False, + operand0 = LocalReference (Name "unknown2"), + operand1 = LocalReference (UnName 1), + metadata = [] + } + ] ( + Do $ Ret (Just (LocalReference (UnName 2))) [] + ) + ] + ] + t <- runErrorT $ withModuleFromAST context badAST $ \_ -> return True + t @?= Left "reference to undefined local: Name \"unknown\"" ] ] diff --git a/test/LLVM/General/Test/Optimization.hs b/test/LLVM/General/Test/Optimization.hs --- a/test/LLVM/General/Test/Optimization.hs +++ b/test/LLVM/General/Test/Optimization.hs @@ -148,7 +148,11 @@ Do $ Br (Name "done") [] ), BasicBlock (Name "done") [ - Name "r" := Phi {type' = IntegerType 32, incomingValues = [(LocalReference (UnName 1),Name "take"),(ConstantOperand (C.Int 32 57), Name "here")], metadata = []} + Name "r" := Phi { + type' = IntegerType 32, + incomingValues = [(LocalReference (UnName 1),Name "take"),(ConstantOperand (C.Int 32 57), Name "here")], + metadata = [] + } ] ( Do $ Ret (Just (LocalReference (Name "r"))) [] ) diff --git a/test/LLVM/General/Test/PrettyPrint.hs b/test/LLVM/General/Test/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/test/LLVM/General/Test/PrettyPrint.hs @@ -0,0 +1,99 @@ +module LLVM.General.Test.PrettyPrint where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit + +import LLVM.General.Test.Support + +import LLVM.General.PrettyPrint + +import LLVM.General.AST +import qualified LLVM.General.AST.Linkage as L +import qualified LLVM.General.AST.Visibility as V +import qualified LLVM.General.AST.CallingConvention as CC +import qualified LLVM.General.AST.Constant as C + +tests = testGroup "PrettyPrint" [ + testCase "basic" $ do + let ast = Module "" Nothing Nothing [ + GlobalDefinition $ Function L.External V.Default CC.C [] (IntegerType 32) (Name "foo") ([ + Parameter (IntegerType 32) (Name "x") [] + ],False) + [] Nothing 0 + [ + BasicBlock (UnName 0) [ + UnName 1 := Mul { + nsw = True, + nuw = False, + operand0 = ConstantOperand (C.Int 32 1), + operand1 = ConstantOperand (C.Int 32 1), + metadata = [] + } + ] ( + Do $ Br (Name "here") [] + ), + BasicBlock (Name "here") [ + ] ( + Do $ Ret (Just (LocalReference (UnName 1))) [] + ) + ] + ] + s = "A.Module {\n\ + \ A.moduleName = \"\",\n\ + \ A.moduleDataLayout = Nothing,\n\ + \ A.moduleTargetTriple = Nothing,\n\ + \ A.moduleDefinitions = [\n\ + \ A.GlobalDefinition A.G.Function {\n\ + \ A.G.linkage = A.L.External,\n\ + \ A.G.visibility = A.V.Default,\n\ + \ A.G.callingConvention = A.CC.C,\n\ + \ A.G.returnAttributes = [],\n\ + \ A.G.returnType = A.IntegerType {A.typeBits = 32},\n\ + \ A.G.name = A.Name \"foo\",\n\ + \ A.G.parameters = ([A.G.Parameter A.IntegerType { A.typeBits = 32 } (A.Name \"x\") []], False),\n\ + \ A.G.functionAttributes = [],\n\ + \ A.G.section = Nothing,\n\ + \ A.G.alignment = 0,\n\ + \ A.G.basicBlocks = [\n\ + \ A.G.BasicBlock (A.UnName 0) [\n\ + \ A.UnName 1 A.:= A.Mul {\n\ + \ A.nsw = True,\n\ + \ A.nuw = False,\n\ + \ A.operand0 = A.ConstantOperand A.C.Int {A.C.integerBits = 32, A.C.integerValue = 1},\n\ + \ A.operand1 = A.ConstantOperand A.C.Int {A.C.integerBits = 32, A.C.integerValue = 1},\n\ + \ A.metadata = []\n\ + \ }\n\ + \ ] (A.Do A.Br { A.dest = A.Name \"here\", A.metadata' = [] }),\n\ + \ A.G.BasicBlock (A.Name \"here\") [] (\n\ + \ A.Do A.Ret {A.returnOperand = Just (A.LocalReference (A.UnName 1)), A.metadata' = []}\n\ + \ )\n\ + \ ]\n\ + \ }\n\ + \ ]\n\ + \}" + showPretty ast @?= s, + testCase "imports" $ do + imports defaultPrefixScheme @?= + "import qualified Data.Map as Map\n\ + \import Data.Maybe\n\ + \import qualified Data.Set as Set\n\ + \import qualified LLVM.General.AST as A\n\ + \import qualified LLVM.General.AST.AddrSpace as A\n\ + \import qualified LLVM.General.AST.Attribute as A.A\n\ + \import qualified LLVM.General.AST.CallingConvention as A.CC\n\ + \import qualified LLVM.General.AST.Constant as A.C\n\ + \import qualified LLVM.General.AST.DataLayout as A\n\ + \import qualified LLVM.General.AST.Float as A\n\ + \import qualified LLVM.General.AST.FloatingPointPredicate as A.FPred\n\ + \import qualified LLVM.General.AST.Global as A.G\n\ + \import qualified LLVM.General.AST.InlineAssembly as A\n\ + \import qualified LLVM.General.AST.Instruction as A\n\ + \import qualified LLVM.General.AST.IntegerPredicate as A.IPred\n\ + \import qualified LLVM.General.AST.Linkage as A.L\n\ + \import qualified LLVM.General.AST.Name as A\n\ + \import qualified LLVM.General.AST.Operand as A\n\ + \import qualified LLVM.General.AST.Type as A\n\ + \import qualified LLVM.General.AST.Visibility as A.V\n" + ] + diff --git a/test/LLVM/General/Test/Support.hs b/test/LLVM/General/Test/Support.hs --- a/test/LLVM/General/Test/Support.hs +++ b/test/LLVM/General/Test/Support.hs @@ -27,8 +27,10 @@ withModuleFromString' c s f = failInIO $ withModuleFromString c s f withModuleFromAST' c a f = failInIO $ withModuleFromAST c a f -strCheck mAST mStr = withContext $ \context -> do +strCheckC mAST mStr mStrCanon = withContext $ \context -> do a <- withModuleFromString' context mStr moduleAST s <- withModuleFromAST' context mAST moduleString - (a,s) @?= (mAST, mStr) + (a,s) @?= (mAST, mStrCanon) + +strCheck mAST mStr = strCheckC mAST mStr mStr diff --git a/test/LLVM/General/Test/Tests.hs b/test/LLVM/General/Test/Tests.hs --- a/test/LLVM/General/Test/Tests.hs +++ b/test/LLVM/General/Test/Tests.hs @@ -13,6 +13,7 @@ import qualified LLVM.General.Test.Optimization as Optimization import qualified LLVM.General.Test.Target as Target import qualified LLVM.General.Test.Analysis as Analysis +import qualified LLVM.General.Test.PrettyPrint as PrettyPrint tests = testGroup "llvm-general" [ Constants.tests, @@ -25,5 +26,6 @@ Module.tests, Optimization.tests, Target.tests, - Analysis.tests + Analysis.tests, + PrettyPrint.tests ]