Created
June 29, 2021 18:48
-
-
Save Heimdell/73568662a1ea567b318b8b263996cdfd to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module Color where | |
type Color = (Int, Int) | |
toCode :: Color -> String | |
toCode (hue, -1) = show (30 + hue) ++ ";2" | |
toCode (hue, 0) = show (90 + hue) | |
toCode (hue, 1) = show (30 + hue) ++ ";1" | |
toCode c = error $ "toCode: should be (0..16 (15?), -1.. 1), but it is " ++ show c | |
faint :: Color -> Color | |
faint (h, _) = (h, -1) | |
bright :: Color -> Color | |
bright (h, _) = (h, 1) | |
red :: Color | |
red = (1, 0) | |
green :: Color | |
green = (2, 0) | |
blue :: Color | |
blue = (4, 0) | |
black :: Color | |
black = (0, 0) | |
(+!) :: Color -> Color -> Color | |
(a, _) +! (b, _) = (a + b, 0) | |
yellow :: Color | |
yellow = green +! red | |
cyan :: Color | |
cyan = green +! blue | |
magenta :: Color | |
magenta = red +! blue | |
white :: Color | |
white = red +! blue +! green |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{- | An extension of 'Text.PrettyPrint'. | |
-} | |
module Pretty | |
( module Pretty | |
, module Text.PrettyPrint | |
, module Color | |
) | |
where | |
import qualified Data.Text as Text | |
import Data.Text (Text, pack) | |
import Text.PrettyPrint hiding ((<>)) | |
import Color | |
-- | Pretty-print to `Text`. Through `String`. Yep. | |
ppToText :: Pretty a => a -> Text | |
ppToText = pack . show . pretty | |
{- | A typeclass for pretty-printable stuff. | |
-} | |
class Pretty p where | |
pretty :: p -> Doc | |
pretty = prettyAtPrec 10 | |
prettyAtPrec :: Int -> p -> Doc | |
prettyAtPrec _ = pretty | |
{-# minimal pretty | prettyAtPrec #-} | |
makeParensIfGt :: (Doc, Doc) -> Bool -> Doc -> Doc | |
makeParensIfGt (open, close) yes d | |
| yes = open <.> d <.> close | |
| otherwise = d | |
instance Pretty () where | |
pretty _ = "()" | |
instance Pretty1 Maybe where | |
pretty1 = maybe empty pretty | |
instance {-# OVERLAPS #-} (Pretty a, Pretty b) => Pretty (Either a b) where | |
pretty = either pretty pretty | |
instance Pretty Int where | |
pretty = int | |
instance Pretty Integer where | |
pretty = integer | |
instance Pretty Float where | |
pretty = float | |
-- | Common instance. | |
instance Pretty Text where | |
pretty = text . Text.unpack | |
-- | Common instance. | |
instance Pretty Doc where | |
pretty = id | |
{- | A typeclass for pretty-printable functors. | |
-} | |
class Pretty1 p where | |
pretty1 :: p Doc -> Doc | |
pretty1 = prettyAtPrec1 10 | |
prettyAtPrec1 :: Int -> p Doc -> Doc | |
prettyAtPrec1 _ = pretty1 | |
{-# minimal pretty1 | prettyAtPrec1 #-} | |
instance {-# OVERLAPPABLE #-} (Pretty a, Pretty1 p, Functor p) => Pretty (p a) where | |
pretty = pretty1 . fmap pretty | |
prettyAtPrec prec = prettyAtPrec1 prec . fmap pretty | |
instance Pretty1 [] where | |
pretty1 = list | |
{- | A wrapper to make `Show` instances from `Pretty` ones. | |
> data X a = X | |
> deriving Show via PP (X a) | |
-} | |
newtype PP a = PP { unPP :: a } | |
instance Pretty a => Show (PP a) where | |
show = show . pretty . unPP | |
{- | The class for annotations. | |
-} | |
class Modifies d where | |
ascribe :: d -> Doc -> Doc | |
instance Modifies () where | |
ascribe () = id | |
{- | The replacement for `Text.PrettyPrint.<>`. | |
-} | |
infixl 6 <.> | |
(<.>) :: Doc -> Doc -> Doc | |
(<.>) = (<>) | |
-- | Colorize a `Doc`. | |
color :: Color -> Doc -> Doc | |
color c d = zeroWidthText begin <.> d <.> zeroWidthText end | |
where | |
begin = "\x1b[" ++ toCode c ++ "m" | |
end = "\x1b[0m" | |
-- | Decorate list of stuff as a tuple. | |
tuple :: Pretty p => [p] -> Doc | |
tuple = parens . train "," | |
-- | Decorate list of stuff as a list. | |
list :: Pretty p => [p] -> Doc | |
list = brackets . train ";" | |
infixr 2 `indent` | |
-- | First argument is a header to an indented second one. | |
indent :: Doc -> Doc -> Doc | |
indent a b = hang a 2 b | |
infixr 1 `above` | |
-- | Horisontal composition. | |
above :: Doc -> Doc -> Doc | |
above a b = hang a 0 b | |
-- | Pretty print as a sequence with given separator. | |
train :: Pretty p => Doc -> [p] -> Doc | |
train sep' = fsep . punctuate sep' . map pretty | |
-- | Pretty print as a vertical block. | |
block :: Pretty p => [p] -> Doc | |
block = foldr ($+$) empty . map pretty | |
-- | For pretty-printing qualified names. | |
sepByDot :: Pretty p => [p] -> Doc | |
sepByDot = cat . map (("." <.>) . pretty) | |
-- | For pretty-printing `Maybe`s. | |
mb :: Pretty a => (Doc -> Doc) -> Maybe a -> Doc | |
mb f = maybe empty (f . pretty) | |
-- | Pretty print as a vertical with elements separated by newline. | |
sparseBlock :: Pretty a => [a] -> Doc | |
sparseBlock = vcat . punctuate "\n" . map (($$ empty) . pretty) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment