module LLVM.General.PrettyPrint (
PrettyShow(..),
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.FastMathFlags,
''A.MemoryOrdering,
''Either,
''Maybe
]
showPretty :: PrettyShow a => a -> String
showPretty = showPrettyEx 80 " " defaultPrefixScheme
showPrettyEx
:: PrettyShow a
=> Int
-> String
-> PrefixScheme
-> a
-> String
showPrettyEx width indent (PrefixScheme ps) = renderEx width indent (defaultPrettyShowEnv { prefixes = ps }) . prettyShow
newtype PrefixScheme = PrefixScheme (Map String (Maybe String))
deriving (Eq, Ord, Read, Show, Monoid)
basePrefixScheme :: PrefixScheme
basePrefixScheme = PrefixScheme $ Map.fromList [
("Data.Maybe", Nothing),
("Data.Either", Nothing),
("Data.Map", Just "Map"),
("Data.Set", Just "Set"),
("GHC.Base", Nothing)
]
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")
]
longASTPrefixScheme :: PrefixScheme
longASTPrefixScheme = case shortASTPrefixScheme of
PrefixScheme m -> PrefixScheme $ maybe (Just "A") (Just . ("A."++)) <$> m
shortPrefixScheme :: PrefixScheme
shortPrefixScheme = shortASTPrefixScheme <> basePrefixScheme
longPrefixScheme :: PrefixScheme
longPrefixScheme = longASTPrefixScheme <> basePrefixScheme
defaultPrefixScheme :: PrefixScheme
defaultPrefixScheme = longPrefixScheme
imports :: PrefixScheme -> String
imports (PrefixScheme p) = unlines [
"import " ++ maybe mod (\abbr -> "qualified " ++ mod ++ " as " ++ abbr) mAbbr
| (mod, mAbbr) <- Map.toList p, mod /= "GHC.Base"
]