{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016     , Myrtle Software Ltd,
                     2021-2022, QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  PrettyPrec printing class and instances for CoreHW
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Clash.Core.Pretty
  ( PrettyPrec (..)
  , PrettyOptions (..)
  , ClashDoc
  , ClashAnnotation (..)
  , SyntaxElement (..)
  , ppr, ppr'
  , showPpr, showPpr'
  , tracePprId
  , tracePpr
  , fromPpr
  )
where

import Data.Char                        (isSymbol, isUpper, ord)
import Data.Default                     (Default(..))
import Data.Text                        (Text)
import Control.Monad.Identity
import Data.Binary.IEEE754              (wordToDouble, wordToFloat)
import Data.List.Extra                  ((<:>))
import qualified Data.Text              as T
import Data.Maybe                       (fromMaybe)
#if MIN_VERSION_prettyprinter(1,7,0)
import Prettyprinter
import Prettyprinter.Internal
#else
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Internal
#endif
import GHC.Show                         (showMultiLineString)
import GHC.Stack                        (HasCallStack)
#if MIN_VERSION_ghc(9,0,0)
import qualified GHC.Utils.Outputable   as GHC
#else
import qualified Outputable             as GHC
#endif
import System.Environment               (lookupEnv)
import System.IO.Unsafe                 (unsafePerformIO)
import Text.Read                        (readMaybe)

import Clash.Core.DataCon               (DataCon (..))
import Clash.Core.Literal               (Literal (..))
import Clash.Core.Name                  (Name (..))
import Clash.Core.Term
  (Pat (..), Term (..), TickInfo (..), NameMod (..), CoreContext (..), primArg, PrimInfo(primName),Bind(..))
import Clash.Core.TyCon                 (TyCon (..), TyConName, isTupleTyConLike, AlgTyConRhs(..))
import Clash.Core.Type                  (ConstTy (..), Kind, LitTy (..),
                                         Type (..), TypeView (..), tyView,mkTyConApp)
import Clash.Core.Var                   (Id, TyVar, Var (..), IdScope(..))
import Clash.Debug                      (trace)
import Clash.Util
import qualified Clash.Util.Interpolate as I
import Clash.Pretty

unsafeLookupEnvBool :: HasCallStack =>  String -> Bool -> Bool
unsafeLookupEnvBool :: String -> Bool -> Bool
unsafeLookupEnvBool String
key Bool
dflt =
  case IO (Maybe String) -> Maybe String
forall a. IO a -> a
unsafePerformIO (String -> IO (Maybe String)
lookupEnv String
key) of
    Maybe String
Nothing -> Bool
dflt
    Just String
a -> (Bool -> Maybe Bool -> Bool) -> Maybe Bool -> Bool -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe (String -> Maybe Bool
forall a. Read a => String -> Maybe a
readMaybe String
a) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. HasCallStack => String -> a
error [I.i|
      'unsafeLookupEnvBool' tried to lookup #{key} in the environment. It found
      it, but couldn't interpret it to as a Bool. Expected one of: True, False.
      But found:

        #{a}
    |]

-- | Options for the pretty-printer, controlling which elements to hide.
data PrettyOptions = PrettyOptions
  { PrettyOptions -> Bool
displayUniques    :: Bool
  -- ^ whether to display unique identifiers
  , PrettyOptions -> Bool
displayTypes      :: Bool
  -- ^ whether to display type information
  , PrettyOptions -> Bool
displayQualifiers :: Bool
  -- ^ whether to display module qualifiers
  , PrettyOptions -> Bool
displayTicks      :: Bool
  -- ^ whether to display ticks
  }

instance Default PrettyOptions where
  def :: PrettyOptions
def = PrettyOptions :: Bool -> Bool -> Bool -> Bool -> PrettyOptions
PrettyOptions
    { displayUniques :: Bool
displayUniques    = HasCallStack => String -> Bool -> Bool
String -> Bool -> Bool
unsafeLookupEnvBool String
"CLASH_PPR_UNIQUES" Bool
True
    , displayTypes :: Bool
displayTypes      = HasCallStack => String -> Bool -> Bool
String -> Bool -> Bool
unsafeLookupEnvBool String
"CLASH_PPR_TYPES" Bool
True
    , displayQualifiers :: Bool
displayQualifiers = HasCallStack => String -> Bool -> Bool
String -> Bool -> Bool
unsafeLookupEnvBool String
"CLASH_PPR_QUALIFIERS" Bool
True
    , displayTicks :: Bool
displayTicks      = HasCallStack => String -> Bool -> Bool
String -> Bool -> Bool
unsafeLookupEnvBool String
"CLASH_PPR_TICKS" Bool
True
    }

-- | Annotations carried on pretty-printed code.
data ClashAnnotation
  = AnnContext CoreContext
  -- ^ marking navigation to a different context
  | AnnSyntax  SyntaxElement
  -- ^ marking a specific sort of syntax
  deriving ClashAnnotation -> ClashAnnotation -> Bool
(ClashAnnotation -> ClashAnnotation -> Bool)
-> (ClashAnnotation -> ClashAnnotation -> Bool)
-> Eq ClashAnnotation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClashAnnotation -> ClashAnnotation -> Bool
$c/= :: ClashAnnotation -> ClashAnnotation -> Bool
== :: ClashAnnotation -> ClashAnnotation -> Bool
$c== :: ClashAnnotation -> ClashAnnotation -> Bool
Eq

-- | Specific places in the program syntax.
data SyntaxElement = Keyword | LitS | Type | Unique | Qualifier | Ticky
  deriving (SyntaxElement -> SyntaxElement -> Bool
(SyntaxElement -> SyntaxElement -> Bool)
-> (SyntaxElement -> SyntaxElement -> Bool) -> Eq SyntaxElement
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SyntaxElement -> SyntaxElement -> Bool
$c/= :: SyntaxElement -> SyntaxElement -> Bool
== :: SyntaxElement -> SyntaxElement -> Bool
$c== :: SyntaxElement -> SyntaxElement -> Bool
Eq, Int -> SyntaxElement -> String -> String
[SyntaxElement] -> String -> String
SyntaxElement -> String
(Int -> SyntaxElement -> String -> String)
-> (SyntaxElement -> String)
-> ([SyntaxElement] -> String -> String)
-> Show SyntaxElement
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SyntaxElement] -> String -> String
$cshowList :: [SyntaxElement] -> String -> String
show :: SyntaxElement -> String
$cshow :: SyntaxElement -> String
showsPrec :: Int -> SyntaxElement -> String -> String
$cshowsPrec :: Int -> SyntaxElement -> String -> String
Show)

-- | Clash's specialized @Doc@ type holds metadata of type @ClashAnnotation@.
type ClashDoc = Doc ClashAnnotation

-- | PrettyPrec printing Show-like typeclass
class PrettyPrec p where

  -- default pretty-printing without hiding
  pprPrec :: Monad m => Rational -> p -> m ClashDoc

  -- pretty-printing with hiding options
  -- NB: we utilise the syntax annotations to hide the requested parts of syntax
  pprPrec' :: Monad m => PrettyOptions -> Rational -> p -> m ClashDoc
  pprPrec' PrettyOptions
