packages feed

morley-prelude 0.5.2 → 0.5.3

raw patch · 8 files changed

+1338/−4 lines, 8 filesdep +bytestringdep +prettyprinterdep +textdep −fmt

Dependencies added: bytestring, prettyprinter, text

Dependencies removed: fmt

Files

CHANGES.md view
@@ -1,6 +1,39 @@ <!-- Unreleased: append new entries here -->  +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)
morley-prelude.cabal view
@@ -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
+ src/Fmt.hs view
@@ -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) #-}
+ src/Fmt/Buildable.hs view
@@ -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)+<Left: foo>+>>> pretty (Right 123 :: Either String Int)+<Right: 123>+-}+instance (Buildable a, Buildable b) => Buildable (Either a b) where+  build (Left a) = "<Left: " <> build a <> ">"+  build (Right b) = "<Right: " <> 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])+<BLANKLINE>+>>> 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])+<BLANKLINE>+>>> 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
+ src/Fmt/Operators.hs view
@@ -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 </>,<//>,<$>,<$$>
+ src/Fmt/Utils.hs view
@@ -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
+ src/Morley/Prelude/Length.hs view
@@ -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+-}
src/Prelude.hs view
@@ -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 #-}