----------------------------------------------------------------------------
-- |
-- Module      :  Prettyprinter.MetaDoc
-- Copyright   :  (c) Sergey Vinokurov 2018
-- License     :  Apache-2.0 (see LICENSE)
-- Maintainer  :  serg.foo@gmail.com
----------------------------------------------------------------------------

module Prettyprinter.MetaDoc
  ( DocKind(..)
  , MetaDoc
  , mdPayload
  , mdKind
  , compositeMetaDoc
  , atomicMetaDoc

  , metaDocInt
  , metaDocFloat
  , metaDocDouble
  , metaDocInteger
  , metaDocNatural
  , metaDocWord
  , metaDocWord8
  , metaDocWord16
  , metaDocWord32
  , metaDocWord64
  , metaDocInt8
  , metaDocInt16
  , metaDocInt32
  , metaDocInt64
  , metaDocUnit
  , metaDocBool
  , metaDocChar

  , stringMetaDoc
  , strictTextMetaDoc
  , lazyTextMetaDoc
  , strictByteStringMetaDoc
  , lazyByteStringMetaDoc
  , shortByteStringMetaDoc

  , constructorAppMetaDoc
  ) where

import Data.ByteString.Char8 qualified as C8
import Data.ByteString.Lazy.Char8 qualified as CL8
import Data.ByteString.Short qualified as ShortBS
import Data.Int
import Data.Semigroup as Semigroup
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Word
import Numeric.Natural
import Prettyprinter
import Prettyprinter qualified as PP
import Prettyprinter.Combinators.Basic

data DocKind = Atomic | Composite
  deriving (DocKind -> DocKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DocKind -> DocKind -> Bool
$c/= :: DocKind -> DocKind -> Bool
== :: DocKind -> DocKind -> Bool
$c== :: DocKind -> DocKind -> Bool
Eq, Eq DocKind
DocKind -> DocKind -> Bool
DocKind -> DocKind -> Ordering
DocKind -> DocKind -> DocKind
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DocKind -> DocKind -> DocKind
$cmin :: DocKind -> DocKind -> DocKind
max :: DocKind -> DocKind -> DocKind
$cmax :: DocKind -> DocKind -> DocKind
>= :: DocKind -> DocKind -> Bool
$c>= :: DocKind -> DocKind -> Bool
> :: DocKind -> DocKind -> Bool
$c> :: DocKind -> DocKind -> Bool
<= :: DocKind -> DocKind -> Bool
$c<= :: DocKind -> DocKind -> Bool
< :: DocKind -> DocKind -> Bool
$c< :: DocKind -> DocKind -> Bool
compare :: DocKind -> DocKind -> Ordering
$ccompare :: DocKind -> DocKind -> Ordering
Ord, Int -> DocKind
DocKind -> Int
DocKind -> [DocKind]
DocKind -> DocKind
DocKind -> DocKind -> [DocKind]
DocKind -> DocKind -> DocKind -> [DocKind]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: DocKind -> DocKind -> DocKind -> [DocKind]
$cenumFromThenTo :: DocKind -> DocKind -> DocKind -> [DocKind]
enumFromTo :: DocKind -> DocKind -> [DocKind]
$cenumFromTo :: DocKind -> DocKind -> [DocKind]
enumFromThen :: DocKind -> DocKind -> [DocKind]
$cenumFromThen :: DocKind -> DocKind -> [DocKind]
enumFrom :: DocKind -> [DocKind]
$cenumFrom :: DocKind -> [DocKind]
fromEnum :: DocKind -> Int
$cfromEnum :: DocKind -> Int
toEnum :: Int -> DocKind
$ctoEnum :: Int -> DocKind
pred :: DocKind -> DocKind
$cpred :: DocKind -> DocKind
succ :: DocKind -> DocKind
$csucc :: DocKind -> DocKind
Enum, DocKind
forall a. a -> a -> Bounded a
maxBound :: DocKind
$cmaxBound :: DocKind
minBound :: DocKind
$cminBound :: DocKind
Bounded)

instance Semigroup DocKind where
  <> :: DocKind -> DocKind -> DocKind
(<>) = forall a. Ord a => a -> a -> a
max

instance Monoid DocKind where
  mempty :: DocKind
mempty  = forall a. Bounded a => a
minBound
  mappend :: DocKind -> DocKind -> DocKind
mappend = forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

data MetaDoc ann = MetaDoc
  { forall ann. MetaDoc ann -> Doc ann
mdPayload :: Doc ann
  , forall ann. MetaDoc ann -> DocKind
mdKind    :: DocKind
  }