opts Rational
p = (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ClashDoc -> ClashDoc
hide (m ClashDoc -> m ClashDoc) -> (p -> m ClashDoc) -> p -> m ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> p -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
p
    where
      hide :: ClashDoc -> ClashDoc
hide = \case
        FlatAlt ClashDoc
d ClashDoc
d'         -> ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
FlatAlt (ClashDoc -> ClashDoc
hide ClashDoc
d) (ClashDoc -> ClashDoc
hide ClashDoc
d')
        Cat ClashDoc
d ClashDoc
d'             -> ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
Cat (ClashDoc -> ClashDoc
hide ClashDoc
d) (ClashDoc -> ClashDoc
hide ClashDoc
d')
        Nest Int
i ClashDoc
d             -> Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
Nest Int
i (ClashDoc -> ClashDoc
hide ClashDoc
d)
        Union ClashDoc
d ClashDoc
d'           -> ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
Union (ClashDoc -> ClashDoc
hide ClashDoc
d) (ClashDoc -> ClashDoc
hide ClashDoc
d')
        Column Int -> ClashDoc
f             -> (Int -> ClashDoc) -> ClashDoc
forall ann. (Int -> Doc ann) -> Doc ann
Column (ClashDoc -> ClashDoc
hide (ClashDoc -> ClashDoc) -> (Int -> ClashDoc) -> Int -> ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ClashDoc
f)
        WithPageWidth PageWidth -> ClashDoc
f      -> (PageWidth -> ClashDoc) -> ClashDoc
forall ann. (PageWidth -> Doc ann) -> Doc ann
WithPageWidth (ClashDoc -> ClashDoc
hide (ClashDoc -> ClashDoc)
-> (PageWidth -> ClashDoc) -> PageWidth -> ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PageWidth -> ClashDoc
f)
        Nesting Int -> ClashDoc
f            -> (Int -> ClashDoc) -> ClashDoc
forall ann. (Int -> Doc ann) -> Doc ann
Nesting (ClashDoc -> ClashDoc
hide (ClashDoc -> ClashDoc) -> (Int -> ClashDoc) -> Int -> ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ClashDoc
f)
        Annotated ClashAnnotation
ann ClashDoc
d'     ->
          if Bool -> Bool
not (PrettyOptions -> Bool
displayTypes PrettyOptions
opts)      Bool -> Bool -> Bool
&& ClashAnnotation
ann ClashAnnotation -> ClashAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
== SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type
          Bool -> Bool -> Bool
|| Bool -> Bool
not (PrettyOptions -> Bool
displayUniques PrettyOptions
opts)    Bool -> Bool -> Bool
&& ClashAnnotation
ann ClashAnnotation -> ClashAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
== SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Unique
          Bool -> Bool -> Bool
|| Bool -> Bool
not (PrettyOptions -> Bool
displayQualifiers PrettyOptions
opts) Bool -> Bool -> Bool
&& ClashAnnotation
ann ClashAnnotation -> ClashAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
== SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Qualifier
          Bool -> Bool -> Bool
|| Bool -> Bool
not (PrettyOptions -> Bool
displayTicks PrettyOptions
opts)      Bool -> Bool -> Bool
&& ClashAnnotation
ann ClashAnnotation -> ClashAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
== SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Ticky
            then ClashDoc
forall ann. Doc ann
Empty
            else ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
Annotated ClashAnnotation
ann (ClashDoc -> ClashDoc
hide ClashDoc
d')
        ClashDoc
d -> ClashDoc
d

pprM :: (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM :: p -> m ClashDoc
pprM = Rational -> p -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
0

pprM' :: (Monad m, PrettyPrec p) => PrettyOptions -> p -> m ClashDoc
pprM' :: PrettyOptions -> p -> m ClashDoc
pprM' PrettyOptions
opts = PrettyOptions -> Rational -> p -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
PrettyOptions -> Rational -> p -> m ClashDoc
pprPrec' PrettyOptions
opts Rational
0

ppr :: PrettyPrec p => p -> ClashDoc
ppr :: p -> ClashDoc
ppr = Identity ClashDoc -> ClashDoc
forall a. Identity a -> a
runIdentity (Identity ClashDoc -> ClashDoc)
-> (p -> Identity ClashDoc) -> p -> ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Identity ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM

ppr' :: PrettyPrec p => PrettyOptions -> p -> ClashDoc
ppr' :: PrettyOptions -> p -> ClashDoc
ppr' PrettyOptions
opts = Identity ClashDoc -> ClashDoc
forall a. Identity a -> a
runIdentity (Identity ClashDoc -> ClashDoc)
-> (p -> Identity ClashDoc) -> p -> ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyOptions -> p -> Identity ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
PrettyOptions -> p -> m ClashDoc
pprM' PrettyOptions
opts

fromPpr :: PrettyPrec a => a -> Doc ()
fromPpr :: a -> Doc ()
fromPpr = ClashDoc -> Doc ()
forall ann. Doc ann -> Doc ()
removeAnnotations (ClashDoc -> Doc ()) -> (a -> ClashDoc) -> a -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ClashDoc
forall p. PrettyPrec p => p -> ClashDoc
ppr

noPrec, opPrec, appPrec :: Num a => a
noPrec :: a
noPrec = a
0
opPrec :: a
opPrec = a
1
appPrec :: a
appPrec = a
2

-- | Print a PrettyPrec thing to a String
showPpr :: PrettyPrec p => p -> String
showPpr :: p -> String
showPpr = PrettyOptions -> p -> String
forall p. PrettyPrec p => PrettyOptions -> p -> String
showPpr' PrettyOptions
forall a. Default a => a
def

showPpr' :: PrettyPrec p => PrettyOptions -> p -> String
showPpr' :: PrettyOptions -> p -> String
showPpr' PrettyOptions
opts = ClashDoc -> String
forall ann. Doc ann -> String
showDoc (ClashDoc -> String) -> (p -> ClashDoc) -> p -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyOptions -> p -> ClashDoc
forall p. PrettyPrec p => PrettyOptions -> p -> ClashDoc
ppr' PrettyOptions
opts

tracePprId :: PrettyPrec p => p -> p
tracePprId :: p -> p
tracePprId p
p = String -> p -> p
forall a. String -> a -> a
trace (p -> String
forall p. PrettyPrec p => p -> String
showPpr p
p) p
p

tracePpr :: PrettyPrec p => p -> a -> a
tracePpr :: p -> a -> a
tracePpr p
p a
a = String -> a -> a
forall a. String -> a -> a
trace (p -> String
forall p. PrettyPrec p => p -> String
showPpr p
p) a
a

parensIf :: Bool -> ClashDoc -> ClashDoc
parensIf :: Bool -> ClashDoc -> ClashDoc
parensIf Bool
False = ClashDoc -> ClashDoc
forall a. a -> a
id
parensIf Bool
True  = ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
parens

tyParens :: ClashDoc -> ClashDoc
tyParens :: ClashDoc -> ClashDoc
tyParens = ClashDoc -> ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose (ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) ClashDoc
forall ann. Doc ann
lparen)
                   (ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) ClashDoc
forall ann. Doc ann
rparen)

tyParensIf :: Bool -> ClashDoc -> ClashDoc
tyParensIf :: Bool -> ClashDoc -> ClashDoc
tyParensIf Bool
False = ClashDoc -> ClashDoc
forall a. a -> a
id
tyParensIf Bool
True  = ClashDoc -> ClashDoc
tyParens

vsepHard :: [ClashDoc] -> ClashDoc
vsepHard :: [ClashDoc] -> ClashDoc
vsepHard = (ClashDoc -> ClashDoc -> ClashDoc) -> [ClashDoc] -> ClashDoc
forall (t :: Type -> Type) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (\ClashDoc
x ClashDoc
y -> ClashDoc
x ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
forall ann. Doc ann
hardline ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
y)

viewName :: Name a -> (Text, Text, Text)
viewName :: Name a -> (Text, Text, Text)
viewName Name a
n = (Text
qual, Text
occ, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Name a -> Int
forall a. Name a -> Int
nameUniq Name a
n)
  where (Text
qual, Text
occ) = Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ Name a -> Text
forall a. Name a -> Text
nameOcc Name a
n

instance PrettyPrec (Name a) where
  pprPrec :: Rational -> Name a -> m ClashDoc
pprPrec Rational
p (Name a -> (Text, Text, Text)
forall a. Name a -> (Text, Text, Text)
viewName -> (Text
qual, Text
occ, Text
uniq)) = do
    ClashDoc
qual' <- ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Qualifier) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Text -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
p Text
qual
    ClashDoc
occ'  <- Rational -> Text -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
p Text
occ
    ClashDoc
uniq' <- ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Unique) (ClashDoc -> ClashDoc)
-> (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
brackets (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rational -> Text -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
p Text
uniq)
    ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc
qual' ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
occ' ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
uniq'

instance ClashPretty (Name a) where
  clashPretty :: Name a -> Doc ()
clashPretty = Name a -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr

instance PrettyPrec a => PrettyPrec [a] where
  pprPrec :: Rational -> [a] -> m ClashDoc
pprPrec Rational
prec = ([ClashDoc] -> ClashDoc) -> m [ClashDoc] -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
vcat (m [ClashDoc] -> m ClashDoc)
-> ([a] -> m [ClashDoc]) -> [a] -> m ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m ClashDoc) -> [a] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Rational -> a -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec)

instance PrettyPrec (Id, Term) where
  pprPrec :: Rational -> (Id, Term) -> m ClashDoc
pprPrec Rational
_ = (Id, Term) -> m ClashDoc
forall (m :: Type -> Type). Monad m => (Id, Term) -> m ClashDoc
pprTopLevelBndr

pprTopLevelBndr :: Monad m => (Id,Term) -> m ClashDoc
pprTopLevelBndr :: (Id, Term) -> m ClashDoc
pprTopLevelBndr (Id
bndr,Term
expr) = do
  ClashDoc
bndr'    <- Id -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM Id
bndr
  ClashDoc
bndrName <- Name Term -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM (Id -> Name Term
forall a. Var a -> Name a
varName Id
bndr)
  ClashDoc
expr'    <- Term -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM Term
expr
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc
bndr' ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
forall ann. Doc ann
line ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 ([ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep [(ClashDoc
bndrName ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
forall ann. Doc ann
equals), ClashDoc
expr']) ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
forall ann. Doc ann
line

dcolon, rarrow, lam, tylam, at, cast, coerce, let_, letrec, in_, case_, of_, forall_,
  data_,newtype_,type_,family_,instance_
  :: ClashDoc
[ClashDoc
dcolon, ClashDoc
rarrow, ClashDoc
lam, ClashDoc
tylam, ClashDoc
at, ClashDoc
cast, ClashDoc
coerce, ClashDoc
let_, ClashDoc
letrec, ClashDoc
in_, ClashDoc
case_, ClashDoc
of_, ClashDoc
forall_,
  ClashDoc
data_,ClashDoc
newtype_,ClashDoc
type_,ClashDoc
family_,ClashDoc
instance_]
  = ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Keyword) (ClashDoc -> ClashDoc) -> [ClashDoc] -> [ClashDoc]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [ClashDoc
"::", ClashDoc
"->", ClashDoc
"λ", ClashDoc
"Λ", ClashDoc
"@", ClashDoc
"▷", ClashDoc
"~", ClashDoc
"let", ClashDoc
"letrec", ClashDoc
"in", ClashDoc
"case", ClashDoc
"of", ClashDoc
"forall",
     ClashDoc
"data",ClashDoc
"newtype",ClashDoc
"type",ClashDoc
"family",ClashDoc
"instance"]

instance PrettyPrec Text where
  pprPrec :: Rational -> Text -> m ClashDoc
pprPrec Rational
_ = ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ClashDoc -> m ClashDoc)
-> (Text -> ClashDoc) -> Text -> m ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty

instance PrettyPrec Type where
  pprPrec :: Rational -> Type -> m ClashDoc
pprPrec Rational
_ Type
t = ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType Type
t

instance ClashPretty Type where
  clashPretty :: Type -> Doc ()
clashPretty = Type -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr

instance PrettyPrec TyCon where
  pprPrec :: Rational -> TyCon -> m ClashDoc
pprPrec Rational
prec TyCon
t = case TyCon
t of
    AlgTyCon Int
_ TyConName
nm Type
kn Int
_ (DataTyCon [DataCon]
dcs) Bool
_ -> do
      ClashDoc
name <- Rational -> TyConName -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec TyConName
nm
      ClashDoc
kind <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprKind Type
kn
      let decl :: ClashDoc
decl = ClashDoc
name ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) (ClashDoc
forall ann. Doc ann
space ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
dcolon ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
kind)

      [ClashDoc]
cons <- (DataCon -> m ClashDoc) -> [DataCon] -> m [ClashDoc]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DataCon -> m ClashDoc
forall (m :: Type -> Type). Monad m => DataCon -> m ClashDoc
pprDataCon [DataCon]
dcs
      ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
vsep (ClashDoc
data_ ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
decl ClashDoc -> [ClashDoc] -> [ClashDoc]
forall a. a -> [a] -> [a]
: [ClashDoc]
cons))
     where
      pprDataCon :: DataCon -> m ClashDoc
pprDataCon DataCon
dc = do
        ClashDoc
name <- Rational -> DataCon -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec DataCon
dc
        ClashDoc
ty <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType (DataCon -> Type
dcType DataCon
dc)

        ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ClashDoc
name ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
dcolon ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
ty)

    AlgTyCon Int
_ TyConName
nm Type
kn Int
_ (NewTyCon DataCon
dc ([TyVar], Type)
_) Bool
_ -> do
      ClashDoc
name <- Rational -> TyConName -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec TyConName
nm
      ClashDoc
kind <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprKind Type
kn
      let decl :: ClashDoc
decl = ClashDoc
name ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) (ClashDoc
forall ann. Doc ann
space ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
dcolon ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
kind)

      ClashDoc
