1-- | 2-- Module : Cryptol.Utils.PP 3-- Copyright : (c) 2013-2016 Galois, Inc. 4-- License : BSD3 5-- Maintainer : cryptol@galois.com 6-- Stability : provisional 7-- Portability : portable 8 9{-# LANGUAGE Safe #-} 10 11{-# LANGUAGE DeriveAnyClass #-} 12{-# LANGUAGE DeriveGeneric #-} 13{-# LANGUAGE OverloadedStrings #-} 14module Cryptol.Utils.PP where 15 16import Cryptol.Utils.Fixity 17import Cryptol.Utils.Ident 18import Control.DeepSeq 19import Control.Monad (mplus) 20import Data.Maybe (fromMaybe) 21import qualified Data.Semigroup as S 22import Data.String (IsString(..)) 23import qualified Data.Text as T 24import GHC.Generics (Generic) 25import qualified Text.PrettyPrint as PJ 26 27import Prelude () 28import Prelude.Compat 29 30 31-- | How to pretty print things when evaluating 32data PPOpts = PPOpts 33 { useAscii :: Bool 34 , useBase :: Int 35 , useInfLength :: Int 36 , useFPBase :: Int 37 , useFPFormat :: PPFloatFormat 38 } 39 deriving Show 40 41asciiMode :: PPOpts -> Integer -> Bool 42asciiMode opts width = useAscii opts && (width == 7 || width == 8) 43 44data PPFloatFormat = 45 FloatFixed Int PPFloatExp -- ^ Use this many significant digis 46 | FloatFrac Int -- ^ Show this many digits after floating point 47 | FloatFree PPFloatExp -- ^ Use the correct number of digits 48 deriving Show 49 50data PPFloatExp = ForceExponent -- ^ Always show an exponent 51 | AutoExponent -- ^ Only show exponent when needed 52 deriving Show 53 54 55defaultPPOpts :: PPOpts 56defaultPPOpts = PPOpts { useAscii = False, useBase = 10, useInfLength = 5 57 , useFPBase = 16 58 , useFPFormat = FloatFree AutoExponent 59 } 60 61 62-- Name Displaying ------------------------------------------------------------- 63 64{- | How to display names, inspired by the GHC `Outputable` module. 65Getting a value of 'Nothing' from the NameDisp function indicates 66that the display has no opinion on how this name should be displayed, 67and some other display should be tried out. -} 68data NameDisp = EmptyNameDisp 69 | NameDisp (ModName -> Ident -> Maybe NameFormat) 70 deriving (Generic, NFData) 71 72instance Show NameDisp where 73 show _ = "<NameDisp>" 74 75instance S.Semigroup NameDisp where 76 NameDisp f <> NameDisp g = NameDisp (\m n -> f m n `mplus` g m n) 77 EmptyNameDisp <> EmptyNameDisp = EmptyNameDisp 78 EmptyNameDisp <> x = x 79 x <> _ = x 80 81instance Monoid NameDisp where 82 mempty = EmptyNameDisp 83 mappend = (S.<>) 84 85data NameFormat = UnQualified 86 | Qualified !ModName 87 | NotInScope 88 deriving (Show) 89 90-- | Never qualify names from this module. 91neverQualifyMod :: ModName -> NameDisp 92neverQualifyMod mn = NameDisp $ \ mn' _ -> 93 if mn == mn' then Just UnQualified 94 else Nothing 95 96alwaysQualify :: NameDisp 97alwaysQualify = NameDisp $ \ mn _ -> Just (Qualified mn) 98 99neverQualify :: NameDisp 100neverQualify = NameDisp $ \ _ _ -> Just UnQualified 101 102fmtModName :: ModName -> NameFormat -> T.Text 103fmtModName _ UnQualified = T.empty 104fmtModName _ (Qualified mn) = modNameToText mn 105fmtModName mn NotInScope = modNameToText mn 106 107-- | Compose two naming environments, preferring names from the left 108-- environment. 109extend :: NameDisp -> NameDisp -> NameDisp 110extend = mappend 111 112-- | Get the format for a name. When 'Nothing' is returned, the name is not 113-- currently in scope. 114getNameFormat :: ModName -> Ident -> NameDisp -> NameFormat 115getNameFormat m i (NameDisp f) = fromMaybe NotInScope (f m i) 116getNameFormat _ _ EmptyNameDisp = NotInScope 117 118-- | Produce a document in the context of the current 'NameDisp'. 119withNameDisp :: (NameDisp -> Doc) -> Doc 120withNameDisp k = Doc (\disp -> runDoc disp (k disp)) 121 122-- | Fix the way that names are displayed inside of a doc. 123fixNameDisp :: NameDisp -> Doc -> Doc 124fixNameDisp disp (Doc f) = Doc (\ _ -> f disp) 125 126 127-- Documents ------------------------------------------------------------------- 128 129newtype Doc = Doc (NameDisp -> PJ.Doc) deriving (Generic, NFData) 130 131instance S.Semigroup Doc where 132 (<>) = liftPJ2 (PJ.<>) 133 134instance Monoid Doc where 135 mempty = liftPJ PJ.empty 136 mappend = (S.<>) 137 138runDoc :: NameDisp -> Doc -> PJ.Doc 139runDoc names (Doc f) = f names 140 141instance Show Doc where 142 show d = show (runDoc mempty d) 143 144instance IsString Doc where 145 fromString = text 146 147render :: Doc -> String 148render d = PJ.render (runDoc mempty d) 149 150renderOneLine :: Doc -> String 151renderOneLine d = PJ.renderStyle (PJ.style { PJ.mode = PJ.OneLineMode }) (runDoc mempty d) 152 153class PP a where 154 ppPrec :: Int -> a -> Doc 155 156class PP a => PPName a where 157 -- | Fixity information for infix operators 158 ppNameFixity :: a -> Maybe Fixity 159 160 -- | Print a name in prefix: @f a b@ or @(+) a b)@ 161 ppPrefixName :: a -> Doc 162 163 -- | Print a name as an infix operator: @a + b@ 164 ppInfixName :: a -> Doc 165 166pp :: PP a => a -> Doc 167pp = ppPrec 0 168 169pretty :: PP a => a -> String 170pretty = show . pp 171 172optParens :: Bool -> Doc -> Doc 173optParens b body | b = parens body 174 | otherwise = body 175 176 177-- | Information about an infix expression of some sort. 178data Infix op thing = Infix 179 { ieOp :: op -- ^ operator 180 , ieLeft :: thing -- ^ left argument 181 , ieRight :: thing -- ^ right argument 182 , ieFixity :: Fixity -- ^ operator fixity 183 } 184 185commaSep :: [Doc] -> Doc 186commaSep = fsep . punctuate comma 187 188 189-- | Pretty print an infix expression of some sort. 190ppInfix :: (PP thing, PP op) 191 => Int -- ^ Non-infix leaves are printed with this precedence 192 -> (thing -> Maybe (Infix op thing)) 193 -- ^ pattern to check if sub-thing is also infix 194 -> Infix op thing -- ^ Pretty print this infix expression 195 -> Doc 196ppInfix lp isInfix expr = 197 sep [ ppSub wrapL (ieLeft expr) <+> pp (ieOp expr) 198 , ppSub wrapR (ieRight expr) ] 199 where 200 wrapL f = compareFixity f (ieFixity expr) /= FCLeft 201 wrapR f = compareFixity (ieFixity expr) f /= FCRight 202 203 ppSub w e 204 | Just e1 <- isInfix e = optParens (w (ieFixity e1)) (ppInfix lp isInfix e1) 205 ppSub _ e = ppPrec lp e 206 207 208 209-- | Display a numeric value as an ordinal (e.g., 2nd) 210ordinal :: (Integral a, Show a, Eq a) => a -> Doc 211ordinal x = text (show x) <.> text (ordSuffix x) 212 213-- | The suffix to use when displaying a number as an oridinal 214ordSuffix :: (Integral a, Eq a) => a -> String 215ordSuffix n0 = 216 case n `mod` 10 of 217 1 | notTeen -> "st" 218 2 | notTeen -> "nd" 219 3 | notTeen -> "rd" 220 _ -> "th" 221 222 where 223 n = abs n0 224 m = n `mod` 100 225 notTeen = m < 11 || m > 19 226 227 228-- Wrapped Combinators --------------------------------------------------------- 229 230liftPJ :: PJ.Doc -> Doc 231liftPJ d = Doc (const d) 232 233liftPJ1 :: (PJ.Doc -> PJ.Doc) -> Doc -> Doc 234liftPJ1 f (Doc d) = Doc (\env -> f (d env)) 235 236liftPJ2 :: (PJ.Doc -> PJ.Doc -> PJ.Doc) -> (Doc -> Doc -> Doc) 237liftPJ2 f (Doc a) (Doc b) = Doc (\e -> f (a e) (b e)) 238 239liftSep :: ([PJ.Doc] -> PJ.Doc) -> ([Doc] -> Doc) 240liftSep f ds = Doc (\e -> f [ d e | Doc d <- ds ]) 241 242infixl 6 <.>, <+> 243 244(<.>) :: Doc -> Doc -> Doc 245(<.>) = liftPJ2 (PJ.<>) 246 247(<+>) :: Doc -> Doc -> Doc 248(<+>) = liftPJ2 (PJ.<+>) 249 250infixl 5 $$ 251 252($$) :: Doc -> Doc -> Doc 253($$) = liftPJ2 (PJ.$$) 254 255sep :: [Doc] -> Doc 256sep = liftSep PJ.sep 257 258fsep :: [Doc] -> Doc 259fsep = liftSep PJ.fsep 260 261hsep :: [Doc] -> Doc 262hsep = liftSep PJ.hsep 263 264hcat :: [Doc] -> Doc 265hcat = liftSep PJ.hcat 266 267vcat :: [Doc] -> Doc 268vcat = liftSep PJ.vcat 269 270hang :: Doc -> Int -> Doc -> Doc 271hang (Doc p) i (Doc q) = Doc (\e -> PJ.hang (p e) i (q e)) 272 273nest :: Int -> Doc -> Doc 274nest n = liftPJ1 (PJ.nest n) 275 276parens :: Doc -> Doc 277parens = liftPJ1 PJ.parens 278 279braces :: Doc -> Doc 280braces = liftPJ1 PJ.braces 281 282brackets :: Doc -> Doc 283brackets = liftPJ1 PJ.brackets 284 285quotes :: Doc -> Doc 286quotes = liftPJ1 PJ.quotes 287 288backticks :: Doc -> Doc 289backticks d = hcat [ "`", d, "`" ] 290 291punctuate :: Doc -> [Doc] -> [Doc] 292punctuate p = go 293 where 294 go (d:ds) | null ds = [d] 295 | otherwise = d <.> p : go ds 296 go [] = [] 297 298text :: String -> Doc 299text s = liftPJ (PJ.text s) 300 301char :: Char -> Doc 302char c = liftPJ (PJ.char c) 303 304integer :: Integer -> Doc 305integer i = liftPJ (PJ.integer i) 306 307int :: Int -> Doc 308int i = liftPJ (PJ.int i) 309 310comma :: Doc 311comma = liftPJ PJ.comma 312 313empty :: Doc 314empty = liftPJ PJ.empty 315 316colon :: Doc 317colon = liftPJ PJ.colon 318 319instance PP T.Text where 320 ppPrec _ str = text (T.unpack str) 321 322instance PP Ident where 323 ppPrec _ i = text (T.unpack (identText i)) 324 325instance PP ModName where 326 ppPrec _ = text . T.unpack . modNameToText 327 328instance PP Assoc where 329 ppPrec _ LeftAssoc = text "left-associative" 330 ppPrec _ RightAssoc = text "right-associative" 331 ppPrec _ NonAssoc = text "non-associative" 332 333instance PP Fixity where 334 ppPrec _ (Fixity assoc level) = 335 text "precedence" <+> int level <.> comma <+> pp assoc 336