diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,39 @@ +0.5.3 +===== +* [!1352](https://gitlab.com/morley-framework/morley/-/merge_requests/1352) + Clean-up Buildable ExecutorOp implementation + + New convenience combinators, for `Buildable`: `quoteF` and `quoteF'` +* [!1360](https://gitlab.com/morley-framework/morley/-/merge_requests/1360) + Add generic-deriving default Buildable implementation + + We already had `GenericBuildable` which could be used with `DerivingVia`, + this just adds an option to use `Buildable` with `DeriveAnyClass` for the + same effect, which is a bit more DRY. +* [!1351](https://gitlab.com/morley-framework/morley/-/merge_requests/1351) + Fix and improve `Buildable MichelsonFailureWithStack` + + Slightly tweak reflowing braces (`++|`, `|++`) for smarter line breaks + + Add a couple more useful formatters, `flatAltF` and its particularly useful + specialization, `quoteOrIndentF` +* [!1346](https://gitlab.com/morley-framework/morley/-/merge_requests/1346) + Use proper datatype for Micheline primitives, refactor some FromExp instances + + Add `toEnumSafe`, a total version of `toEnum` for `Bounded` types + + Add `punctuateF` formatter to `Fmt` +* [!1348](https://gitlab.com/morley-framework/morley/-/merge_requests/1348) + Make `length` polymorphic in its return value +* [!1342](https://gitlab.com/morley-framework/morley/-/merge_requests/1342) + Implement `prettyprinter`-compatible replacement for `fmt` + + New modules, `Fmt`, `Fmt.Buildable`, `Fmt.Operators`, `Fmt.Utils` (the + latter three are reexported by the former) + + `Fmt.Buildable` implements `fmt`-like API on top of `prettyprinter` + + `Fmt.Operators` implements Wadler-Leijen operators missing from + `prettyprinter`. Additionally, these operators have smart `mempty` handling + + `Fmt.Utils` has some handy type synonyms and helper functions + + **Important**: `Buildable` operates on `Doc` instead of `Builder`; having a + synonym would be more confusing than helpful, so there isn't one; update + your code accordingly + 0.5.2 ===== * [!1290](https://gitlab.com/morley-framework/morley/-/merge_requests/1290) diff --git a/morley-prelude.cabal b/morley-prelude.cabal --- a/morley-prelude.cabal +++ b/morley-prelude.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morley-prelude -version: 0.5.2 +version: 0.5.3 synopsis: A custom prelude used in Morley description: A custom prelude used in Morley. It re-exports the Universum prelude and makes some tiny changes. category: Prelude @@ -27,8 +27,13 @@ library exposed-modules: Debug + Fmt + Fmt.Buildable + Fmt.Operators + Fmt.Utils Morley.Prelude.Boolean Morley.Prelude.FromIntegral + Morley.Prelude.Length Morley.Prelude.Show Morley.Prelude.Word Prelude @@ -95,10 +100,12 @@ Cabal , OddWord , base-noprelude >=4.7 && <5 - , fmt + , bytestring , int-cast , lens + , prettyprinter , template-haskell + , text , time , universum default-language: Haskell2010 diff --git a/src/Fmt.hs b/src/Fmt.hs new file mode 100644 --- /dev/null +++ b/src/Fmt.hs @@ -0,0 +1,17 @@ +-- SPDX-FileCopyrightText: 2023 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Re-exporting Wadler-Leijen formatter utilities plus 'Buildable'. +module Fmt + ( module Exports + ) where + +import Universum (Text) + +import Fmt.Buildable as Exports +import Fmt.Operators as Exports +import Fmt.Utils as Exports + +{-# ANN module ("HLint: ignore" :: Text) #-} diff --git a/src/Fmt/Buildable.hs b/src/Fmt/Buildable.hs new file mode 100644 --- /dev/null +++ b/src/Fmt/Buildable.hs @@ -0,0 +1,1064 @@ +-- SPDX-FileCopyrightText: 2022 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Partially implements the interface provided by the @fmt@ package on top of +-- @prettyprinter@. +module Fmt.Buildable + ( Buildable(..) + , FromDoc(..) + , FromSimpleDoc(..) + , ReflowingDoc + -- * Helpers + , pretty + , prettyText + -- * Brackets + , (+|) + , (|+) + , (|++) + , (|++^) + , (++|) + -- * Formatters + , unlinesF + , unwordsF + , nameF + , indentF + , blockMapF + , blockMapF' + , blockListF + , blockListF' + , mapF + , mapF' + , listF + , listF' + , whenF + , unlessF + , enumerateF + , enumerateF' + , whenNE + , fillSepF + , fillSepF' + , reflowF + , singleLineF + , punctuateF + , punctuateF' + , quoteF + , quoteF' + , quoteOrIndentF + , flatAltF + , TupleF(..) + -- ** hexF + , FormatAsHex(..) + , Hex(..) + -- * Generics + , GenericBuildable(..) + , GBuildable(..) + , GetFields(..) + ) where + +import Universum + +import Data.ByteString.Builder qualified as BB +import Data.Foldable qualified as F +import Data.Text qualified as TS +import Data.Text.Lazy.Builder qualified as TLB +import Data.Text.Lazy.Builder.Int (hexadecimal) +import Data.Text.Lazy.Encoding qualified as TLE +import GHC.Exts (IsList, Item) +import GHC.Exts qualified as Exts +import GHC.Generics qualified as G +import Language.Haskell.TH (newName, reifyInstances) +import Language.Haskell.TH qualified as TH +import Language.Haskell.TH.Lib (appT, conT, listE, tupP, tupleT, varE, varP, varT) +import Prettyprinter qualified as WL hiding ((<+>)) +import Prettyprinter.Internal qualified as WL (unsafeTextWithoutNewlines) +import Prettyprinter.Render.Text qualified as WL +import Prettyprinter.Util qualified as WL + +import Fmt.Operators qualified as WL +import Fmt.Utils (Doc, isEmpty, renderOneLine) + +{- $setup +>>> import Prelude hiding (show) +>>> import Debug (show) +>>> import Fmt +-} + +---------------------------------------------------------------------------- +-- FromDoc +---------------------------------------------------------------------------- + +{- | Helper intermediary class to define 'FromDoc'. The primary motivation for +its existence is being able to override the default layout engine. + +>>> :{ +layoutNarrow = + Prettyprinter.layoutPretty Prettyprinter.LayoutOptions + {Prettyprinter.layoutPageWidth = Prettyprinter.AvailablePerLine 20 1} +:} + +>>> doc = reflowF "Lorem ipsum dolor sit amet, consectetur adipiscing elit." +>>> fmt doc +Lorem ipsum dolor sit amet, consectetur adipiscing elit. +>>> fmtSimple $ layoutNarrow doc +Lorem ipsum dolor +sit amet, +consectetur +adipiscing elit. +-} +class FromSimpleDoc a where + fmtSimple :: WL.SimpleDocStream ann -> a + +instance FromSimpleDoc TLB.Builder where + fmtSimple = TLB.fromLazyText . WL.renderLazy + +instance FromSimpleDoc BB.Builder where + fmtSimple = BB.lazyByteString . fmtSimple + +instance FromSimpleDoc LText where + fmtSimple = WL.renderLazy + +instance FromSimpleDoc Text where + fmtSimple = WL.renderStrict + +instance FromSimpleDoc String where + fmtSimple = toString @Text . fmtSimple + +instance FromSimpleDoc LByteString where + fmtSimple = encodeUtf8 . fmtSimple @LText + +instance FromSimpleDoc ByteString where + fmtSimple = encodeUtf8 . fmtSimple @LText + +instance a ~ () => FromSimpleDoc (IO a) where + fmtSimple = putText . fmtSimple + +-- | A class of things that can be produced from 'Doc' using the default layout +-- engine. Mostly various text types. +class FromDoc a where + {- | Render a 'Doc' to another format. + + >>> doc = "foo" :: Doc + >>> fmt doc :: Text + "foo" + >>> fmt doc :: LText + "foo" + >>> fmt doc :: String + "foo" + >>> fmt doc :: ByteString + "foo" + >>> fmt doc :: LByteString + "foo" + >>> fmt doc :: IO () + foo + >>> fmt doc :: Data.Text.Lazy.Builder.Builder + "foo" + >>> Data.ByteString.Builder.toLazyByteString (fmt doc :: Data.ByteString.Builder.Builder) + "foo" + -} + fmt :: Doc -> a + +instance FromDoc Doc where + fmt a = a + +-- | Default layout engine. Uses 80 columns with ribbon width 1. +layout :: Doc -> WL.SimpleDocStream () +layout = WL.layoutSmart WL.LayoutOptions {WL.layoutPageWidth = WL.AvailablePerLine 80 1} + +do + -- this isn't pretty, but it avoids an overlapping instance for FromDoc Doc + varty <- varT =<< newName "a" + reifyInstances ''FromSimpleDoc [varty] >>= mapM \case + (TH.InstanceD _ con (TH.AppT _ ty) _) -> do + inst <- appT (conT ''FromDoc) (pure ty) + TH.InstanceD Nothing con inst <$> [d|$(varP 'fmt) = fmtSimple . layout|] + _ -> error "impossible" + +---------------------------------------------------------------------------- +-- Buildable +---------------------------------------------------------------------------- + +-- | A thing that can be prettyprinted in human-readable (but not necessarily +-- machine-readable) format +class Buildable a where + -- | Make a document with human-readable representation + build :: a -> Doc + default build :: (Generic a, GBuildable (G.Rep a)) => a -> Doc + build = build . GenericBuildable + + -- | Used to avoid overlapping instances with 'String', cf. 'Prelude.showList'. + buildList :: [a] -> Doc + buildList = WL.align . WL.list . map build + +-- | Newtype wrapper for @DerivingVia@, that uses the corresponding instance of +-- 'WL.Pretty' to derive 'Buildable' +newtype ViaPretty a = ViaPretty {unViaPretty :: a} + +instance WL.Pretty a => Buildable (ViaPretty a) where + build = WL.pretty . unViaPretty + buildList = WL.prettyList . map unViaPretty + +instance Buildable Doc where + build x = x + +-- NB: see below for more instances (because TH staging) + +{- | Differs from the corresponding 'WL.Pretty' instance in one important +aspect. It converts newlines to hard lines. Thus, + +>>> str = "Hello,\nWorld!" :: String +>>> Prettyprinter.group @() $ Prettyprinter.pretty str +Hello, World! +>>> Prettyprinter.group $ build str +Hello, +World! +-} +instance Buildable Char where + build '\n' = WL.hardline + build c = WL.pretty c + buildList = build . toText + +{- | Differs from the corresponding 'WL.Pretty' instance in one important +aspect. It converts newlines to hard lines. + +>>> txt = "Hello,\nWorld!" :: Text +>>> Prettyprinter.group @() $ Prettyprinter.pretty txt +Hello, World! +>>> Prettyprinter.group $ build txt +Hello, +World! +-} +instance Buildable Text where + build = unlinesF . map (WL.unsafeTextWithoutNewlines @()) . TS.splitOn "\n" + +{- | Differs from the corresponding 'WL.Pretty' instance in one important +aspect. It converts newlines to hard lines. + +>>> txt = "Hello,\nWorld!" :: LText +>>> Prettyprinter.group @() $ Prettyprinter.pretty txt +Hello, World! +>>> Prettyprinter.group $ build txt +Hello, +World! +-} +instance Buildable LText where + build = build . toStrict + +instance Buildable TLB.Builder where + build = build . TLB.toLazyText + +instance Buildable a => Buildable [a] where build = buildList +instance Buildable a => Buildable (NonEmpty a) where build = buildList . toList + +{- | One important quirk of this instance is it skips over 'Nothing' values +entirely: + +>>> build $ [Just 1, Nothing, Just 3] +[1, 3] +-} +instance Buildable a => Buildable (Maybe a) where + build = maybe mempty build + buildList = buildList . catMaybes +instance Buildable a => Buildable (Identity a) where + build = build . runIdentity +instance Buildable a => Buildable (Const a b) where + build = build . getConst + +{- | + +>>> pretty (Left "foo" :: Either String Int) + +>>> pretty (Right 123 :: Either String Int) + +-} +instance (Buildable a, Buildable b) => Buildable (Either a b) where + build (Left a) = " build a <> ">" + build (Right b) = " build b <> ">" + +{- | + +>>> pretty (fromList [("foo", "bar"), ("baz", "quux")] :: Map Text Text) +{baz: quux, foo: bar} +-} +instance (Buildable k, Buildable v) => Buildable (Map k v) where + build = mapF . toPairs + +{- | + +>>> pretty (fromList ["foo", "bar", "baz", "quux"] :: Set Text) +[bar, baz, foo, quux] +-} +instance Buildable v => Buildable (Set v) where + build = listF + +---------------------------------------------------------------------------- +-- Helpers +---------------------------------------------------------------------------- + +-- | 'build' then 'fmt'. Convenience synonym for @fmt . build@. +pretty :: (Buildable a, FromDoc b) => a -> b +pretty = fmt . build + +-- | A less polymorphic version of 'pretty' for convenience. +prettyText :: Buildable a => a -> Text +prettyText = pretty + +-- | When the second argument is empty, return 'mempty', otherwise, return the +-- first argument. +whenNE :: Monoid a => a -> Doc -> a +{-# SPECIALIZE whenNE :: Doc -> Doc -> Doc #-} +whenNE z y + | isEmpty y = mempty + | otherwise = z + +---------------------------------------------------------------------------- +-- Brackets +---------------------------------------------------------------------------- + +infixr 1 +|, |+ + +{- | Left format bracket. Enclose the value to format in these for concise syntax: + +>>> :{ +data WorldType = Cruel | Wonderful + deriving (Generic, Buildable) +:} + +>>> sayHello worldType = "Hello, " +| worldType |+ " world!" +>>> sayHello Cruel +Hello, Cruel world! +>>> sayHello Wonderful +Hello, Wonderful world! +-} +(+|) :: FromDoc b => Doc -> Doc -> b +d1 +| d2 = fmt $ d1 <> d2 + +-- | Right format bracket +(|+) :: (Buildable a, FromDoc b) => a -> Doc -> b +a |+ d = fmt (build a <> d) + +infixr 1 ++|, |++, |++^ + +-- | Opaque type for reflowing brackets @++|@ @|++@. +newtype ReflowingDoc = ReflowingDoc (Text -> Doc) + +{- | Bracket versions of 'enumerateF'. Note that unlike with @|+@, both brackets +are required. + +>>> let splice = "lorem posuere dapibus in ut lorem." :: Doc +>>> let long_splice = splice <> " " <> splice +>>> :{ +"Lorem ipsum dolor sit amet, consectetur adipiscing elit." ++| splice + |++ "Morbi aliquet accumsan libero." ++| long_splice + |++ "Consectetur adipiscing elit." +:} +Lorem ipsum dolor sit amet, consectetur adipiscing elit. +lorem posuere dapibus in ut lorem. Morbi aliquet accumsan libero. +lorem posuere dapibus in ut lorem. lorem posuere dapibus in ut lorem. +Consectetur adipiscing elit. + +>>> let splice = build "lorem\nposuere\ndapibus" +>>> :{ +"Lorem ipsum dolor sit amet, consectetur adipiscing elit." ++| splice |++ + "Morbi aliquet accumsan libero." +:} +Lorem ipsum dolor sit amet, consectetur adipiscing elit. +lorem +posuere +dapibus +Morbi aliquet accumsan libero. +-} +(|++) :: Buildable a => a -> Doc -> ReflowingDoc +x |++ trail = ReflowingDoc $ reflowDoc' WL.group trail x + +{- | A version of the reflowing bracket that always breaks after a splice if +there's a break before the splice. + +Compare with the similar example for @|++@, notice the line break after +@splice@. It may be combined with 'quoteOrIndentF'. + +>>> let splice = "lorem posuere dapibus in ut lorem." :: Doc +>>> let long_splice = splice <> " " <> splice +>>> :{ +"Lorem ipsum dolor sit amet, consectetur adipiscing elit." ++| splice + |++^ "Morbi aliquet accumsan libero." ++| long_splice + |++^ "Consectetur adipiscing elit." +:} +Lorem ipsum dolor sit amet, consectetur adipiscing elit. +lorem posuere dapibus in ut lorem. +Morbi aliquet accumsan libero. +lorem posuere dapibus in ut lorem. lorem posuere dapibus in ut lorem. +Consectetur adipiscing elit. +-} +(|++^) :: Buildable a => a -> Doc -> ReflowingDoc +x |++^ trail = ReflowingDoc $ reflowDoc' id trail x + +reflowDoc' :: Buildable a => (Doc -> Doc) -> Doc -> a -> Text -> Doc +reflowDoc' tailGroup trail x (WL.reflow -> lead) = + lead + <> WL.group (whenNE WL.line lead + <> tailGroup (WL.align (build x) <> whenNE WL.line trail)) + WL. trail + +-- | Left formatting bracket. +(++|) :: FromDoc b => Text -> ReflowingDoc -> b +lead ++| (ReflowingDoc f) = fmt $ f lead + +---------------------------------------------------------------------------- +-- Formatters +---------------------------------------------------------------------------- + +{-| Join a 'Foldable' with hardlines. + +>>> Prettyprinter.group $ unlinesF ["foo", "bar", "baz"] +foo +bar +baz +-} +unlinesF :: (Foldable f, Buildable a) => f a -> Doc +unlinesF = WL.concatWith (WL.surround WL.hardline) . map build . F.toList + +{-| Join a 'Foldable' with spaces. + +>>> unwordsF ["foo", "bar", "baz"] +foo bar baz +-} +unwordsF :: (Buildable a, Foldable f) => f a -> Doc +unwordsF = WL.fillSep . map build . F.toList + + +{- | If @name@ and @content@ fit into the page width and @content@ doesn't +contain hard line breaks, layout as single line with @: @ between. Otherwise, +make a multiline layout, appending @:@ to @name@, and nesting @content@ by 2 +spaces. + +>>> nameF "Test" "foo" +Test: foo +>>> nameF "Test" $ fillSepF $ replicate 27 "foo" +Test: + foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo + foo foo foo foo foo foo foo foo + +If either name or content is empty, returns only the other one. + +>>> nameF "" "foo" +foo +>>> nameF "Test" "" +Test +-} +nameF :: Buildable a => Doc -> a -> Doc +nameF name (build -> content) + | isEmpty name = content + | isEmpty content = name + | otherwise = WL.group $ WL.nest 2 $ name <> ":" <> + WL.flatAlt (WL.hardline <> content) (WL.space <> content) + +{-| Indent 'Doc' by a given number of spaces. + +>>> indentF 4 "foo" + foo +>>> indentF 4 "foo\nbar" + foo + bar +-} +indentF :: Int -> Doc -> Doc +indentF = WL.indent + +{-| Print a map-like thing in the style of a YAML map. + +>>> blockMapF $ [("foo", "bar"), ("baz", "quux")] +foo: bar +baz: quux +>>> blockMapF ([] :: [(Text, Text)]) +{} +-} +blockMapF :: (Buildable k, Buildable v, IsList f, Item f ~ (k, v)) => f -> Doc +blockMapF = blockMapF' build build + +{- | Version of 'blockMapF' that allows explicitly passing functions to format +key and value. + +>>> blockMapF' hexF build $ [(123, "foo"), (456, "bar")] +7b: foo +1c8: bar +-} +blockMapF' :: (IsList f, Item f ~ (k, v)) => (k -> Doc) -> (v -> Doc) -> f -> Doc +blockMapF' fbuild_k fbuild_v xs + | null items = "{}" + | otherwise = unlinesF items + where + items = uncurry nameF . bimap fbuild_k fbuild_v <$> Exts.toList xs + +{- | Render a list-like thing, YAML style. + +>>> blockListF ["foo", "bar", "baz"] +- foo +- bar +- baz +>>> blockListF ([] :: [Text]) +[] +-} +blockListF :: (Buildable a, Foldable f) => f a -> Doc +blockListF = blockListF' "-" build + +{- | Version of 'blockListF' that allows explicitly passing a bullet style and +formatter for items + +>>> blockListF' "*" hexF [1,11,21] +* 1 +* b +* 15 +-} +blockListF' :: (Foldable f) => Doc -> (a -> Doc) -> f a -> Doc +blockListF' bullet fa xs + | F.null xs = "[]" + | otherwise = unlinesF $ map (buildItem . fa) $ F.toList xs + where + buildItem x + | isEmpty x = bullet + | otherwise = bullet WL.<+> WL.align x + +{-| Format a map-like thing, JSON-style. + +>>> mapF [("foo", "bar"), ("baz", "quux")] +{foo: bar, baz: quux} +>>> mapF ([] :: [(Text, Text)]) +{} +>>> mapF $ replicate 9 ("foo", "bar") +{ foo: bar +, foo: bar +... +, foo: bar } +>>> mapF $ [("foo", "bar\nquux"), ("baz", "corge")] +{ foo: + bar + quux +, baz: corge } +-} +mapF :: (Buildable k, Buildable v, IsList f, Item f ~ (k, v)) => f -> Doc +mapF = mapF' build build + +{-| Version of 'mapF' allowing for custom formatters. + +>>> mapF' hexF build [(128, "foo"), (512, "bar")] +{80: foo, 200: bar} +-} +mapF' :: (IsList f, Item f ~ (k, v)) => (k -> Doc) -> (v -> Doc) -> f -> Doc +mapF' fk fv + = WL.group + . WL.encloseSep lbrace rbrace ", " + . map (WL.align . uncurry nameF . bimap fk fv) + . Exts.toList + where + lbrace = WL.flatAlt "{ " "{" + rbrace = WL.flatAlt " }" "}" + +{-| Print a list, JSON-style. + +>>> listF [1..3] +[1, 2, 3] +>>> listF [1..100] +[ 1 +, 2 +... +, 100 ] +>>> listF ["foo", "bar\nbaz"] +[ foo +, bar + baz ] +-} +listF :: (Buildable a, Foldable f) => f a -> Doc +listF = listF' build + +{-| Version of 'listF' that allows explicitly specifying a formatter for items. + +>>> listF' hexF [1,11,21] +[1, b, 15] +-} +listF' :: Foldable f => (a -> Doc) -> f a -> Doc +listF' f = WL.list . map (WL.align . f) . F.toList + +{-| Conditionally print something. + +>>> whenF True "foo" +foo +>>> show $ whenF False "foo" +"" +-} +whenF :: Bool -> Doc -> Doc +whenF True x = x +whenF False _ = mempty + +{-| Boolean inverse of 'whenF' + +>>> unlessF False "foo" +foo +>>> show $ unlessF True "foo" +"" +-} +unlessF :: Bool -> Doc -> Doc +unlessF = whenF . not + +{-| Class for formatting tuples + +>>> tupleF ("foo", "bar", "baz") +(foo, bar, baz) +>>> tupleF ("foo","bar\nbaz") +( foo +, bar + baz ) +>>> :{ +tupleF + ( "foo", "foo", "foo", "foo", "foo" + , "foo", "foo", "foo", "foo", "foo" + , "foo", "foo", "foo", "foo", "foo" + , "foo", "foo", "foo", "foo", "foo" + ) +:} +( foo +, foo +... +, foo ) +-} +class TupleF a where + tupleF :: a -> Doc + +-- NB: see below for a bunch of TH-derived instances for tuples + +instance Buildable a => TupleF [a] where + tupleF = WL.tupled . map (WL.align . build) + +class FormatAsHex a where + {- | Format a number or bytestring as hex: + + >>> pretty $ hexF 3635 + e33 + >>> pretty $ hexF (-3635) + -e33 + >>> pretty $ hexF ("\0\50\63\80" :: ByteString) + 00323f50 + >>> pretty $ hexF ("\0\50\63\80" :: LByteString) + 00323f50 + -} + hexF :: a -> Doc + +instance FormatAsHex ByteString where + hexF = build . TLE.decodeLatin1 . BB.toLazyByteString . BB.byteStringHex + +instance FormatAsHex LByteString where + hexF = build . TLE.decodeLatin1 . BB.toLazyByteString . BB.lazyByteStringHex + +{- | Wrap an integral type with this if there's no 'FormatAsHex' instance for it +yet, or use it with @DerivingVia@. + +>>> hexF $ Hex 128 +80 +-} +newtype Hex a = Hex a +instance Integral a => FormatAsHex (Hex a) where + hexF (Hex i) = sgn <> build (hexadecimal $ abs i) + where + sgn = if i < 0 then "-" else mempty + +-- NB: see below for more TH-derived instances + +{- | Enumerate pairs of text and 'Doc', reflowing the content to best-fit line +width. This will line-wrap text on whitespace. If 'Doc' is rendered single-line, +this will try to fit it inline. Otherwise, it's surrounded by newlines. + +>>> :{ +long_text = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. \ + \ Donec eget diam ac lorem posuere dapibus in ut lorem. Morbi \ + \ aliquet accumsan libero, a tempor nunc egestas ac." +:} + +>>> enumerateF [(long_text, mempty)] +Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec eget diam ac +lorem posuere dapibus in ut lorem. Morbi aliquet accumsan libero, a tempor nunc +egestas ac. + +>>> let splice = "SPLICE SPLICE SPLICE" :: Doc +>>> :{ +enumerateF + [ (long_text, splice) + , (long_text, mempty) + ] +:} +Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec eget diam ac +lorem posuere dapibus in ut lorem. Morbi aliquet accumsan libero, a tempor nunc +egestas ac. SPLICE SPLICE SPLICE Lorem ipsum dolor sit amet, consectetur +adipiscing elit. Donec eget diam ac lorem posuere dapibus in ut lorem. Morbi +aliquet accumsan libero, a tempor nunc egestas ac. + +>>> let splice = build "SPLICE\nSPLICE\nSPLICE" +>>> :{ +enumerateF + [ (long_text, splice) + , ("Short text", mempty) + ] +:} +Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec eget diam ac +lorem posuere dapibus in ut lorem. Morbi aliquet accumsan libero, a tempor nunc +egestas ac. +SPLICE +SPLICE +SPLICE +Short text + +-} +enumerateF :: [(Text, Doc)] -> Doc +enumerateF = enumerateF' mempty + +{- | Version of 'enumerateF' that allows specifying separator between items. + +>>> enumerateF' "," [("Foo", build 1), ("bar", build 2), ("baz", build 3)] +Foo 1, bar 2, baz 3 +-} +enumerateF' :: Doc -> [(Text, Doc)] -> Doc +enumerateF' sep = foldr merge mempty + where + merge (lead, x) trail = lead ++| (x <> whenNE sep trail) |++ trail + +{- | Surround a 'Buildable' with quotes (or anything else really). + +@quoteF' l r x@ is equivalent to @l <> build x <> r@, but it may be more +convenient in some cases. + +>>> quoteF' "\"" "\"" "Foo" +"Foo" +-} +quoteF' :: Buildable a => Doc -> Doc -> a -> Doc +quoteF' l r = WL.enclose l r . build + +{- | Surround a 'Buildable' with the same 'Doc' on both sides. + +>>> quoteF "\"" "Foo" +"Foo" +-} +quoteF :: Buildable a => Doc -> a -> Doc +quoteF q = quoteF' q q + +{- | If buildable fits into the line, wrap it in single quotes. Otherwise, +indent it by 2 spaces. This is convenient with 'enumerateF' or reflowing +brackets to format a splice that can be long and multiline or short and +singleline with about equal probability. + +This is a particularly useful specialization of 'flatAltF'. + +>>> let splice = "lorem posuere dapibus" :: Doc +>>> let long_splice = unwordsF $ replicate 3 splice +>>> let very_long_splice = unwordsF $ replicate 4 splice + +>>> "Foobar" ++| quoteOrIndentF splice |++ "bazbar." +Foobar 'lorem posuere dapibus' bazbar. + +>>> "Foobarbazquux" ++| quoteOrIndentF long_splice |++ "bazbar." +Foobarbazquux +'lorem posuere dapibus lorem posuere dapibus lorem posuere dapibus' bazbar. + +>>> "Foobarbazquux" ++| quoteOrIndentF long_splice |++^ "bazbar." +Foobarbazquux + lorem posuere dapibus lorem posuere dapibus lorem posuere dapibus +bazbar. + +>>> "Foobar" ++| quoteOrIndentF very_long_splice |++ "bazbar." +Foobar + lorem posuere dapibus lorem posuere dapibus lorem posuere dapibus + lorem posuere dapibus +bazbar. + +>>> "Foobar" ++| quoteOrIndentF very_long_splice |++^ "bazbar." +Foobar + lorem posuere dapibus lorem posuere dapibus lorem posuere dapibus + lorem posuere dapibus +bazbar. +-} +quoteOrIndentF :: Buildable a => a -> Doc +quoteOrIndentF = flatAltF (indentF 2 . build) (quoteF "'" . build) + +{- | Use different formatters depending on whether the pretty-printed +representation fits on the current line or not. The exact meaning of "fits" is +determined by the surrounding context. In precise terms, whether multiline or +single-line format is chosen is determined by whether the enclosing @group@ is +broken or not, respectively. Useful with reflowing brackets, 'nameF', etc to +specify alternate format for short and/or single-line and long and/or multiline +text. + +>>> let short = "bar baz" :: Text +>>> let long = unwordsF $ replicate 10 short + +>>> nameF "Foo" $ flatAltF (quoteF "\"") (quoteF "'") short +Foo: 'bar baz' + +>>> nameF "Foo" $ flatAltF (quoteF "\"") (quoteF "'") long +Foo: + "bar baz bar baz bar baz bar baz bar baz bar baz bar baz bar baz bar baz + bar baz" +-} +flatAltF + :: (a -> Doc) -- ^ Multiline formatter + -> (a -> Doc) -- ^ Single-line formatter + -> (a -> Doc) +flatAltF nonFlat flat res = WL.flatAlt (nonFlat res) (flat res) + +-- | Like 'WL.fillSep', but skips over empty elements. +fillSepF :: (Foldable t, Buildable a) => t a -> Doc +fillSepF = F.foldr (\x acc -> build x WL. acc) mempty + +-- | Version of 'fillSepF' with punctuation. +fillSepF' :: (Foldable t, Buildable a) => Doc -> t a -> Doc +fillSepF' sep = fillSepF . WL.punctuate sep . map build . F.toList + +-- | Reflow text, line-wrapping on white-space. Any leading and trailing +-- whitespace is stripped. +reflowF :: Text -> Doc +reflowF = WL.reflow + +{- | Punctuate a foldable with a distinct separator for the last two elements. +Useful for enumerations. Does the oxford comma by concatenating first and second +arguments. Note that when using a word, a leading space is expected on the pair +separator. + +>>> fillSepF $ punctuateF "," " and" ([] :: [Doc]) + +>>> fillSepF $ punctuateF "," " and" ["foo"] +foo +>>> fillSepF $ punctuateF "," " and" ["bar", "baz"] +bar and baz +>>> fillSepF $ punctuateF "," " and" ["foo", "bar", "baz"] +foo, bar, and baz +-} +punctuateF + :: (Foldable t, Buildable a) + => Doc -- ^ Default separator, usually comma + -> Doc -- ^ Pair separator, usually @" and"@ or @" or"@ + -> t a -- ^ Foldable to punctuate + -> [Doc] +punctuateF sep sep2 = punctuateF' sep sep2 (sep <> sep2) + +{- | Version of 'punctuateF' with explicit distinct separators for penultimate +element and just two elements. + +>>> fillSepF $ punctuateF' "," " and" ", and" ([] :: [Doc]) + +>>> fillSepF $ punctuateF' "," " and" ", and" ["foo"] +foo +>>> fillSepF $ punctuateF' "," " and" ", and" ["bar", "baz"] +bar and baz +>>> fillSepF $ punctuateF' "," " and" ", and" ["foo", "bar", "baz"] +foo, bar, and baz +-} +punctuateF' + :: (Foldable t, Buildable a) + => Doc -- ^ Default separator + -> Doc -- ^ Pair separator + -> Doc -- ^ Penultimate element separator + -> t a + -> [Doc] +punctuateF' sep sep2 sepOxford = go False . F.toList + where + go oxfordComma = \case + [] -> [] + [x] -> [build x] + [x, y] -> [build x <> if oxfordComma then sepOxford else sep2, build y] + (x:xs) -> build x <> sep : go True xs + +{- | Force the 'Doc' to be rendered on a single line, regardless of anything, +including hard line breaks. Will lead to horrible terrible formatting if +overused. In all likelihood, this is not the function you're looking for. + +Note that hard line breaks will be removed entirely, not replaced with spaces. + +>>> singleLineF ("foo\nbar\nbaz" :: Text) +foobarbaz +-} +singleLineF :: Buildable a => a -> Doc +singleLineF = WL.unsafeTextWithoutNewlines . fmtSimple . renderOneLine . build + +---------------------------------------------------------------------------- +-- Generic stuff +---------------------------------------------------------------------------- + +{- | Newtype for use with @DerivingVia@, e.g. + +>>> :{ +data Foo = Bar | Baz + deriving (Generic, Buildable) +:} + +>>> build Bar +Bar + +Handles infix constructors properly: + +>>> data Inf = Text :-> Text deriving (Generic, Buildable) +>>> build $ "foo" :-> "bar" +foo :-> bar +>>> data Inf2 = Text `Con` Text deriving (Generic, Buildable) +>>> build $ Con "foo" "bar" +foo `Con` bar + +>>> :{ +data LargeTy = LargeTy + Text Text Text Text Text + Text Text Text Text Text + Text Text Text Text Text + Text Text Text Text Text + deriving (Generic, Buildable) +:} + +>>> :{ +build $ LargeTy + "foo" "foo" "foo" "foo" "foo" + "foo" "foo" "foo" "foo" "foo" + "foo" "foo" "foo" "foo" "foo" + "foo" "foo" "foo" "foo" "foo" +:} +LargeTy; + foo, foo, foo, foo, foo, foo, foo, foo, foo, foo, foo, foo, foo, + foo, foo, foo, foo, foo, foo, foo + + +There is a special case for tuples: + +>>> :{ +newtype Tup = Tup (Int, Int, Text) + deriving stock Generic + deriving anyclass Buildable +:} + +>>> build $ Tup (1, 2, "many") +Tup; (1, 2, many) +>>> build $ Tup (1, 2, "many\nlines") +Tup; + ( 1 + , 2 + , many + lines ) + +Renders records as maps + +>>> :{ +data Rec = Rec + { foo :: Text + , bar :: Text + , baz :: Text + } deriving (Generic, Buildable) +:} + +>>> build $ Rec "quux" "waldo" "corge" +Rec: + foo: quux + bar: waldo + baz: corge +-} +newtype GenericBuildable a = GenericBuildable a + +instance (GBuildable (G.Rep a), Generic a) => Buildable (GenericBuildable a) where + build (GenericBuildable a) = gbuild $ G.from a + +class GBuildable f where + gbuild :: f a -> Doc + +instance Buildable c => GBuildable (G.Rec0 c) where + gbuild (G.K1 a) = build a + +instance (GBuildable a, GBuildable b) => GBuildable (a G.:+: b) where + gbuild (G.L1 x) = gbuild x + gbuild (G.R1 x) = gbuild x + +instance GBuildable a => GBuildable (G.D1 d a) where + gbuild (G.M1 x) = gbuild x + +instance (GetFields a, G.Constructor c) => GBuildable (G.C1 c a) where + -- A note on fixity: + -- * Ordinarily e.g. "Foo" is prefix and e.g. ":|" is infix + -- * However, "Foo" can be infix when defined as "a `Foo` b" + -- * And ":|" can be prefix when defined as "(:|) a b" + gbuild c@(G.M1 x) + | G.Infix{} <- G.conFixity c + -- There will always be two fields in this case. + , [a, b] <- fields = a WL.<+> infixName WL.<+> b + | isTuple = WL.tupled fields + | G.conIsRecord c = nameF prefixName $ blockMapF fieldsWithNames + | null fields = prefixName + | otherwise = WL.nest 2 $ WL.group $ WL.surround (";" <> WL.line) prefixName $ + WL.fillSep $ WL.punctuate ", " fields + where + fieldsWithNames = getFields x + fields = snd <$> fieldsWithNames + (prefixName, infixName) + | ':':_ <- G.conName c = (WL.enclose "(" ")" cn, cn) + | otherwise = (cn, WL.enclose "`" "`" cn) + where cn = build (G.conName c) + isTuple + | '(':',':_ <- G.conName c = True + | otherwise = False + +-- | Helper class for 'GBuildable'. +class GetFields f where + -- | Get fields, together with their names if available + getFields :: f a -> [(String, Doc)] + +instance (GetFields a, GetFields b) => GetFields (a G.:*: b) where + getFields (a G.:*: b) = getFields a <> getFields b + +instance (GBuildable a, G.Selector c) => GetFields (G.S1 c a) where + getFields s@(G.M1 a) = [(G.selName s, WL.align $ gbuild a)] + +instance GetFields G.U1 where + getFields _ = [] + +---------------------------------------------------------------------------- +-- TH-derived instances and those that depend on it +---------------------------------------------------------------------------- + +concatMapM + (\(conT -> ty) -> [d|deriving via ViaPretty $ty instance Buildable $ty|]) + [ ''Int, ''Int8, ''Int16, ''Int32, ''Int64, ''Integer + , ''Word, ''Word8, ''Word16, ''Word32, ''Word64, ''Natural + , ''(), ''Void + , ''Bool, ''Double, ''Float + ] + +concatMapM + (\(conT -> ty) -> [d|deriving via Hex $ty instance FormatAsHex $ty|]) + [ ''Int, ''Int8, ''Int16, ''Int32, ''Int64, ''Integer + , ''Word, ''Word8, ''Word16, ''Word32, ''Word64, ''Natural + ] + +concatForM [2..30] \n -> do + names <- replicateM n $ newName "a" + let constr = tupT $ tys <&> \ty -> [t|Buildable $ty|] + tup = tupT tys + tupT = foldl' appT (tupleT n) + tys = varT <$> names + pat = tupP $ varP <$> names + list = listE $ names <&> \name -> [|WL.align $ build $(varE name)|] + [d| + instance $constr => TupleF $tup where + tupleF $pat = WL.tupled $list + instance $constr => Buildable $tup where + build = tupleF + |] + +instance Buildable a => Buildable (Ratio a) where + {-# SPECIALIZE instance Buildable (Ratio Integer) #-} + build a = build (numerator a) <> "/" <> build (denominator a) + +{- | + +>>> pretty (fromList [(100, "bar"), (500, "quux")] :: IntMap Text) +{100: bar, 500: quux} +-} +instance Buildable v => Buildable (IntMap v) where + build = mapF + +{- | + +>>> pretty (fromList [100, 500] :: IntSet) +[100, 500] +-} +instance Buildable IntSet where + build = listF . toList diff --git a/src/Fmt/Operators.hs b/src/Fmt/Operators.hs new file mode 100644 --- /dev/null +++ b/src/Fmt/Operators.hs @@ -0,0 +1,42 @@ +-- SPDX-FileCopyrightText: 2023 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Extra operators on top of "Prettyprinter" with additional semantics. +module Fmt.Operators + ( () + , () + , (<+>) + , (<$>) + , (<$$>) + ) where + +import Universum ((<>)) + +import Fmt.Utils (Doc, linebreak, softbreak) +import Prettyprinter (line, softline, space) +import Prettyprinter.Internal (pattern Empty) + +(<+>), (<$>), (), (<$$>), () :: Doc -> Doc -> Doc +Empty <+> y = y +x <+> Empty = x +x <+> y = x <> space <> y +infixr 6 <+> + +x <$> Empty = x +Empty <$> y = y +x <$> y = x <> line <> y + +x Empty = x +Empty y = y +x y = x <> softline <> y + +x <$$> Empty = x +Empty <$$> y = y +x <$$> y = x <> linebreak <> y + +x Empty = x +Empty y = y +x y = x <> softbreak <> y +infixr 5 ,,<$>,<$$> diff --git a/src/Fmt/Utils.hs b/src/Fmt/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Fmt/Utils.hs @@ -0,0 +1,70 @@ +-- SPDX-FileCopyrightText: 2023 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Compatibility layer between @prettyprinter@ and @wl-pprint-text@ +module Fmt.Utils + ( Doc + , SimpleDoc + , renderOneLine + , isEmpty + , linebreak + , softbreak + , mkLayoutOptions + ) where + +import Universum (Bool(..), Double, Int, flip, mempty, ($), (+), (...)) + +import Prettyprinter qualified as PP +import Prettyprinter.Internal qualified as PP (Doc(..)) + +-- | Document without annotations +type Doc = PP.Doc () + +-- | Simple document without annotations +type SimpleDoc = PP.SimpleDocStream () + +{- | Check if 'Doc' is 'mempty'. Note that empty strings are also considered +empty. + +>>> isEmpty mempty +True +>>> isEmpty "" +True +>>> isEmpty "foo" +False +-} +isEmpty :: Doc -> Bool +isEmpty PP.Empty = True +isEmpty _ = False + +-- | Rendered as newline, when undone by @group@, is @mempty@. +linebreak :: Doc +linebreak = PP.flatAlt PP.line mempty + +-- | Like @mempty@ if the output fits the page, otherwise like @line@. +softbreak :: Doc +softbreak = PP.group linebreak + +renderOneLine :: Doc -> SimpleDoc +renderOneLine dc = scan 0 [dc] + where + scan _ [] = PP.SEmpty + scan !k (d:ds) = case d of + PP.Fail -> PP.SFail + PP.Empty -> scan k ds + PP.Char c -> PP.SChar c $ scan (k + 1) ds + PP.Text l s -> PP.SText l s $ scan (k + l) ds + PP.Line -> scan k ds + PP.Cat x y -> scan k (x : y : ds) + PP.Nest _ x -> scan k (x : ds) + PP.Union x _ -> scan k (x : ds) + PP.Column f -> scan k (f k : ds) + PP.Nesting f -> scan k (f 0 : ds) + PP.FlatAlt _ y -> scan k (y : ds) + PP.WithPageWidth f -> scan k (f PP.Unbounded : ds) + PP.Annotated _ x -> scan k (x : ds) + +mkLayoutOptions :: Double -> Int -> PP.LayoutOptions +mkLayoutOptions = PP.LayoutOptions ... flip PP.AvailablePerLine diff --git a/src/Morley/Prelude/Length.hs b/src/Morley/Prelude/Length.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Prelude/Length.hs @@ -0,0 +1,88 @@ +-- SPDX-FileCopyrightText: 2023 Oxhead Alpha +-- SPDX-License-Identifier: LicenseRef-MIT-OA + +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | Polymorphic length +module Morley.Prelude.Length + ( length + ) where + +import Morley.Prelude.FromIntegral (CheckIntSubType, IntBaseType) + +import Data.IntCast (IntBaseTypeK(..), IsIntSubType) +import GHC.TypeLits (ErrorMessage(..), TypeError) +import GHC.TypeNats (type (-)) +import Universum hiding (length) +import Universum qualified + +data Length + +type instance IntBaseType Length = WordOfInt (IntBaseType Int) + +type family WordOfInt ty where + WordOfInt ('FixedIntTag n) = 'FixedWordTag (n - 1) + WordOfInt ty = TypeError ('Text "Unexpected tag in WordOfInt: " ':<>: 'ShowType ty) + +{- | Polymorphic version of 'Universum.length'. + +Defaults to 'Int', same as the non-polymorphic version, if return value is +ambiguous. + +>>> let list = [1..100] + +>>> :t length list +length list :: Int + +>>> length list :: Word +100 +>>> length list :: Int +100 +>>> length list :: Word63 +100 +>>> length list :: Natural +100 +>>> length list :: Integer +100 +>>> length list :: Word8 +... +... error: +... Can not safely cast 'Morley.Prelude.Length.Length' to 'Word8': +... 'Morley.Prelude.Length.Length' is not a subtype of 'Word8' +... + +One caveat that with an unsuitable monomorphic type, @length@ will also default +to 'Int': + +>>> length list :: Bool +... +... error: +... Couldn't match type ‘Bool’ with ‘Int’ +... + +However, this lets us avoid the issue with integral literals. +-} +length + :: (Integral i, Container a, CheckIntSubType Length i, DefaultToInt (IsIntSubType Length i) i) + => a -> i +length = Universum.fromIntegral . Universum.length + +type DefaultToInt :: Bool -> Type -> Constraint +class DefaultToInt b i + +instance DefaultToInt 'True i +instance DefaultToInt 'False i + +instance {-# incoherent #-} i ~ Int => DefaultToInt f i + +{- +This incoherent instance trick merits a bit of an explanation. Basically, it +works like this: as long as @i@ is monomorphic and is a valid target type, +@IsIntSubType Length i@ is well-defined, that is, either @'True@ or @'False@, +thus non-incoherent instances get selected. If @i@ is polymorphic or an invalid +target type, then @IsIntSubType Length i@ is stuck, and the incoherent instance +can be selected, which will in turn force @i@ into @Int@. + +-- @lierdakil +-} diff --git a/src/Prelude.hs b/src/Prelude.hs --- a/src/Prelude.hs +++ b/src/Prelude.hs @@ -9,10 +9,13 @@ ( module Control.Lens , module Universum , for + , toEnumSafe -- * Converters from @Integral@ types , module FromIntegral -- * Overloaded boolean operators , module Boolean + -- * Polymorphic length + , module Length -- * Unsafe conversions , Unsafe.fromInteger -- * Safer @show@ @@ -28,13 +31,23 @@ import Control.Lens (Lens, Lens', Traversal, Traversal', _1, _2, _3, _4, _5, over, preuse, preview, set, use, view, (%~), (&), (.~), (<&>), (^.), (^..), (^?)) +import Data.Ix (inRange) import Data.Traversable (for) import Morley.Prelude.Boolean as Boolean import Morley.Prelude.FromIntegral as FromIntegral +import Morley.Prelude.Length as Length import Morley.Prelude.Show as Show import Morley.Prelude.Word as Word import Universum hiding (All(..), Any(..), Key, Lens, Lens', Nat, Traversal, Traversal', Val, _1, _2, _3, _4, _5, all, - and, any, fromInteger, fromIntegral, not, or, over, preuse, preview, readFile, set, show, use, - view, writeFile, (%~), (&&), (&), (.~), (<&>), (^.), (^..), (^?), (||)) + and, any, fromInteger, fromIntegral, length, not, or, over, preuse, preview, readFile, set, show, + use, view, writeFile, (%~), (&&), (&), (.~), (<&>), (^.), (^..), (^?), (||)) import Unsafe qualified (fromInteger, unsafe, unsafeM) + +-- | A safe version of 'toEnum' for 'Bounded' types. +toEnumSafe :: forall a. (Enum a, Bounded a) => Int -> Maybe a +toEnumSafe i = guard (inBounds i) $> toEnum i + where + inBounds :: Int -> Bool + inBounds = inRange (fromEnum (minBound :: a), fromEnum (maxBound :: a)) +{-# INLINE toEnumSafe #-}