conName <- Rational -> DcName -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec (DataCon -> DcName
dcName DataCon
dc)
      ClashDoc
conType <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType (DataCon -> Type
dcType DataCon
dc)

      ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
vsep [ClashDoc
newtype_ ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
decl, ClashDoc
conName ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
dcolon ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
conType])

    PromotedDataCon Int
_ TyConName
_ Type
_ Int
_ DataCon
dc ->
      (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (ClashDoc
"promoted" ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Rational -> DataCon -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec DataCon
dc)

    FunTyCon Int
_ TyConName
nm Type
kn Int
_ [([Type], Type)]
ss -> do
      ClashDoc
name <- Rational -> TyConName -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec TyConName
nm
      ClashDoc
kind <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprKind Type
kn
      let decl :: ClashDoc
decl = ClashDoc
name ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) (ClashDoc
forall ann. Doc ann
space ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
dcolon ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
kind)

      [ClashDoc]
substs <- (([Type], Type) -> m ClashDoc) -> [([Type], Type)] -> m [ClashDoc]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Type], Type) -> m ClashDoc
forall (m :: Type -> Type). Monad m => ([Type], Type) -> m ClashDoc
pprSubst [([Type], Type)]
ss
      ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
vsep (ClashDoc
type_ ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
family_ ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
decl ClashDoc -> [ClashDoc] -> [ClashDoc]
forall a. a -> [a] -> [a]
: [ClashDoc]
substs))
     where
      pprSubst :: ([Type], Type) -> m ClashDoc
