You can reach me at
" +-} +spr :: IsString s => Fmt LogStr s m -> Fmt m a a +spr = fmt . runLogFmt + +-- | Run a formatter and print out the text to stdout. +{-# INLINE printf #-} +printf :: Fmt LogStr Term a -> a +printf = flip unFmt (B.putStrLn . fromLogStr) + +-- | Run a 'Fmt'. +{-# INLINE runFmt #-} +runFmt :: Fmt m m a -> a +runFmt = flip unFmt id + +-- | Run a 'LogFmt'. +{-# INLINE runLogFmt #-} +runLogFmt :: IsString s => Fmt LogStr s a -> a +runLogFmt = flip unFmt (fromString . B.unpack . fromLogStr) +{-# SPECIALIZE runLogFmt :: Fmt LogStr BL.ByteString a -> a #-} +{-# SPECIALIZE runLogFmt :: Fmt LogStr ByteString a -> a #-} +{-# SPECIALIZE runLogFmt :: Fmt LogStr String a -> a #-} +{-# SPECIALIZE runLogFmt :: Fmt LogStr LogStr a -> a #-} +{-# SPECIALIZE runLogFmt :: Fmt LogStr Builder a -> a #-} + +-- | Format a constant value of type @m@. +{-# INLINE fmt #-} +fmt :: m -> Fmt m a a +fmt m = Fmt ($ m) + +-- | Format a constant value of type @m@. +{-# INLINE logFmt #-} +logFmt :: ToLogStr m => m -> Fmt LogStr a a +logFmt = fmt . toLogStr + +-- | Concatenate two formatters. +infixr 0 % + +{-# INLINE (%) #-} +(%) :: Semigroup m => Fmt m b c -> Fmt m a b -> Fmt m a c +f % g = + f + `bind` \a -> + g + `bind` \b -> fmt (a <> b) + +-- | Apply a 'Fmt1' to a 'Fmt'. +{-# INLINE apply #-} +apply :: Fmt1 m s m -> Fmt m s a -> Fmt m s a +apply (Fmt f) (Fmt a) = Fmt (a . f) + +-- | Indexed bind. +{-# INLINE bind #-} +bind :: Fmt m a1 b -> (m -> Fmt m a2 a1) -> Fmt m a2 b +bind m f = Fmt $ \k -> unFmt m (\a -> unFmt (f a) k) + +-- | Concatenate a collection of formatters. +{-# INLINE cat #-} +cat :: (Monoid m, Foldable f) => f (Fmt m a a) -> Fmt m a a +cat = foldr (%) C.id + +-- | Map over the the formatting @Monoid@. +{-# INLINE refmt #-} +refmt :: (m1 -> m2) -> Fmt m1 a b -> Fmt m2 a b +refmt m12 (Fmt f) = Fmt $ \a -> f (a . m12) + +{- | Replace one occurance of a search term. + + > replace1 "bar" "foo" "foobarbaz" + "foofoobaz" +-} +{-# INLINE replace1 #-} +replace1 :: ByteString -> Fmt LogStr a a -> Fmt LogStr a b -> Fmt LogStr a b +replace1 x y = + splitWith (B.breakSubstring x) $ \l r0 -> + case B.stripPrefix x r0 of + Nothing -> logFmt l + Just r -> cat [logFmt l, y, logFmt r] + +{-# INLINE splitWith #-} +splitWith :: + (ByteString -> (ByteString, ByteString)) -> -- Splitter + (ByteString -> ByteString -> Fmt LogStr a2 a1) -> -- Joiner + Fmt LogStr a1 b -> + Fmt LogStr a2 b +splitWith break join = flip bind $ uncurry join . break . fromLogStr + +-- Fmt1 + +------------------------- + +{- | A unary higher-order formatter. + + @ 'Fmt1' m s a ~ (m -> s) -> a -> s @ +-} +type Fmt1 m s a = Fmt m s (a -> s) + +{- | A binary higher-order formatter. + + @ 'Fmt2' m s a b ~ (m -> s) -> a -> b -> s @ +-} +type Fmt2 m s a b = Fmt m s (a -> b -> s) + +{- | A ternary higher-order formatter. + + @ 'Fmt3' m s a b c ~ (m -> s) -> a -> b -> c -> s @ +-} +type Fmt3 m s a b c = Fmt m s (a -> b -> c -> s) + +{- | Format a value of type @a@ using a function of type @a -> m@. + + @ 'runFmt' . 'fmt1' :: (a -> m) -> a -> m @ +-} +{-# INLINE fmt1 #-} +fmt1 :: (a -> m) -> Fmt1 m s a +fmt1 f = Fmt $ \k -> k . f + +{-# INLINE fmt2 #-} +fmt2 :: (a -> b -> m) -> Fmt2 m s a b +fmt2 f = Fmt $ \k -> fmap k . f + +{-# INLINE fmt1_ #-} +fmt1_ :: Fmt m a a -> Fmt1 m a b +fmt1_ = lmap const . closed + +{-# INLINE fmt2_ #-} +fmt2_ :: Fmt m a a -> Fmt2 m a b c +fmt2_ = lmap (const . const) . (closed . closed) + +-- | Concatenate two formatters, applying both to the same input. +infixr 6 .% + +{-# INLINE (.%) #-} +(.%) :: Semigroup m => Fmt1 m s a -> Fmt1 m s a -> Fmt1 m s a +f .% g = + Fmt + ( \k a -> + unFmt f (\b1 -> unFmt g (\b2 -> k (b1 <> b2)) a) a + ) + +{- | Format each value in a list and concatenate them all: + + >>> runFmt (cat1 (s % " ")) ["one", "two", "three"] + "one two three " +-} +{-# INLINE cat1 #-} +cat1 :: (Monoid m, Foldable f) => Fmt1 m m a -> Fmt1 m s (f a) +cat1 f = fmt1 $ foldMap (runFmt f) + +{- | Use the given text-joining function to join together the individually rendered items of a list. + + >>> runLogFmt (cat1With (mconcat . reverse) d) [123, 456, 789] + "789456123" + + @ + 'cat1With' 'L.unlines' :: 'Foldable' f => 'Fmt1' 'LogStr' 'String' a -> 'Fmt1' 'LogStr' s (f a) + 'cat1With' 'T.unlines' :: 'Foldable' f => 'Fmt1' 'LogStr' 'T.Text' a -> 'Fmt1' 'LogStr' s (f a) + 'cat1With' 'B.unlines' :: 'Foldable' f => 'Fmt1' 'LogStr' 'B.ByteString' a -> 'Fmt1' 'LogStr' s (f a) + 'cat1With' '$' 'L.intercalate' " " :: 'Foldable' f => 'Fmt1' 'LogStr' 'String' a -> 'Fmt1' 'LogStr' s (f a) + 'cat1With' '$' 'T.intercalate' " " :: 'Foldable' f => 'Fmt1' 'LogStr' 'T.Text' a -> 'Fmt1' 'LogStr' s (f a) + 'cat1With' '$' 'B.intercalate' " " :: 'Foldable' f => 'Fmt1' 'LogStr' 'B.ByteString' a -> 'Fmt1' 'LogStr' s (f a) + @ +-} +{-# INLINEABLE cat1With #-} +cat1With :: + (Foldable f, ToLogStr str, IsString str) => + ([str] -> str) -> + Fmt1 LogStr str a -> + Fmt1 LogStr s (f a) +cat1With join f = fmt1 $ toLogStr . join . fmap (runLogFmt f) . toList +{-# SPECIALIZE cat1With :: Foldable f => ([LogStr] -> LogStr) -> Fmt1 LogStr LogStr a -> Fmt1 LogStr s (f a) #-} +{-# SPECIALIZE cat1With :: Foldable f => ([Builder] -> Builder) -> Fmt1 LogStr Builder a -> Fmt1 LogStr s (f a) #-} +{-# SPECIALIZE cat1With :: Foldable f => ([ByteString] -> ByteString) -> Fmt1 LogStr ByteString a -> Fmt1 LogStr s (f a) #-} +{-# SPECIALIZE cat1With :: Foldable f => ([BL.ByteString] -> BL.ByteString) -> Fmt1 LogStr BL.ByteString a -> Fmt1 LogStr s (f a) #-} + +{- | Turn a text-splitting function into a formatting combinator. + + @ + 'split1With' 'hsep' :: ('Traversable' f, 'ToLogStr' msg) => ('ByteString' -> f msg) -> 'Fmt' 'LogStr' s a -> 'Fmt' 'LogStr' s a + 'split1With' 'vsep' :: ('Traversable' f, 'ToLogStr' msg) => ('ByteString' -> f msg) -> 'Fmt' 'LogStr' s a -> 'Fmt' 'LogStr' s a + 'split1With' 'list1' :: ('Traversable' f, 'ToLogStr' msg) => ('ByteString' -> f msg) -> 'Fmt' 'LogStr' s a -> 'Fmt' 'LogStr' s a + @ + >>> commas = reverse . fmap BL.reverse . BL.chunksOf 3 . BL.reverse + >>> dollars = prefix "$" . split1With commas (intercalate ",") . reversed + >>> runLogFmt (dollars d) 1234567890 + "$1,234,567,890" + >>> printf (split1With (BL.splitOn ",") vsep t) "one,two,three" + one + two + three + >>> printf (split1With (BL.splitOn ",") (indentEach 4) t) "one,two,three" + one + two + three +-} +{-# INLINEABLE split1With #-} +split1With :: + (Traversable f, ToLogStr str) => + (Fmt1 m s_ m -> Fmt1 m m (f LogStr)) -> + (ByteString -> f str) -> + Fmt LogStr s a -> + Fmt m s a +split1With lf split (Fmt g) = Fmt (g . (. runFmt (lf $ fmt1 id) . fmap toLogStr . split . fromLogStr)) + +-- Html + +------------------------- + +{- | Format HTML + + For example: + + @ + contact :: 'Html' 'LogStr' + contact = 'Data.Fmt.Html.p' "You can reach me at" '%' 'Data.Fmt.Html.ul' . 'spr' . 'Data.Fmt.Html.li' $ do + c1 <- 'Data.Fmt.Html.a' '!' 'href' @String "https://example.com" $ "Website" + c2 <- 'Data.Fmt.Html.a' '!' 'href' @String "mailto:cmk@example.com" $ "Email" + 'pure' $ c1 '<>' c2 + @ + + generates the following output: + + > "You can reach me at
" +-} +type Html a = Fmt LogStr a a + +toHtml :: ToLogStr s => s -> Html a +toHtml = logFmt + +comment :: ToLogStr s => s -> Html a +comment = enclose "" . toHtml + +-- | Type for an attribute. +newtype Attr = Attr (forall a. Html a -> Html a) + +instance Semigroup Attr where + Attr f <> Attr g = Attr (g . f) + +instance Monoid Attr where + mempty = Attr id + +{- | Apply an attribute to an HTML tag. + + The interface is similar to < https://hackage.haskell.org/package/blaze-builder >. + + You should not define your own instances of this class. +-} +class Element html where + {- | Apply an attribute to an element. + + >>> printf $ img ! src "foo.png" +
+
+ This can be used on nested elements as well:
+
+ >>> printf $ p ! style "float: right" $ "Hello!"
+ Hello!
+ -} + (!) :: html -> Attr -> html + +instance Element (Html a) where + h ! (Attr f) = f h + {-# INLINE (!) #-} + +instance Element (Html a -> Html b) where + h ! f = (! f) . h + {-# INLINE (!) #-} + +{- | Shorthand for setting an attribute depending on a conditional. + + Example: + + > p !? (isBig, A.class "big") $ "Hello" + + Gives the same result as: + + > (if isBig then p ! A.class "big" else p) "Hello" +-} +(!?) :: Element html => html -> (Bool, Attr) -> html +(!?) h (c, a) = if c then h ! a else h + +-- Formatting + +------------------------- + +{- | Format each value in a list with spaces in between: + + >>> runLogFmt (hsep d) [1, 2, 3] + "1 2 3" +-} +hsep :: Foldable f => Fmt1 LogStr ByteString a -> Fmt1 LogStr s (f a) +hsep = cat1With $ B.intercalate " " +{-# INLINE hsep #-} + +{- | Format each value in a list, placing each on its own line: + + >>> printf (vsep c) ['a'..'c'] + a + b + c +-} +vsep :: Foldable f => Fmt1 LogStr ByteString a -> Fmt1 LogStr s (f a) +vsep = cat1With B.unlines +{-# INLINE vsep #-} + +{- | Format a list of items, placing one per line, indent by the given number of spaces. + + @ 'indentEach' n = 'Test.Contra.Type.Format.vsep' . 'indent' n @ + + >>> printf (split1With BL.lines (indentList 2) t) "one\ntwo\nthree" + one + two + three + >>> printf ("The lucky numbers are:\n" % indentList 2 d) [7, 13, 1, 42] + The lucky numbers are: + 7 + 13 + 1 + 42 +-} +hang :: Foldable f => Int -> Fmt1 LogStr ByteString a -> Fmt1 LogStr s (f a) +hang n = vsep . indent n +{-# INLINE hang #-} + +{- | Insert the given number of spaces at the start of the rendered text: + + >>> runFmt (indent 4 d) 7 + " 7" + + Note that this only indents the first line of a multi-line string. + To indent all lines see 'reindent'. +-} +indent :: (IsString m, Semigroup m) => Int -> Fmt m a b -> Fmt m a b +indent n = prefix $ fromString $ replicate n ' ' +{-# INLINEABLE indent #-} + +{- | Add the given prefix to the formatted item: + + >>> runLogFmt ("The answer is: " % prefix "wait for it... " d) 42 + "The answer is: wait for it... 42" + + >>> printf (vsep (indent 4 (prefix "- " d))) [1, 2, 3] + - 1 + - 2 + - 3 +-} +prefix :: Semigroup m => m -> Fmt m a b -> Fmt m a b +prefix s f = fmt s % f +{-# INLINE prefix #-} + +-- | Add the given suffix to the formatted item. +suffix :: Semigroup m => m -> Fmt m a b -> Fmt m a b +suffix s f = f % fmt s +{-# INLINE suffix #-} + +{- | Enclose the output string with the given strings: + + >>> runFmt (parens $ enclose v s ", ") 1 "two" + "(1, two)" + >>> runFmt (enclose (fmt "") s) "an html comment" + "" +-} +enclose :: Semigroup m => Fmt m b2 c -> Fmt m a b1 -> Fmt m b1 b2 -> Fmt m a c +enclose pre suf f = pre % f % suf +{-# INLINE enclose #-} + +-- @ 'tuple' 'd' 'd' :: 'LogFmt2' a 'Int' @ +-- +-- >>> runFmt (tuple d t) 1 "two" +-- "(1, two)" +tuple :: (Semigroup m, IsString m) => Fmt m b c -> Fmt m a b -> Fmt m a c +tuple f1 f2 = parens $ enclose f1 f2 ", " + +{- | Add double quotes around the formatted item: + + Use this to escape a string: + + >>> runFmt ("He said it was based on " % quotes t' % ".") "science" + He said it was based on "science". +-} +quotes :: (Semigroup m, IsString m) => Fmt m a b -> Fmt m a b +quotes = enclose "\"" "\"" +{-# INLINE quotes #-} + +{- | Add single quotes around the formatted item: + + >>> let obj = Just Nothing in format ("The object is: " % quotes' shown % ".") obj + "The object is: 'Just Nothing'." +-} +quotes' :: (Semigroup m, IsString m) => Fmt m a b -> Fmt m a b +quotes' = enclose "'" "'" +{-# INLINE quotes' #-} + +{- | Add parentheses around the formatted item: + + >>> runFmt ("We found " % parens d % " discrepancies.") 17 + "We found (17) discrepancies." + + >>> printf (get 5 (list1 (parens d))) [1..] + [(1), (2), (3), (4), (5)] +-} +parens :: (Semigroup m, IsString m) => Fmt m a b -> Fmt m a b +parens = enclose "(" ")" +{-# INLINE parens #-} + +{- | Add braces around the formatted item: + + >>> runFmt ("\\begin" % braces t) "section" + "\\begin{section}" +-} +braces :: (Semigroup m, IsString m) => Fmt m a b -> Fmt m a b +braces = enclose "{" "}" +{-# INLINE braces #-} + +{- | Add square brackets around the formatted item: + + >>> runFmt (brackets d) 7 + "[7]" +-} +brackets :: (Semigroup m, IsString m) => Fmt m a b -> Fmt m a b +brackets = enclose "[" "]" +{-# INLINE brackets #-} + +{- | Add backticks around the formatted item: + + >>> runLogFmt ("Be sure to run " % backticks builder % " as root.") ":(){:|:&};:" + "Be sure to run `:(){:|:&};:` as root." +-} +backticks :: (Semigroup m, IsString m) => Fmt m a b -> Fmt m a b +backticks = enclose "`" "`" +{-# INLINE backticks #-} + +-- Collections + +------------------------- + +{- | Render the value in a Left with the given formatter, rendering a Right as an empty string: + + >>> runLogFmt (left1 text) (Left "bingo") + "bingo" + + >>> runLogFmt (left1 text) (Right 16) + "" +-} +left1 :: IsString m => Fmt1 m m a -> Fmt1 m s (Either a b) +left1 f = either1 f (fmt1 $ const "") +{-# INLINE left1 #-} + +{- | Render the value in a Right with the given formatter, rendering a Left as an empty string: + + >>> runLogFmt (right1 text) (Left 16) + "" + + >>> runLogFmt (right1 text) (Right "bingo") + "bingo" +-} +right1 :: IsString m => Fmt1 m m b -> Fmt1 m s (Either a b) +right1 = either1 (fmt1 $ const "") +{-# INLINE right1 #-} + +{- | Render the value in an Either: + + >>> runLogFmt (either1 text int) (Left "Error!" + "Error!" + + >>> runLogFmt (either1 text int) (Right 69) + "69" +-} +either1 :: Fmt1 m m a -> Fmt1 m m b -> Fmt1 m s (Either a b) +either1 l r = fmt1 $ either (runFmt l) (runFmt r) +{-# INLINE either1 #-} + +{- | Render a Maybe value either as a default (if Nothing) or using the given formatter: + + >>> runLogFmt (maybe1 "Goodbye" text) Nothing + "Goodbye" + + >>> runLogFmt (maybe1 "Goodbye" text) (Just "Hello") + "Hello" +-} +maybe1 :: m -> Fmt1 m m a -> Fmt1 m s (Maybe a) +maybe1 def f = fmt1 $ maybe def (runFmt f) +{-# INLINE maybe1 #-} + +{- | Add square brackets around the Foldable (e.g. a list), and separate each formatted item with a comma and space. + + >>> runLogFmt (list1 s) ["one", "two", "three"] + "[one, two, three]" + >>> printf (quotes $ list1 d) [1,2,3] + ["1", "2", "3"] + >>> printf (quotes $ list1 s) ["one", "two", "three"] + ["one", "two", "three"] +-} +list1 :: Foldable f => Fmt1 LogStr ByteString a -> Fmt1 LogStr s (f a) +list1 = cat1With (B.intercalate ", ") . brackets +{-# INLINE list1 #-} + +{- | A JSON-style formatter for lists. + + >>> printf jsonList [1,2,3] + [ + 1 + , 2 + , 3 + ] + + Like 'yamlListF', it handles multiline elements well: + + >>> fmt $ jsonListF ["hello\nworld", "foo\nbar\nquix"] + [ + hello + world + , foo + bar + quix + ] +-} +{-# INLINE jsonList #-} +jsonList :: (Foldable f, ToLogStr a) => Fmt1 LogStr s (f a) +jsonList = fmt1 f + where + f xs + | null items = "[]\n" + | otherwise = "[\n" <> mconcat items <> "]\n" + where + items = zipWith buildItem (True : repeat False) (toList xs) + -- Item builder + --buildItem :: Bool -> a -> B + + buildItem isFirst x = + case map toLogStr (B.lines (fromLogStr (toLogStr x))) of + [] + | isFirst -> "\n" + | otherwise -> ",\n" + (h : t) -> + mconcat . map (<> "\n") $ + if isFirst + then " " <> h : fmap (" " <>) t + else ", " <> h : fmap (" " <>) t + +{- | A multiline formatter for lists. + + >>> printf (yamlList d) [1,2,3] + - 1 + - 2 + - 3 + + Multi-line elements are indented correctly: + + >>> printf (yamlList s) ["hello\nworld", "foo\nbar\nquix"] + - hello + world + - foo + bar + quix +-} +{-# INLINE yamlList #-} +yamlList :: (Foldable f, ToLogStr a) => Fmt1 LogStr s (f a) +yamlList = fmt1 f + where + f xs = if null items then "[]\n" else mconcat items + where + bullet = "-" + spaces = " " + newline = "\n" + items = map buildItem (toList xs) + buildItem x = case B.lines (fromLogStr (toLogStr x)) of + [] -> bullet <> newline + (l : ls) -> + bullet <> " " <> toLogStr l <> newline + <> mconcat [spaces <> toLogStr s <> newline | s <- ls] + +{- | A JSON-like map formatter; works for Map, HashMap, etc, and lists of pairs. + +>>> fmt $ jsonMapF [("Odds", jsonListF [1,3]), ("Evens", jsonListF [2,4])] +{ + Odds: + [ + 1 + , 3 + ] +, Evens: + [ + 2 + , 4 + ] +} +-} +{-# INLINE jsonMap #-} +jsonMap :: (ToLogStr k, IsList map, Item map ~ (k, ByteString)) => Fmt1 LogStr s map +jsonMap = fmt1 f + where + f xs + | null items = "{}\n" + | otherwise = "{\n" <> mconcat items <> "}\n" + where + items = zipWith buildItem (True : repeat False) (IsList.toList xs) + -- Item builder + --buildItem :: Bool -> (k, v) -> B + buildItem isFirst (k, v) = do + let kb = (if isFirst then " " else ", ") <> toLogStr k + case map toLogStr (B.lines v) of + [] -> kb <> ":\n" + [l] -> kb <> ": " <> l <> "\n" + ls -> + kb <> ":\n" + <> mconcat [" " <> s <> "\n" | s <- ls] + +-- | A YAML-like map formatter: +-- +-- >>> BL.putStrLn $ BL.toLazyByteString $ yamlMapF id id [("Odds", yamlListF (BL.fromString . show) "-" [1,3]), ("Evens", yamlListF (BL.fromString . show) "-" [2,4])] +-- Odds: +-- - 1 +-- - 3 +-- Evens: +-- - 2 +-- - 4 +{-# INLINE yamlMap #-} +yamlMap :: (ToLogStr k, ToLogStr v, IsList map, Item map ~ (k, v)) => Fmt1 LogStr s map +yamlMap = fmt1 f + where + f xs + | null items = "{}\n" + | otherwise = mconcat items + where + items = map (\(k, v) -> nameF (toLogStr k) (toLogStr v)) (IsList.toList xs) + +nameF :: LogStr -> LogStr -> LogStr +nameF k v = case B.lines (fromLogStr v) of + [] -> k <> ":\n" + [l] -> k <> ": " <> toLogStr l <> "\n" + ls -> + k <> ":\n" + <> mconcat [" " <> toLogStr s <> "\n" | s <- ls] diff --git a/src/Data/Fmt/Ansi.hs b/src/Data/Fmt/Ansi.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fmt/Ansi.hs @@ -0,0 +1,102 @@ +module Data.Fmt.Ansi ( + -- * Ansi terminal codes + code, + codes, + erase, + reset, + shift, + scroll, + + -- ** Emphasis + blink, + bold, + faint, + italic, + underline, + + -- ** Color + dull, + vivid, + layer, + palette, + Palette, + XColor, + Color (..), + ConsoleLayer (..), +) where + +import Data.Fmt +import Data.Word +import System.Console.ANSI.Codes +import System.Console.ANSI.Types + +-- Ansi terminal formatters + +------------------------- + +code :: (Semigroup m, IsString m) => SGR -> Fmt m s a -> Fmt m s a +code = codes . pure + +-- | Wrap content with escape sequence to set and reset color of normal intensity. +codes :: (Semigroup m, IsString m) => [SGR] -> Fmt m s a -> Fmt m s a +codes sgr x = enclose before after x + where + before = fromString $ setSGRCode sgr + after = fromString $ setSGRCode [Reset] + +erase :: (Semigroup m, IsString m) => Ordering -> Fmt m s a -> Fmt m s a +erase LT = suffix $ fromString clearFromCursorToLineBeginningCode +erase EQ = suffix $ fromString clearLineCode +erase GT = suffix $ fromString clearFromCursorToLineEndCode + +reset :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a +reset = prefix $ fromString $ setSGRCode [Reset] + +shift :: (Semigroup m, IsString m) => Either Int Int -> Fmt m s a -> Fmt m s a +shift = prefix . fromString . either cursorBackwardCode cursorForwardCode + +scroll :: (Semigroup m, IsString m) => Either Int Int -> Fmt m s a -> Fmt m s a +scroll = prefix . fromString . either scrollPageUpCode scrollPageDownCode + +-- Emphasis + +------------------------- + +blink :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a +blink = code $ SetBlinkSpeed SlowBlink + +bold :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a +bold = code $ SetConsoleIntensity BoldIntensity + +italic :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a +italic = code $ SetItalicized True + +underline :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a +underline = code $ SetUnderlining SingleUnderline + +faint :: (Semigroup m, IsString m) => Fmt m s a -> Fmt m s a +faint = code $ SetConsoleIntensity FaintIntensity + +-- Color + +------------------------- + +-- | The xterm < https://en.wikipedia.org/wiki/8-bit_color 8 bit > color encoding. +type XColor = Word8 + +-- | A simple palette consisting of a foreground and background color. +type Palette = (XColor, XColor) + +dull :: (Semigroup m, IsString m) => Color -> ConsoleLayer -> Fmt m s a -> Fmt m s a +dull = layer . xtermSystem Dull + +vivid :: (Semigroup m, IsString m) => Color -> ConsoleLayer -> Fmt m s a -> Fmt m s a +vivid = layer . xtermSystem Vivid + +--vivid col lay = code $ SetColor lay Vivid col + +layer :: (Semigroup m, IsString m) => XColor -> ConsoleLayer -> Fmt m s a -> Fmt m s a +layer pal lay = code $ SetPaletteColor lay pal + +palette :: (Semigroup m, IsString m) => Palette -> Fmt m s a -> Fmt m s a +palette (fg, bg) = codes [SetPaletteColor Foreground fg, SetPaletteColor Background bg] diff --git a/src/Data/Fmt/Attr.hs b/src/Data/Fmt/Attr.hs new file mode 100644 --- /dev/null +++ b/src/Data/Fmt/Attr.hs @@ -0,0 +1,3414 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | Html5 formatting. + + The API is similar to < https://hackage.haskell.org/package/blaze-html >. +-} +module Data.Fmt.Attr ( + -- * Html + Html, + Attr, + toHtml, + comment, + Element (..), + (!?), + + -- * Attributes + accept, + acceptCharset, + accesskey, + action, + alt, + async, + autocomplete, + autofocus, + autoplay, + challenge, + charset, + checked, + cite, + class_, + cols, + colspan, + content, + contenteditable, + contextmenu, + controls, + coords, + data_, + datetime, + defer, + dir, + disabled, + draggable, + enctype, + for, + form, + formaction, + formenctype, + formmethod, + formnovalidate, + formtarget, + headers, + height, + hidden, + high, + href, + hreflang, + httpEquiv, + icon, + id, + ismap, + item, + itemprop, + itemscope, + itemtype, + keytype, + label, + lang, + list, + loop, + low, + manifest, + max, + maxlength, + media, + method, + min, + multiple, + name, + novalidate, + onbeforeonload, + onbeforeprint, + onblur, + oncanplay, + oncanplaythrough, + onchange, + onclick, + oncontextmenu, + ondblclick, + ondrag, + ondragend, + ondragenter, + ondragleave, + ondragover, + ondragstart, + ondrop, + ondurationchange, + onemptied, + onended, + onerror, + onfocus, + onformchange, + onforminput, + onhaschange, + oninput, + oninvalid, + onkeydown, + onkeyup, + onload, + onloadeddata, + onloadedmetadata, + onloadstart, + onmessage, + onmousedown, + onmousemove, + onmouseout, + onmouseover, + onmouseup, + onmousewheel, + ononline, + onpagehide, + onpageshow, + onpause, + onplay, + onplaying, + onprogress, + onpropstate, + onratechange, + onreadystatechange, + onredo, + onresize, + onscroll, + onseeked, + onseeking, + onselect, + onstalled, + onstorage, + onsubmit, + onsuspend, + ontimeupdate, + onundo, + onunload, + onvolumechange, + onwaiting, + open, + optimum, + pattern, + ping, + placeholder, + preload, + pubdate, + radiogroup, + readonly, + rel, + required, + reversed, + role, + rows, + rowspan, + sandbox, + scope, + scoped, + seamless, + selected, + shape, + size, + sizes, + span, + spellcheck, + src, + srcdoc, + start, + step, + style, + subject, + summary, + tabindex, + target, + title, + type_, + usemap, + value, + width, + wrap, + xmlns, +) where + +import qualified Data.ByteString.Char8 as B +import Data.Fmt +import Prelude (Eq (..), Maybe (..), Monoid (..), ($), (||)) + +attr :: ToLogStr s => LogStr -> s -> Attr +attr k v = Attr $ splitWith f g + where + f = B.break $ \c -> c == '/' || c == '>' + g l r0 = case B.uncons r0 of + Just ('/', r) -> toHtml l % fmt k % "=" % quotes (toHtml v) % fmt " /" % toHtml r + Just ('>', r) -> toHtml l % " " % fmt k % "=" % quotes (toHtml v) % fmt ">" % toHtml r + _ -> fmt mempty + +-- Attributes + +------------------------- + +{- | Combinator for the @accept@ attribute. + + Example: + + > div ! accept "bar" $ "Hello." + + Result: + + >You can reach me at
" + +-- | Run a monadic expression. +-- +-- This executes the formatting commands contained in the expression and +-- returns the result as a variable. +run :: Fmt m m n -> Fmt n a a +run = fmt . runFmt + +-- > runLogFmt $ numbers 2 +-- "A list of numbers:
The end.
" +numbers :: Int -> Html LogStr +numbers n = html $ do + l <- ul . cat $ li . toHtml <$> [1 .. n] + cat + [ p "A list of numbers:" + , fmt l + , p "The end." + ] + +-- | Create a < https://en.wikipedia.org/wiki/HTML_element#Syntax tag > for an element. +element :: String -> Html a -> Html a +element = enclose <$> (enclose "<" ">" . toHtml) <*> (enclose "" . toHtml) + +element_ :: String -> Html a +element_ = enclose "<" " />" . toHtml + +-- Elements + +------------------------- + +{- | Combinator for the document type. This should be placed at the top + of every HTML page. + + Example: + + > docType + + Result: + + > +-} +docType :: + -- | The document type HTML. + Html a +docType = "\n" +{-# INLINE docType #-} + +{- | Combinator for the @\@ element. This combinator will also + insert the correct doctype. + + Example: + + > docTypeHtml $ span $ fmt "foo" + + Result: + + > + > foo +-} +docTypeHtml :: + -- | Inner HTML. + Html a -> + -- | Resulting HTML. + Html a +docTypeHtml inner = docType % html inner +{-# INLINE docTypeHtml #-} + +{- | Combinator for the @\@ element. + + Example: + + > a $ span $ fmt "foo" + + Result: + + > foo +-} +a :: + -- | Inner HTML. + Html a -> + -- | Resulting HTML. + Html a +a = element "a" +{-# INLINE a #-} + +{- | Combinator for the @\@ element. + + Example: + + > abbr $ span $ fmt "foo" + + Result: + + > foo +-} +abbr :: + -- | Inner HTML. + Html a -> + -- | Resulting HTML. + Html a +abbr = element "abbr" +{-# INLINE abbr #-} + +{- | Combinator for the @\@ element. + + Example: + + > address $ span $ fmt "foo" + + Result: + + > foo +-} +address :: + -- | Inner HTML. + Html a -> + -- | Resulting HTML. + Html a +address = element "address" +{-# INLINE address #-} + +{- | Combinator for the @\@ element. + + Example: + + > area + + Result: + + > +-} +area :: + -- | Resulting HTML. + Html a +area = element_ "area" +{-# INLINE area #-} + +{- | Combinator for the @\