compositeMetaDoc :: Doc ann -> MetaDoc ann
compositeMetaDoc :: forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc Doc ann
x = MetaDoc
  { mdPayload :: Doc ann
mdPayload = Doc ann
x
  , mdKind :: DocKind
mdKind    = DocKind
Composite
  }

atomicMetaDoc :: Doc ann -> MetaDoc ann
atomicMetaDoc :: forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc Doc ann
x = MetaDoc
  { mdPayload :: Doc ann
mdPayload = Doc ann
x
  , mdKind :: DocKind
mdKind    = DocKind
Atomic
  }

instance Semigroup (MetaDoc ann) where
  <> :: MetaDoc ann -> MetaDoc ann -> MetaDoc ann
(<>) (MetaDoc Doc ann
p1 DocKind
kind1) (MetaDoc Doc ann
p2 DocKind
kind2) = MetaDoc
    { mdPayload :: Doc ann
mdPayload = Doc ann
p1 forall a. Semigroup a => a -> a -> a
<> Doc ann
p2
    , mdKind :: DocKind
mdKind    = DocKind
kind1 forall a. Semigroup a => a -> a -> a
<> DocKind
kind2
    }

instance Monoid (MetaDoc ann) where
  mempty :: MetaDoc ann
mempty = MetaDoc
    { mdPayload :: Doc ann
mdPayload = forall a. Monoid a => a
mempty
    , mdKind :: DocKind
mdKind    = forall a. Monoid a => a
mempty
    }
  mappend :: MetaDoc ann -> MetaDoc ann -> MetaDoc ann
mappend = forall a. Semigroup a => a -> a -> a
(<>)

metaDocInt :: Int -> MetaDoc ann
metaDocInt :: forall ann. Int -> MetaDoc ann
metaDocInt = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocFloat :: Float -> MetaDoc ann
metaDocFloat :: forall ann. Float -> MetaDoc ann
metaDocFloat = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocDouble :: Double -> MetaDoc ann
metaDocDouble :: forall ann. Double -> MetaDoc ann
metaDocDouble = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocInteger :: Integer -> MetaDoc ann
metaDocInteger :: forall ann. Integer -> MetaDoc ann
metaDocInteger = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocNatural :: Natural -> MetaDoc ann
metaDocNatural :: forall ann. Natural -> MetaDoc ann
metaDocNatural = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocWord :: Word -> MetaDoc ann
metaDocWord :: forall ann. Word -> MetaDoc ann
metaDocWord = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocWord8 :: Word8 -> MetaDoc ann
metaDocWord8 :: forall ann. Word8 -> MetaDoc ann
metaDocWord8 = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocWord16 :: Word16 -> MetaDoc ann
metaDocWord16 :: forall ann. Word16 -> MetaDoc ann
metaDocWord16 = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocWord32 :: Word32 -> MetaDoc ann
metaDocWord32 :: forall ann. Word32 -> MetaDoc ann
metaDocWord32 = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocWord64 :: Word64 -> MetaDoc ann
metaDocWord64 :: forall ann. Word64 -> MetaDoc ann
metaDocWord64 = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocInt8 :: Int8 -> MetaDoc ann
metaDocInt8 :: forall ann. Int8 -> MetaDoc ann
metaDocInt8 = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocInt16 :: Int16 -> MetaDoc ann
metaDocInt16 :: forall ann. Int16 -> MetaDoc ann
metaDocInt16 = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocInt32 :: Int32 -> MetaDoc ann
metaDocInt32 :: forall ann. Int32 -> MetaDoc ann
metaDocInt32 = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocInt64 :: Int64 -> MetaDoc ann
metaDocInt64 :: forall ann. Int64 -> MetaDoc ann
metaDocInt64 = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocUnit :: () -> MetaDoc ann
metaDocUnit :: forall ann. () -> MetaDoc ann
metaDocUnit = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocBool :: Bool -> MetaDoc ann
metaDocBool :: forall ann. Bool -> MetaDoc ann
metaDocBool = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty

metaDocChar :: Char -> MetaDoc ann
metaDocChar :: forall ann. Char -> MetaDoc ann
metaDocChar = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty


stringMetaDoc :: String -> MetaDoc ann
stringMetaDoc :: forall ann. String -> MetaDoc ann
stringMetaDoc String
str = forall ann. Doc ann -> MetaDoc ann
f forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty String
str
  where
    f :: Doc ann -> MetaDoc ann
f | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== Char
' ') String
str = forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc
      | Bool
otherwise        = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc

strictTextMetaDoc :: T.Text -> MetaDoc ann
strictTextMetaDoc :: forall ann. Text -> MetaDoc ann
strictTextMetaDoc Text
str = forall ann. Doc ann -> MetaDoc ann
f forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Text
str
  where
    f :: Doc ann -> MetaDoc ann
f | (Char -> Bool) -> Text -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
str = forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc
      | Bool
otherwise          = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc

lazyTextMetaDoc :: TL.Text -> MetaDoc ann
lazyTextMetaDoc :: forall ann. Text -> MetaDoc ann
lazyTextMetaDoc Text
str = forall ann. Doc ann -> MetaDoc ann
f forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Text
str
  where
    f :: Doc ann -> MetaDoc ann
f | (Char -> Bool) -> Text -> Bool
TL.any (forall a. Eq a => a -> a -> Bool
== Char
' ') Text
str = forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc
      | Bool
otherwise           = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc

strictByteStringMetaDoc :: C8.ByteString -> MetaDoc ann
strictByteStringMetaDoc :: forall ann. ByteString -> MetaDoc ann
strictByteStringMetaDoc ByteString
str = forall ann. Doc ann -> MetaDoc ann
f forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
str
  where
    f :: Doc ann -> MetaDoc ann
f | (Char -> Bool) -> ByteString -> Bool
C8.any (forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
str = forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc
      | Bool
otherwise           = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc

lazyByteStringMetaDoc :: CL8.ByteString -> MetaDoc ann
lazyByteStringMetaDoc :: forall ann. ByteString -> MetaDoc ann
lazyByteStringMetaDoc ByteString
str = forall ann. Doc ann -> MetaDoc ann
f forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ ByteString -> String
CL8.unpack ByteString
str
  where
    f :: Doc ann -> MetaDoc ann
f | (Char -> Bool) -> ByteString -> Bool
CL8.any (forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
str = forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc
      | Bool
otherwise            = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc

shortByteStringMetaDoc :: ShortBS.ShortByteString -> MetaDoc ann
shortByteStringMetaDoc :: forall ann. ShortByteString -> MetaDoc ann
shortByteStringMetaDoc ShortByteString
str = forall ann. Doc ann -> MetaDoc ann
f forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack ByteString
str'
  where
    str' :: ByteString
str' = ShortByteString -> ByteString
ShortBS.fromShort ShortByteString
str
    f :: Doc ann -> MetaDoc ann
f | (Char -> Bool) -> ByteString -> Bool
C8.any (forall a. Eq a => a -> a -> Bool
== Char
' ') ByteString
str' = forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc
      | Bool
otherwise            = forall ann. Doc ann -> MetaDoc ann
atomicMetaDoc

constructorAppMetaDoc :: MetaDoc ann -> [MetaDoc ann] -> MetaDoc ann
constructorAppMetaDoc :: forall ann. MetaDoc ann -> [MetaDoc ann] -> MetaDoc ann
constructorAppMetaDoc MetaDoc ann
constructor [MetaDoc ann]
args =
  case forall a b. (a -> b) -> [a] -> [b]
map forall ann. MetaDoc ann -> MetaDoc ann
field [MetaDoc ann]
args of
    []  -> MetaDoc ann
constructor
    [MetaDoc ann
f] -> forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc forall a b. (a -> b) -> a -> b
$ forall ann. MetaDoc ann -> Doc ann
mdPayload MetaDoc ann
constructor forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
group (forall ann. MetaDoc ann -> Doc ann
mdPayload MetaDoc ann
f)
    [MetaDoc ann]
fs  -> forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
PP.align forall a b. (a -> b) -> a -> b
$ forall ann. MetaDoc ann -> Doc ann
mdPayload MetaDoc ann
constructor forall ann. Doc ann -> Doc ann -> Doc ann
## forall ann. [Doc ann] -> Doc ann
PP.vsep (forall a b. (a -> b) -> [a] -> [b]
map forall ann. MetaDoc ann -> Doc ann
mdPayload [MetaDoc ann]
fs)
  where
    field :: MetaDoc ann -> MetaDoc ann
    field :: forall ann. MetaDoc ann -> MetaDoc ann
field MetaDoc ann
md =
      case forall ann. MetaDoc ann -> DocKind
mdKind MetaDoc ann
md of
        DocKind
Atomic    -> MetaDoc ann
md
        DocKind
Composite -> forall ann. Doc ann -> MetaDoc ann
compositeMetaDoc forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann -> Doc ann
PP.flatAlt Doc ann
payload (forall ann. Doc ann -> Doc ann
PP.parens Doc ann
payload)
      where
        payload :: Doc ann
payload = forall ann. MetaDoc ann -> Doc ann
mdPayload MetaDoc ann
md