pprSubst ([Type]
xs, Type
y) = do
        ClashDoc
lhs <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType (TyConName -> [Type] -> Type
mkTyConApp (TyCon -> TyConName
tyConName TyCon
t) [Type]
xs)
        ClashDoc
rhs <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType Type
y

        ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ClashDoc
type_ ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
instance_ ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
lhs ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
"=" ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
rhs)

    PrimTyCon Int
_ TyConName
nm Type
kn Int
_ -> do
      ClashDoc
name <- Rational -> TyConName -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec TyConName
nm
      ClashDoc
kind <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprKind Type
kn

      ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ClashDoc
name ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) (ClashDoc
forall ann. Doc ann
space ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
dcolon ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
kind))

instance Pretty LitTy where
  pretty :: LitTy -> Doc ann
pretty (NumTy Integer
i) = Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i
  pretty (SymTy String
s) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
s

instance PrettyPrec LitTy where
  pprPrec :: Rational -> LitTy -> m ClashDoc
pprPrec Rational
_ = ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc)
-> (LitTy -> ClashDoc) -> LitTy -> m ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
LitS) (ClashDoc -> ClashDoc) -> (LitTy -> ClashDoc) -> LitTy -> ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LitTy -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty

instance PrettyPrec Term where
  pprPrec :: Rational -> Term -> m ClashDoc
pprPrec Rational
prec Term
e = case Term
e of
    Var Id
x           -> do
      ClashDoc
v <- Rational -> Name Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec (Id -> Name Term
forall a. Var a -> Name a
varName Id
x)
      ClashDoc
s <- Id -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => Var a -> m ClashDoc
pprPrecIdScope Id
x
      ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ClashDoc
v ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
brackets ClashDoc
s)
    Data DataCon
dc         -> Rational -> DataCon -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec DataCon
dc
    Literal Literal
l       -> Rational -> Literal -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Literal
l
    Prim PrimInfo
p          -> Rational -> Text -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> Text -> m ClashDoc
pprPrecPrim Rational
prec (PrimInfo -> Text
primName PrimInfo
p)
    Lam  Id
v Term
e1       -> ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext (CoreContext -> ClashAnnotation) -> CoreContext -> ClashAnnotation
forall a b. (a -> b) -> a -> b
$ Id -> CoreContext
LamBody Id
v) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         Rational -> [Id] -> Term -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> [Id] -> Term -> m ClashDoc
pprPrecLam Rational
prec [Id
v] Term
e1
    TyLam TyVar
tv Term
e1     -> ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext (CoreContext -> ClashAnnotation) -> CoreContext -> ClashAnnotation
forall a b. (a -> b) -> a -> b
$ TyVar -> CoreContext
TyLamBody TyVar
tv) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         Rational -> [TyVar] -> Term -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> [TyVar] -> Term -> m ClashDoc
pprPrecTyLam Rational
prec [TyVar
tv] Term
e1
    App Term
fun Term
arg     -> Rational -> Term -> Term -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> Term -> Term -> m ClashDoc
pprPrecApp Rational
prec Term
fun Term
arg
    TyApp Term
e' Type
ty     -> ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext CoreContext
TyAppC) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         Rational -> Term -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> Term -> Type -> m ClashDoc
pprPrecTyApp Rational
prec Term
e' Type
ty
    Let (NonRec Id
i Term
x) Term
e1 -> Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc
pprPrecLetrec Rational
prec Bool
False [(Id
i,Term
x)] Term
e1
    Let (Rec [(Id, Term)]
xes) Term
e1   -> Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc
pprPrecLetrec Rational
prec Bool
True [(Id, Term)]
xes Term
e1
    Case Term
e' Type
_ [Alt]
alts  -> Rational -> Term -> [Alt] -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> Term -> [Alt] -> m ClashDoc
pprPrecCase Rational
prec Term
e' [Alt]
alts
    Cast Term
e' Type
ty1 Type
ty2 -> Rational -> Term -> Type -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> Term -> Type -> Type -> m ClashDoc
pprPrecCast Rational
prec Term
e' Type
ty1 Type
ty2
    Tick TickInfo
t Term
e'       -> do
      ClashDoc
tDoc <- Rational -> TickInfo -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec TickInfo
t
      ClashDoc
eDoc <- Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Term
e'
      ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Ticky) (ClashDoc
tDoc ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
forall ann. Doc ann
line') ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
eDoc)

instance PrettyPrec TickInfo where
  pprPrec :: Rational -> TickInfo -> m ClashDoc
pprPrec Rational
prec (SrcSpan SrcSpan
sp)   = Rational -> SrcSpan -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec SrcSpan
sp
  pprPrec Rational
prec (NameMod NameMod
PrefixName Type
t) = (ClashDoc
"<prefixName>" ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<>) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Type -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Type
t
  pprPrec Rational
prec (NameMod NameMod
SuffixName Type
t) = (ClashDoc
"<suffixName>" ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<>) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Type -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Type
t
  pprPrec Rational
prec (NameMod NameMod
SuffixNameP Type
t) = (ClashDoc
"<suffixNameP>" ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<>) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Type -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Type
t
  pprPrec Rational
prec (NameMod NameMod
SetName Type
t)    = (ClashDoc
"<setName>" ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<>) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Type -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Type
t
  pprPrec Rational
_    TickInfo
DeDup                  = ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ClashDoc
"<deDup>"
  pprPrec Rational
_    TickInfo
NoDeDup                = ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ClashDoc
"<noDeDup>"

instance PrettyPrec SrcSpan where
  pprPrec :: Rational -> SrcSpan -> m ClashDoc
pprPrec Rational
_ SrcSpan
sp = ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc
"<src>"ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<>String -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty (SDoc -> String
GHC.showSDocUnsafe (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr SrcSpan
sp)))

instance ClashPretty Term where
  clashPretty :: Term -> Doc ()
clashPretty = Term -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr

data BindingSite = LambdaBind | CaseBind | LetBind

instance PrettyPrec (Var a) where
  pprPrec :: Rational -> Var a -> m ClashDoc
pprPrec Rational
_ v :: Var a
v@(TyVar {}) = Name a -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM (Name a -> m ClashDoc) -> Name a -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ Var a -> Name a
forall a. Var a -> Name a
varName Var a
v
  pprPrec Rational
_ v :: Var a
v@(Id {})    = do
    ClashDoc
v'  <- Name a -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM (Var a -> Name a
forall a. Var a -> Name a
varName Var a
v)
    ClashDoc
ty' <- Type -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM (Var a -> Type
forall a. Var a -> Type
varType Var a
v)
    ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc
v' ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> (ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
align (ClashDoc
forall ann. Doc ann
space ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
dcolon ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
ty'))

instance ClashPretty (Var a) where
  clashPretty :: Var a -> Doc ()
clashPretty = Var a -> Doc ()
forall a. PrettyPrec a => a -> Doc ()
fromPpr

instance PrettyPrec DataCon where
  pprPrec :: Rational -> DataCon -> m ClashDoc
pprPrec Rational
_ = DcName -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM (DcName -> m ClashDoc)
-> (DataCon -> DcName) -> DataCon -> m ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> DcName
dcName

instance PrettyPrec Literal where
  pprPrec :: Rational -> Literal -> m ClashDoc
pprPrec Rational
_ Literal
l = ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
LitS) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ case Literal
l of
    IntegerLiteral Integer
i
      | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0          -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
parens (Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i)
      | Bool
otherwise      -> Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i
    IntLiteral Integer
i
      | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0          -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
parens (Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
"#")
      | Bool
otherwise      -> Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
"#"
    Int64Literal Integer
i
      | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0          -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
parens (Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
"#")
      | Bool
otherwise      -> Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
"#"
    WordLiteral Integer
w      -> Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
w ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
"##"
    Word64Literal Integer
w    -> Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
w ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
"##"
    FloatLiteral Word32
w     -> Float -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty (Word32 -> Float
wordToFloat Word32
w) ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
"#"
    DoubleLiteral Word64
w    -> Double -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty (Word64 -> Double
wordToDouble Word64
w) ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
"##"
    CharLiteral Char
c      -> Char -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
c ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
"#"
    StringLiteral String
s    -> [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
vcat ([ClashDoc] -> ClashDoc) -> [ClashDoc] -> ClashDoc
forall a b. (a -> b) -> a -> b
$ (String -> ClashDoc) -> [String] -> [ClashDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty ([String] -> [ClashDoc]) -> [String] -> [ClashDoc]
forall a b. (a -> b) -> a -> b
$ String -> [String]
showMultiLineString String
s
    NaturalLiteral Integer
n   -> Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
n
    ByteArrayLiteral ByteArray
s -> String -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty (String -> ClashDoc) -> String -> ClashDoc
forall a b. (a -> b) -> a -> b
$ ByteArray -> String
forall a. Show a => a -> String
show ByteArray
s

instance PrettyPrec Pat where
  pprPrec :: Rational -> Pat -> m ClashDoc
pprPrec Rational
prec Pat
pat = case Pat
pat of
    DataPat DataCon
dc [TyVar]
txs [Id]
xs -> do
      ClashDoc
dc'  <- DataCon -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM DataCon
dc
      [ClashDoc]
txs' <- (TyVar -> m ClashDoc) -> [TyVar] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BindingSite -> TyVar -> m ClashDoc
forall (m :: Type -> Type) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m ClashDoc
pprBndr BindingSite
LetBind) [TyVar]
txs
      [ClashDoc]
xs'  <- (Id -> m ClashDoc) -> [Id] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BindingSite -> Id -> m ClashDoc
forall (m :: Type -> Type) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m ClashDoc
pprBndr BindingSite
CaseBind) [Id]
xs
      ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ Bool -> ClashDoc -> ClashDoc
parensIf (Rational
prec Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
forall a. Num a => a
appPrec) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
        [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep [ [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
hsep (ClashDoc
dc'ClashDoc -> [ClashDoc] -> [ClashDoc]
forall a. a -> [a] -> [a]
:[ClashDoc]
txs')
            , Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 ([ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep [ClashDoc]
xs') ]
    LitPat Literal
l   -> Literal -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM Literal
l
    Pat
DefaultPat -> ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return ClashDoc
"_"

pprPrecIdScope :: Monad m => Var a -> m ClashDoc
pprPrecIdScope :: Var a -> m ClashDoc
pprPrecIdScope (TyVar {}) = ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ClashDoc
"TyVar"
pprPrecIdScope (Id Name a
_ Int
_ Type
_ IdScope
GlobalId) = ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ClashDoc
"GlobalId"
pprPrecIdScope (Id Name a
_ Int
_ Type
_ IdScope
LocalId) = ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ClashDoc
"LocalId"

pprPrecPrim :: Monad m => Rational -> Text -> m ClashDoc
pprPrecPrim :: Rational -> Text -> m ClashDoc
pprPrecPrim Rational
prec Text
nm =
  ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
(<>) (ClashDoc -> ClashDoc -> ClashDoc)
-> m ClashDoc -> m (ClashDoc -> ClashDoc)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Qualifier) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Text -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Text
qual)
       m (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Rational -> Text -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Text
occ
  where (Text
qual, Text
occ) = Text -> Text -> (Text, Text)
T.breakOnEnd Text
"." Text
nm

pprPrecLam :: Monad m => Rational -> [Id] -> Term -> m ClashDoc
pprPrecLam :: Rational -> [Id] -> Term -> m ClashDoc
pprPrecLam Rational
prec [Id]
xs Term
e = do
  [ClashDoc]
xs' <- (Id -> m ClashDoc) -> [Id] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BindingSite -> Id -> m ClashDoc
forall (m :: Type -> Type) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m ClashDoc
pprBndr BindingSite
LambdaBind) [Id]
xs
  ClashDoc
e'  <- Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Term
e
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ Bool -> ClashDoc -> ClashDoc
parensIf (Rational
prec Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
forall a. Num a => a
noPrec) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
    ClashDoc
lam ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
hsep [ClashDoc]
xs' ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
rarrow ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
forall ann. Doc ann
line ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
e'

pprPrecTyLam :: Monad m => Rational -> [TyVar] -> Term -> m ClashDoc
pprPrecTyLam :: Rational -> [TyVar] -> Term -> m ClashDoc
pprPrecTyLam Rational
prec [TyVar]
tvs Term
e = do
  [ClashDoc]
tvs' <- (TyVar -> m ClashDoc) -> [TyVar] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM [TyVar]
tvs
  ClashDoc
e'   <- Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Term
e
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ Bool -> ClashDoc -> ClashDoc
tyParensIf (Rational
prec Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
forall a. Num a => a
noPrec) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
    ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) (ClashDoc
tylam ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
hsep [ClashDoc]
tvs' ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
rarrow ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
forall ann. Doc ann
line) ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
e'

pprPrecApp :: Monad m => Rational -> Term -> Term -> m ClashDoc
pprPrecApp :: Rational -> Term -> Term -> m ClashDoc
pprPrecApp Rational
prec Term
e1 Term
e2 = do
  ClashDoc
e1' <- ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext CoreContext
AppFun) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
opPrec Term
e1
  ClashDoc
e2' <- ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext (CoreContext -> ClashAnnotation) -> CoreContext -> ClashAnnotation
forall a b. (a -> b) -> a -> b
$ Maybe (Text, Int, Int) -> CoreContext
AppArg (Maybe (Text, Int, Int) -> CoreContext)
-> Maybe (Text, Int, Int) -> CoreContext
forall a b. (a -> b) -> a -> b
$ Term -> Maybe (Text, Int, Int)
primArg Term
e2) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
appPrec Term
e2
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ Bool -> ClashDoc -> ClashDoc
parensIf (Rational
prec Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
forall a. Num a => a
appPrec) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
    Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 ([ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep [ClashDoc
e1',ClashDoc
e2'])

pprPrecTyApp :: Monad m => Rational -> Term -> Type -> m ClashDoc
pprPrecTyApp :: Rational -> Term -> Type -> m ClashDoc
pprPrecTyApp Rational
prec Term
e Type
ty = do
  ClashDoc
e'  <- Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
opPrec Term
e
  ClashDoc
ty' <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprParendType Type
ty
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ Bool -> ClashDoc -> ClashDoc
tyParensIf (Rational
prec Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
forall a. Num a => a
appPrec) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
    Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
group (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
      ClashDoc
e' ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) (ClashDoc
forall ann. Doc ann
line ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
at ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
ty')

pprPrecCast :: Monad m => Rational -> Term -> Type -> Type -> m ClashDoc
pprPrecCast :: Rational -> Term -> Type -> Type -> m ClashDoc
pprPrecCast Rational
prec Term
e Type
ty1 Type
ty2 = do
  ClashDoc
e'   <- ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext CoreContext
CastBody) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
appPrec Term
e
  ClashDoc
ty1' <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType Type
ty1
  ClashDoc
ty2' <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType Type
ty2
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ Bool -> ClashDoc -> ClashDoc
tyParensIf (Rational
prec Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
forall a. Num a => a
appPrec) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
    ClashDoc
e' ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type)
                   (ClashDoc
forall ann. Doc ann
softline ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 ([ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
vsep [ClashDoc
cast, ClashDoc
ty1', ClashDoc
coerce, ClashDoc
ty2']))

-- TODO Since Clash now keeps non-recursive let expressions separately, the
-- result of normalization will contain more nested let expressions as the old
-- Letrec-based definitions are replaced by Let. As this happens, it may be a
-- good idea to change pprPrecLetrec to encourage more compact forms such as
-- printing the entire binding on one line if possible.

pprPrecLetrec :: Monad m => Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc
pprPrecLetrec :: Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc
pprPrecLetrec Rational
prec Bool
isRec [(Id, Term)]
xes Term
body = do
  let bndrs :: [Id]
bndrs = (Id, Term) -> Id
forall a b. (a, b) -> a
fst ((Id, Term) -> Id) -> [(Id, Term)] -> [Id]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Id, Term)]
xes
  ClashDoc
body' <- ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext (CoreContext -> ClashAnnotation) -> CoreContext -> ClashAnnotation
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreContext
LetBody [Id]
bndrs) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Term
body
  [ClashDoc]
xes'  <- ((Id, Term) -> m ClashDoc) -> [(Id, Term)] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Id
x,Term
e) -> do
                  ClashDoc
x' <- BindingSite -> Id -> m ClashDoc
forall (m :: Type -> Type) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m ClashDoc
pprBndr BindingSite
LetBind Id
x
                  ClashDoc
e' <- Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Term
e
                  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext (CoreContext -> ClashAnnotation) -> CoreContext -> ClashAnnotation
forall a b. (a -> b) -> a -> b
$ Id -> [Id] -> CoreContext
LetBinding Id
x [Id]
bndrs) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
                    [ClashDoc] -> ClashDoc
vsepHard [ClashDoc
x', ClashDoc
forall ann. Doc ann
equals ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
e']
                ) [(Id, Term)]
xes
  let xes'' :: [ClashDoc]
xes'' = case [ClashDoc]
xes' of { [] -> [ClashDoc
"EmptyLetrec"]; [ClashDoc]
_  -> [ClashDoc]
xes' }
  let kw :: ClashDoc
kw = if Bool
isRec then ClashDoc
letrec else ClashDoc
let_
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ Bool -> ClashDoc -> ClashDoc
parensIf (Rational
prec Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
forall a. Num a => a
noPrec) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
    [ClashDoc] -> ClashDoc
vsepHard [Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 ([ClashDoc] -> ClashDoc
vsepHard ([ClashDoc] -> ClashDoc) -> [ClashDoc] -> ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc
kw ClashDoc -> [ClashDoc] -> [ClashDoc]
forall a. a -> [a] -> [a]
: [ClashDoc]
xes''), ClashDoc
in_ ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
body']

pprPrecCase :: Monad m => Rational -> Term -> [(Pat,Term)] -> m ClashDoc
pprPrecCase :: Rational -> Term -> [Alt] -> m ClashDoc
pprPrecCase Rational
prec Term
e [Alt]
alts = do
  ClashDoc
e'    <- ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext CoreContext
CaseScrut) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Term
e
  [ClashDoc]
alts' <- (Alt -> m ClashDoc) -> [Alt] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Rational -> Alt -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
Rational -> Alt -> m ClashDoc
pprPrecAlt Rational
forall a. Num a => a
noPrec) [Alt]
alts
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ Bool -> ClashDoc -> ClashDoc
parensIf (Rational
prec Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
forall a. Num a => a
noPrec) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
    Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ [ClashDoc] -> ClashDoc
vsepHard ([ClashDoc] -> ClashDoc) -> [ClashDoc] -> ClashDoc
forall a b. (a -> b) -> a -> b
$ (ClashDoc
case_ ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
e' ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
of_) ClashDoc -> [ClashDoc] -> [ClashDoc]
forall a. a -> [a] -> [a]
: [ClashDoc]
alts'

pprPrecAlt :: Monad m => Rational -> (Pat,Term) -> m ClashDoc
pprPrecAlt :: Rational -> Alt -> m ClashDoc
pprPrecAlt Rational
_ (Pat
altPat, Term
altE) = do
  ClashDoc
altPat' <- Rational -> Pat -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Pat
altPat
  ClashDoc
altE'   <- Rational -> Term -> m ClashDoc
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Term
altE
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext (CoreContext -> ClashAnnotation) -> CoreContext -> ClashAnnotation
forall a b. (a -> b) -> a -> b
$ Pat -> CoreContext
CaseAlt Pat
altPat) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
    Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ [ClashDoc] -> ClashDoc
vsepHard [(ClashDoc
altPat' ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
rarrow), ClashDoc
altE']

pprBndr :: (Monad m, PrettyPrec a) => BindingSite -> a -> m ClashDoc
pprBndr :: BindingSite -> a -> m ClashDoc
pprBndr BindingSite
LetBind = a -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM
pprBndr BindingSite
_       = (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ClashDoc -> ClashDoc
tyParens (m ClashDoc -> m ClashDoc) -> (a -> m ClashDoc) -> a -> m ClashDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM

data TypePrec = TopPrec | FunPrec | TyConPrec deriving (TypePrec -> TypePrec -> Bool
(TypePrec -> TypePrec -> Bool)
-> (TypePrec -> TypePrec -> Bool) -> Eq TypePrec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypePrec -> TypePrec -> Bool
$c/= :: TypePrec -> TypePrec -> Bool
== :: TypePrec -> TypePrec -> Bool
$c== :: TypePrec -> TypePrec -> Bool
Eq,Eq TypePrec
Eq TypePrec
-> (TypePrec -> TypePrec -> Ordering)
-> (TypePrec -> TypePrec -> Bool)
-> (TypePrec -> TypePrec -> Bool)
-> (TypePrec -> TypePrec -> Bool)
-> (TypePrec -> TypePrec -> Bool)
-> (TypePrec -> TypePrec -> TypePrec)
-> (TypePrec -> TypePrec -> TypePrec)
-> Ord TypePrec
TypePrec -> TypePrec -> Bool
TypePrec -> TypePrec -> Ordering
TypePrec -> TypePrec -> TypePrec
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 :: TypePrec -> TypePrec -> TypePrec
$cmin :: TypePrec -> TypePrec -> TypePrec
max :: TypePrec -> TypePrec -> TypePrec
$cmax :: TypePrec -> TypePrec -> TypePrec
>= :: TypePrec -> TypePrec -> Bool
$c>= :: TypePrec -> TypePrec -> Bool
> :: TypePrec -> TypePrec -> Bool
$c> :: TypePrec -> TypePrec -> Bool
<= :: TypePrec -> TypePrec -> Bool
$c<= :: TypePrec -> TypePrec -> Bool
< :: TypePrec -> TypePrec -> Bool
$c< :: TypePrec -> TypePrec -> Bool
compare :: TypePrec -> TypePrec -> Ordering
$ccompare :: TypePrec -> TypePrec -> Ordering
$cp1Ord :: Eq TypePrec
Ord)

maybeParen :: TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen :: TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen TypePrec
ctxt_prec TypePrec
inner_prec = Bool -> ClashDoc -> ClashDoc
parensIf (TypePrec
ctxt_prec TypePrec -> TypePrec -> Bool
forall a. Ord a => a -> a -> Bool
>= TypePrec
inner_prec)

pprType :: Monad m => Type -> m ClashDoc
pprType :: Type -> m ClashDoc
pprType = TypePrec -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
TopPrec

pprParendType :: Monad m => Type -> m ClashDoc
pprParendType :: Type -> m ClashDoc
pprParendType = TypePrec -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
TyConPrec

ppr_type :: Monad m => TypePrec -> Type -> m ClashDoc
ppr_type :: TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
_ (VarTy TyVar
tv)                   = TyVar -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM TyVar
tv
ppr_type TypePrec
_ (LitTy LitTy
tyLit)                = LitTy -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM LitTy
tyLit
ppr_type TypePrec
p ty :: Type
ty@(ForAllTy {})             = TypePrec -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
pprForAllType TypePrec
p Type
ty
ppr_type TypePrec
p (ConstTy (TyCon TyConName
tc))         = TypePrec
-> (TypePrec -> Type -> m ClashDoc)
-> TyConName
-> [Type]
-> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec
-> (TypePrec -> Type -> m ClashDoc)
-> TyConName
-> [Type]
-> m ClashDoc
pprTcApp TypePrec
p TypePrec -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
ppr_type TyConName
tc []
ppr_type TypePrec
p (AnnType [Attr']
_ann Type
typ)           = TypePrec -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
p Type
typ
ppr_type TypePrec
p (Type -> TypeView
tyView -> TyConApp TyConName
tc [Type]
args) = TypePrec
-> (TypePrec -> Type -> m ClashDoc)
-> TyConName
-> [Type]
-> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec
-> (TypePrec -> Type -> m ClashDoc)
-> TyConName
-> [Type]
-> m ClashDoc
pprTcApp TypePrec
p TypePrec -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
ppr_type TyConName
tc [Type]
args
ppr_type TypePrec
p (Type -> TypeView
tyView -> FunTy Type
ty1 Type
ty2)
  = [ClashDoc] -> ClashDoc
pprArrowChain ([ClashDoc] -> ClashDoc) -> m [ClashDoc] -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TypePrec -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
FunPrec Type
ty1 m ClashDoc -> m [ClashDoc] -> m [ClashDoc]
forall (f :: Type -> Type) a.
Applicative f =>
f a -> f [a] -> f [a]
<:> Type -> m [ClashDoc]
forall (f :: Type -> Type). Monad f => Type -> f [ClashDoc]
pprFunTail Type
ty2
  where
    pprFunTail :: Type -> f [ClashDoc]
pprFunTail (Type -> TypeView
tyView -> FunTy Type
ty1' Type
ty2')
      = TypePrec -> Type -> f ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
FunPrec Type
ty1' f ClashDoc -> f [ClashDoc] -> f [ClashDoc]
forall (f :: Type -> Type) a.
Applicative f =>
f a -> f [a] -> f [a]
<:> Type -> f [ClashDoc]
pprFunTail Type
ty2'
    pprFunTail Type
otherTy
      = TypePrec -> Type -> f ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
TopPrec Type
otherTy f ClashDoc -> f [ClashDoc] -> f [ClashDoc]
forall (f :: Type -> Type) a.
Applicative f =>
f a -> f [a] -> f [a]
<:> [ClashDoc] -> f [ClashDoc]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []

    pprArrowChain :: [ClashDoc] -> ClashDoc
pprArrowChain []
      = ClashDoc
forall ann. Doc ann
emptyDoc
    pprArrowChain (ClashDoc
arg:[ClashDoc]
args)
      = TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen TypePrec
p TypePrec
FunPrec (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep [ClashDoc
arg, [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep ((ClashDoc -> ClashDoc) -> [ClashDoc] -> [ClashDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ClashDoc
rarrow ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) [ClashDoc]
args)]

ppr_type TypePrec
p (AppTy Type
ty1 Type
ty2) = TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen TypePrec
p TypePrec
TyConPrec (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
(<+>) (ClashDoc -> ClashDoc -> ClashDoc)
-> m ClashDoc -> m (ClashDoc -> ClashDoc)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType Type
ty1
                                                               m (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> TypePrec -> Type -> m ClashDoc
forall (m :: Type -> Type).
Monad m =>
TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
TyConPrec Type
ty2)
ppr_type TypePrec
_ (ConstTy ConstTy
Arrow) = ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
parens ClashDoc
rarrow)

pprForAllType :: Monad m => TypePrec -> Type -> m ClashDoc
pprForAllType :: TypePrec -> Type -> m ClashDoc
pprForAllType TypePrec
p Type
ty = TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen TypePrec
p TypePrec
FunPrec (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Bool -> Type -> m ClashDoc
pprSigmaType Bool
True Type
ty

pprSigmaType :: Monad m => Bool -> Type -> m ClashDoc
pprSigmaType :: Bool -> Type -> m ClashDoc
pprSigmaType Bool
showForalls Type
ty = do
    ([TyVar]
tvs, Type
rho)     <- [TyVar] -> Type -> m ([TyVar], Type)
forall (m :: Type -> Type).
Monad m =>
[TyVar] -> Type -> m ([TyVar], Type)
split1 [] Type
ty
    [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep ([ClashDoc] -> ClashDoc) -> m [ClashDoc] -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [m ClashDoc] -> m [ClashDoc]
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [ if Bool
showForalls then [TyVar] -> m ClashDoc
forall (m :: Type -> Type). Monad m => [TyVar] -> m ClashDoc
pprForAll [TyVar]
tvs else ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ClashDoc
forall ann. Doc ann
emptyDoc
                      , Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType Type
rho
                      ]
  where
    split1 :: [TyVar] -> Type -> m ([TyVar], Type)
split1 [TyVar]
tvs (ForAllTy TyVar
tv Type
resTy) = [TyVar] -> Type -> m ([TyVar], Type)
split1 (TyVar
tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
tvs) Type
resTy
    split1 [TyVar]
tvs Type
resTy               = ([TyVar], Type) -> m ([TyVar], Type)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([TyVar] -> [TyVar]
forall a. [a] -> [a]
reverse [TyVar]
tvs,Type
resTy)

pprForAll :: Monad m => [TyVar] -> m ClashDoc
pprForAll :: [TyVar] -> m ClashDoc
pprForAll []  = ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return ClashDoc
forall ann. Doc ann
emptyDoc
pprForAll [TyVar]
tvs = do
  [ClashDoc]
tvs' <- (TyVar -> m ClashDoc) -> [TyVar] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> m ClashDoc
forall (m :: Type -> Type). Monad m => TyVar -> m ClashDoc
pprTvBndr [TyVar]
tvs
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc
forall_ ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep [ClashDoc]
tvs' ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
forall ann. Doc ann
dot

pprTvBndr :: Monad m => TyVar -> m ClashDoc
pprTvBndr :: TyVar -> m ClashDoc
pprTvBndr TyVar
tv = do
  ClashDoc
tv'   <- TyVar -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM TyVar
tv
  ClashDoc
kind' <- Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprKind (TyVar -> Type
forall a. Var a -> Type
varType TyVar
tv)
  ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc -> ClashDoc
tyParens (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc
tv' ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> (ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Type) (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc
forall ann. Doc ann
space ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<> ClashDoc
dcolon ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
kind')

pprKind :: Monad m => Kind -> m ClashDoc
pprKind :: Type -> m ClashDoc
pprKind = Type -> m ClashDoc
forall (m :: Type -> Type). Monad m => Type -> m ClashDoc
pprType

pprTcApp :: Monad m => TypePrec -> (TypePrec -> Type -> m ClashDoc)
  -> TyConName -> [Type] -> m ClashDoc
pprTcApp :: TypePrec
-> (TypePrec -> Type -> m ClashDoc)
-> TyConName
-> [Type]
-> m ClashDoc
pprTcApp TypePrec
p TypePrec -> Type -> m ClashDoc
pp TyConName
tc [Type]
tys
  | [Type] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
null [Type]
tys
  = TyConName -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM TyConName
tc

  | TyConName -> Bool
isTupleTyConLike TyConName
tc
  = do [ClashDoc]
tys' <- (Type -> m ClashDoc) -> [Type] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypePrec -> Type -> m ClashDoc
pp TypePrec
TopPrec) [Type]
tys
       ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann
parens (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep ([ClashDoc] -> ClashDoc) -> [ClashDoc] -> ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc -> [ClashDoc] -> [ClashDoc]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate ClashDoc
forall ann. Doc ann
comma [ClashDoc]
tys'

  | Bool
isSym
  , [Type
ty1, Type
ty2] <- [Type]
tys
  = do ClashDoc
ty1' <- TypePrec -> Type -> m ClashDoc
pp TypePrec
FunPrec Type
ty1
       ClashDoc
ty2' <- TypePrec -> Type -> m ClashDoc
pp TypePrec
FunPrec Type
ty2
       ClashDoc
tc' <- TyConName -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM TyConName
tc
       ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen TypePrec
p TypePrec
FunPrec (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
         [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep [ClashDoc
ty1', ClashDoc -> ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose ClashDoc
"`" ClashDoc
"`" ClashDoc
tc' ClashDoc -> ClashDoc -> ClashDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ClashDoc
ty2']

  | Bool
otherwise
  = do [ClashDoc]
tys' <- (Type -> m ClashDoc) -> [Type] -> m [ClashDoc]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypePrec -> Type -> m ClashDoc
pp TypePrec
TyConPrec) [Type]
tys
       ClashDoc
tc' <- Bool -> ClashDoc -> ClashDoc
parensIf Bool
isSym (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TyConName -> m ClashDoc
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m ClashDoc
pprM TyConName
tc
       ClashDoc -> m ClashDoc
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ClashDoc -> m ClashDoc) -> ClashDoc -> m ClashDoc
forall a b. (a -> b) -> a -> b
$ TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen TypePrec
p TypePrec
TyConPrec (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$
         Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (ClashDoc -> ClashDoc) -> ClashDoc -> ClashDoc
forall a b. (a -> b) -> a -> b
$ [ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep (ClashDoc
tc'ClashDoc -> [ClashDoc] -> [ClashDoc]
forall a. a -> [a] -> [a]
:[ClashDoc]
tys')

  where isSym :: Bool
isSym = TyConName -> Bool
forall a. Name a -> Bool
isSymName TyConName
tc

isSymName :: Name a -> Bool
isSymName :: Name a -> Bool
isSymName Name a
n = Text -> Bool
go (Name a -> Text
forall a. Name a -> Text
nameOcc Name a
n)
  where
    go :: Text -> Bool
go Text
s | Text -> Bool
T.null Text
s           = Bool
False
         | Char -> Bool
isUpper (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
s = Text -> Bool
isLexConSym Text
s
         | Bool
otherwise          = Text -> Bool
isLexSym Text
s

isLexSym :: Text -> Bool
isLexSym :: Text -> Bool
isLexSym Text
cs = Text -> Bool
isLexConSym Text
cs Bool -> Bool -> Bool
|| Text -> Bool
isLexVarSym Text
cs

isLexConSym :: Text -> Bool
isLexConSym :: Text -> Bool
isLexConSym Text
"->" = Bool
True
isLexConSym Text
cs   = Char -> Bool
startsConSym (Text -> Char
T.head Text
cs)

isLexVarSym :: Text -> Bool
isLexVarSym :: Text -> Bool
isLexVarSym Text
cs = Char -> Bool
startsVarSym (Text -> Char
T.head Text
cs)

startsConSym :: Char -> Bool
startsConSym :: Char -> Bool
startsConSym Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':'

startsVarSym :: Char -> Bool
startsVarSym :: Char -> Bool
startsVarSym Char
c = Char -> Bool
isSymbolASCII Char
c Bool -> Bool -> Bool
|| (Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0x7f Bool -> Bool -> Bool
&& Char -> Bool
isSymbol Char
c)

isSymbolASCII :: Char -> Bool
isSymbolASCII :: Char -> Bool
isSymbolASCII Char
c = Char
c Char -> String -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` (String
"!#$%&*+./<=>?@\\^|~-" :: String)