{-|
  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 #-}

{-# 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 :: HasCallStack => 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
    { 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
$c== :: ClashAnnotation -> ClashAnnotation -> Bool
== :: ClashAnnotation -> ClashAnnotation -> Bool
$c/= :: ClashAnnotation -> ClashAnnotation -> Bool
/= :: 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
$c== :: SyntaxElement -> SyntaxElement -> Bool
== :: SyntaxElement -> SyntaxElement -> Bool
$c/= :: SyntaxElement -> SyntaxElement -> Bool
/= :: 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
$cshowsPrec :: Int -> SyntaxElement -> String -> String
showsPrec :: Int -> SyntaxElement -> String -> String
$cshow :: SyntaxElement -> String
show :: SyntaxElement -> String
$cshowList :: [SyntaxElement] -> String -> String
showList :: [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 = (Doc ClashAnnotation -> Doc ClashAnnotation)
-> m (Doc ClashAnnotation) -> m (Doc ClashAnnotation)
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc ClashAnnotation -> Doc ClashAnnotation
hide (m (Doc ClashAnnotation) -> m (Doc ClashAnnotation))
-> (p -> m (Doc ClashAnnotation)) -> p -> m (Doc ClashAnnotation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> p -> m (Doc ClashAnnotation)
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m (Doc ClashAnnotation)
forall (m :: Type -> Type).
Monad m =>
Rational -> p -> m (Doc ClashAnnotation)
pprPrec Rational
p
    where
      hide :: Doc ClashAnnotation -> Doc ClashAnnotation
hide = \case
        FlatAlt Doc ClashAnnotation
d Doc ClashAnnotation
d'         -> Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. Doc ann -> Doc ann -> Doc ann
FlatAlt (Doc ClashAnnotation -> Doc ClashAnnotation
hide Doc ClashAnnotation
d) (Doc ClashAnnotation -> Doc ClashAnnotation
hide Doc ClashAnnotation
d')
        Cat Doc ClashAnnotation
d Doc ClashAnnotation
d'             -> Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. Doc ann -> Doc ann -> Doc ann
Cat (Doc ClashAnnotation -> Doc ClashAnnotation
hide Doc ClashAnnotation
d) (Doc ClashAnnotation -> Doc ClashAnnotation
hide Doc ClashAnnotation
d')
        Nest Int
i Doc ClashAnnotation
d             -> Int -> Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. Int -> Doc ann -> Doc ann
Nest Int
i (Doc ClashAnnotation -> Doc ClashAnnotation
hide Doc ClashAnnotation
d)
        Union Doc ClashAnnotation
d Doc ClashAnnotation
d'           -> Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. Doc ann -> Doc ann -> Doc ann
Union (Doc ClashAnnotation -> Doc ClashAnnotation
hide Doc ClashAnnotation
d) (Doc ClashAnnotation -> Doc ClashAnnotation
hide Doc ClashAnnotation
d')
        Column Int -> Doc ClashAnnotation
f             -> (Int -> Doc ClashAnnotation) -> Doc ClashAnnotation
forall ann. (Int -> Doc ann) -> Doc ann
Column (Doc ClashAnnotation -> Doc ClashAnnotation
hide (Doc ClashAnnotation -> Doc ClashAnnotation)
-> (Int -> Doc ClashAnnotation) -> Int -> Doc ClashAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ClashAnnotation
f)
        WithPageWidth PageWidth -> Doc ClashAnnotation
f      -> (PageWidth -> Doc ClashAnnotation) -> Doc ClashAnnotation
forall ann. (PageWidth -> Doc ann) -> Doc ann
WithPageWidth (Doc ClashAnnotation -> Doc ClashAnnotation
hide (Doc ClashAnnotation -> Doc ClashAnnotation)
-> (PageWidth -> Doc ClashAnnotation)
-> PageWidth
-> Doc ClashAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PageWidth -> Doc ClashAnnotation
f)
        Nesting Int -> Doc ClashAnnotation
f            -> (Int -> Doc ClashAnnotation) -> Doc ClashAnnotation
forall ann. (Int -> Doc ann) -> Doc ann
Nesting (Doc ClashAnnotation -> Doc ClashAnnotation
hide (Doc ClashAnnotation -> Doc ClashAnnotation)
-> (Int -> Doc ClashAnnotation) -> Int -> Doc ClashAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ClashAnnotation
f)
        Annotated ClashAnnotation
ann Doc ClashAnnotation
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 Doc ClashAnnotation
forall ann. Doc ann
Empty
            else ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. ann -> Doc ann -> Doc ann
Annotated ClashAnnotation
ann (Doc ClashAnnotation -> Doc ClashAnnotation
hide Doc ClashAnnotation
d')
        Doc ClashAnnotation
d -> Doc ClashAnnotation
d

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

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

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

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

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

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

-- | Print a PrettyPrec thing to a String
showPpr :: PrettyPrec p => p -> String
showPpr :: forall p. PrettyPrec p => 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' :: forall p. PrettyPrec p => PrettyOptions -> p -> String
showPpr' PrettyOptions
opts = Doc ClashAnnotation -> String
forall ann. Doc ann -> String
showDoc (Doc ClashAnnotation -> String)
-> (p -> Doc ClashAnnotation) -> p -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyOptions -> p -> Doc ClashAnnotation
forall p. PrettyPrec p => PrettyOptions -> p -> Doc ClashAnnotation
ppr' PrettyOptions
opts

tracePprId :: PrettyPrec p => p -> p
tracePprId :: forall p. PrettyPrec p => 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 :: forall p a. PrettyPrec p => 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 -> Doc ClashAnnotation -> Doc ClashAnnotation
parensIf Bool
False = Doc ClashAnnotation -> Doc ClashAnnotation
forall a. a -> a
id
parensIf Bool
True  = Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. Doc ann -> Doc ann
parens

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

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

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

viewName :: Name a -> (Text, Text, Text)
viewName :: forall a. 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
$ Unique -> String
forall a. Show a => a -> String
show (Unique -> String) -> Unique -> String
forall a b. (a -> b) -> a -> b
$ Name a -> Unique
forall a. Name a -> Unique
nameUniq Name a
n)
  where (Text
qual, Text
occ) = HasCallStack => Text -> Text -> (Text, Text)
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 :: forall (m :: Type -> Type).
Monad m =>
Rational -> Name a -> m (Doc ClashAnnotation)
pprPrec Rational
p (Name a -> (Text, Text, Text)
forall a. Name a -> (Text, Text, Text)
viewName -> (Text
qual, Text
occ, Text
uniq)) = do
    qual' <- ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Qualifier) (Doc ClashAnnotation -> Doc ClashAnnotation)
-> m (Doc ClashAnnotation) -> m (Doc ClashAnnotation)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Text -> m (Doc ClashAnnotation)
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m (Doc ClashAnnotation)
forall (m :: Type -> Type).
Monad m =>
Rational -> Text -> m (Doc ClashAnnotation)
pprPrec Rational
p Text
qual
    occ'  <- pprPrec p occ
    uniq' <- annotate (AnnSyntax Unique) . brackets <$> (pprPrec p uniq)
    return $ qual' <> occ' <> 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 :: forall (m :: Type -> Type).
Monad m =>
Rational -> [a] -> m (Doc ClashAnnotation)
pprPrec Rational
prec = ([Doc ClashAnnotation] -> Doc ClashAnnotation)
-> m [Doc ClashAnnotation] -> m (Doc ClashAnnotation)
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [Doc ClashAnnotation] -> Doc ClashAnnotation
forall ann. [Doc ann] -> Doc ann
vcat (m [Doc ClashAnnotation] -> m (Doc ClashAnnotation))
-> ([a] -> m [Doc ClashAnnotation])
-> [a]
-> m (Doc ClashAnnotation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (Doc ClashAnnotation)) -> [a] -> m [Doc ClashAnnotation]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (Rational -> a -> m (Doc ClashAnnotation)
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m (Doc ClashAnnotation)
forall (m :: Type -> Type).
Monad m =>
Rational -> a -> m (Doc ClashAnnotation)
pprPrec Rational
prec)

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

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

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

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

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

      cons <- traverse pprDataCon dcs
      pure (vsep (data_ <+> decl : cons))
     where
      pprDataCon :: DataCon -> m (Doc ClashAnnotation)
pprDataCon DataCon
dc = do
        name <- Rational -> DataCon -> m (Doc ClashAnnotation)
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m (Doc ClashAnnotation)
forall (m :: Type -> Type).
Monad m =>
Rational -> DataCon -> m (Doc ClashAnnotation)
pprPrec Rational
prec DataCon
dc
        ty <- pprType (dcType dc)

        pure (name <+> dcolon <+> ty)

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

      conName <- pprPrec prec (dcName dc)
      conType <- pprType (dcType dc)

      pure (vsep [newtype_ <+> decl, conName <+> dcolon <+> conType])

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

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

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

        pure (type_ <+> instance_ <+> lhs <+> "=" <+> rhs)

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

      pure (name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind))

instance Pretty LitTy where
  pretty :: forall ann. LitTy -> Doc ann
pretty (NumTy Integer
i) = Integer -> Doc ann
forall ann. 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 ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
s
  pretty (CharTy Char
c) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
squotes (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Char -> Doc ann
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
c

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

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

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

instance PrettyPrec SrcSpan where
  pprPrec :: forall (m :: Type -> Type).
Monad m =>
Rational -> SrcSpan -> m (Doc ClashAnnotation)
pprPrec Rational
_ SrcSpan
sp = Doc ClashAnnotation -> m (Doc ClashAnnotation)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Doc ClashAnnotation
"<src>"Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<>String -> Doc ClashAnnotation
forall ann. String -> Doc ann
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 :: forall (m :: Type -> Type).
Monad m =>
Rational -> Var a -> m (Doc ClashAnnotation)
pprPrec Rational
_ v :: Var a
v@(TyVar {}) = Name a -> m (Doc ClashAnnotation)
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m (Doc ClashAnnotation)
pprM (Name a -> m (Doc ClashAnnotation))
-> Name a -> m (Doc ClashAnnotation)
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
    v'  <- Name a -> m (Doc ClashAnnotation)
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m (Doc ClashAnnotation)
pprM (Var a -> Name a
forall a. Var a -> Name a
varName Var a
v)
    ty' <- pprM (varType v)
    return $ v' <> (annotate (AnnSyntax Type) $ align (space <> dcolon <+> 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 :: forall (m :: Type -> Type).
Monad m =>
Rational -> DataCon -> m (Doc ClashAnnotation)
pprPrec Rational
_ = DcName -> m (Doc ClashAnnotation)
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m (Doc ClashAnnotation)
pprM (DcName -> m (Doc ClashAnnotation))
-> (DataCon -> DcName) -> DataCon -> m (Doc ClashAnnotation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> DcName
dcName

instance PrettyPrec Literal where
  pprPrec :: forall (m :: Type -> Type).
Monad m =>
Rational -> Literal -> m (Doc ClashAnnotation)
pprPrec Rational
_ Literal
l = Doc ClashAnnotation -> m (Doc ClashAnnotation)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Doc ClashAnnotation -> m (Doc ClashAnnotation))
-> Doc ClashAnnotation -> m (Doc ClashAnnotation)
forall a b. (a -> b) -> a -> b
$ ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
LitS) (Doc ClashAnnotation -> Doc ClashAnnotation)
-> Doc ClashAnnotation -> Doc ClashAnnotation
forall a b. (a -> b) -> a -> b
$ case Literal
l of
    IntegerLiteral Integer
i   -> Bool -> Doc ClashAnnotation -> Doc ClashAnnotation
parensIf (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i)
    IntLiteral Integer
i       -> Bool -> Doc ClashAnnotation -> Doc ClashAnnotation
parensIf (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"#")
    Int64Literal Integer
i     -> Bool -> Doc ClashAnnotation -> Doc ClashAnnotation
parensIf (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"#64")
    WordLiteral Integer
w      -> Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
w Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"##"
    Word64Literal Integer
w    -> Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
w Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"##64"
#if MIN_VERSION_ghc(8,8,0)
    Int8Literal Integer
i      -> Bool -> Doc ClashAnnotation -> Doc ClashAnnotation
parensIf (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"#8")
    Int16Literal Integer
i     -> Bool -> Doc ClashAnnotation -> Doc ClashAnnotation
parensIf (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"#16")
    Int32Literal Integer
i     -> Bool -> Doc ClashAnnotation -> Doc ClashAnnotation
parensIf (Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"#32")
    Word8Literal Integer
w     -> Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
w Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"##8"
    Word16Literal Integer
w    -> Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
w Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"##16"
    Word32Literal Integer
w    -> Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
w Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"##32"
#endif
    FloatLiteral Word32
w     -> Float -> Doc ClashAnnotation
forall ann. Float -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Word32 -> Float
wordToFloat Word32
w) Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"#"
    DoubleLiteral Unique
w    -> Double -> Doc ClashAnnotation
forall ann. Double -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Unique -> Double
wordToDouble Unique
w) Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"##"
    CharLiteral Char
c      -> Char -> Doc ClashAnnotation
forall ann. Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
c Doc ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall a. Semigroup a => a -> a -> a
<> Doc ClashAnnotation
"#"
    StringLiteral String
s    -> [Doc ClashAnnotation] -> Doc ClashAnnotation
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ClashAnnotation] -> Doc ClashAnnotation)
-> [Doc ClashAnnotation] -> Doc ClashAnnotation
forall a b. (a -> b) -> a -> b
$ (String -> Doc ClashAnnotation)
-> [String] -> [Doc ClashAnnotation]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc ClashAnnotation
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([String] -> [Doc ClashAnnotation])
-> [String] -> [Doc ClashAnnotation]
forall a b. (a -> b) -> a -> b
$ String -> [String]
showMultiLineString String
s
    NaturalLiteral Integer
n   -> Integer -> Doc ClashAnnotation
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
n
    ByteArrayLiteral ByteArray
s -> String -> Doc ClashAnnotation
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ClashAnnotation) -> String -> Doc ClashAnnotation
forall a b. (a -> b) -> a -> b
$ ByteArray -> String
forall a. Show a => a -> String
show ByteArray
s

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

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

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

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

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

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

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

pprPrecCast :: Monad m => Rational -> Term -> Type -> Type -> m ClashDoc
pprPrecCast :: forall (m :: Type -> Type).
Monad m =>
Rational -> Term -> Type -> Type -> m (Doc ClashAnnotation)
pprPrecCast Rational
prec Term
e Type
ty1 Type
ty2 = do
  e'   <- ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext CoreContext
CastBody) (Doc ClashAnnotation -> Doc ClashAnnotation)
-> m (Doc ClashAnnotation) -> m (Doc ClashAnnotation)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m (Doc ClashAnnotation)
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m (Doc ClashAnnotation)
forall (m :: Type -> Type).
Monad m =>
Rational -> Term -> m (Doc ClashAnnotation)
pprPrec Rational
forall a. Num a => a
appPrec Term
e
  ty1' <- pprType ty1
  ty2' <- pprType ty2
  return $ tyParensIf (prec >= appPrec) $
    e' <> annotate (AnnSyntax Type)
                   (softline <> nest 2 (vsep [cast, ty1', coerce, 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 :: forall (m :: Type -> Type).
Monad m =>
Rational -> Bool -> [(Id, Term)] -> Term -> m (Doc ClashAnnotation)
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
  body' <- ClashAnnotation -> Doc ClashAnnotation -> Doc ClashAnnotation
forall ann. ann -> Doc ann -> Doc ann
annotate (CoreContext -> ClashAnnotation
AnnContext (CoreContext -> ClashAnnotation) -> CoreContext -> ClashAnnotation
forall a b. (a -> b) -> a -> b
$ [(Id, Term)] -> CoreContext
LetBody [(Id, Term)]
xes) (Doc ClashAnnotation -> Doc ClashAnnotation)
-> m (Doc ClashAnnotation) -> m (Doc ClashAnnotation)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m (Doc ClashAnnotation)
forall p (m :: Type -> Type).
(PrettyPrec p, Monad m) =>
Rational -> p -> m (Doc ClashAnnotation)
forall (m :: Type -> Type).
Monad m =>
Rational -> Term -> m (Doc ClashAnnotation)
pprPrec Rational
forall a. Num a => a
noPrec Term
body
  xes'  <- mapM (\(Id
x,Term
e) -> do
                  x' <- BindingSite -> Id -> m (Doc ClashAnnotation)
forall (m :: Type -> Type) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m (Doc ClashAnnotation)
pprBndr BindingSite
LetBind Id
x
                  e' <- pprPrec noPrec e
                  return $ annotate (AnnContext $ LetBinding x bndrs) $
                    vsepHard [x', equals <+> e']
                ) xes
  let xes'' = case [Doc ClashAnnotation]
xes' of { [] -> [Doc ClashAnnotation
"EmptyLetrec"]; [Doc ClashAnnotation]
_  -> [Doc ClashAnnotation]
xes' }
  let kw = if Bool
isRec then Doc ClashAnnotation
letrec else Doc ClashAnnotation
let_
  return $ parensIf (prec > noPrec) $
    vsepHard [hang 2 (vsepHard $ kw : xes''), in_ <+> body']

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

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

pprBndr :: (Monad m, PrettyPrec a) => BindingSite -> a -> m ClashDoc
pprBndr :: forall (m :: Type -> Type) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m (Doc ClashAnnotation)
pprBndr BindingSite
LetBind = a -> m (Doc ClashAnnotation)
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m (Doc ClashAnnotation)
pprM
pprBndr BindingSite
_       = (Doc ClashAnnotation -> Doc ClashAnnotation)
-> m (Doc ClashAnnotation) -> m (Doc ClashAnnotation)
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc ClashAnnotation -> Doc ClashAnnotation
tyParens (m (Doc ClashAnnotation) -> m (Doc ClashAnnotation))
-> (a -> m (Doc ClashAnnotation)) -> a -> m (Doc ClashAnnotation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (Doc ClashAnnotation)
forall (m :: Type -> Type) p.
(Monad m, PrettyPrec p) =>
p -> m (Doc ClashAnnotation)
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
$c== :: TypePrec -> TypePrec -> Bool
== :: TypePrec -> TypePrec -> Bool
$c/= :: TypePrec -> TypePrec -> Bool
/= :: 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
$ccompare :: TypePrec -> TypePrec -> Ordering
compare :: TypePrec -> TypePrec -> Ordering
$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
>= :: TypePrec -> TypePrec -> Bool
$cmax :: TypePrec -> TypePrec -> TypePrec
max :: TypePrec -> TypePrec -> TypePrec
$cmin :: TypePrec -> TypePrec -> TypePrec
min :: TypePrec -> TypePrec -> TypePrec
Ord)

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

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

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

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

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

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

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

pprSigmaType :: Monad m => Bool -> Type -> m ClashDoc
pprSigmaType :: forall (m :: Type -> Type).
Monad m =>
Bool -> Type -> m (Doc ClashAnnotation)
pprSigmaType Bool
showForalls Type
ty = do
    (tvs, rho)     <- [TyVar] -> Type -> m ([TyVar], Type)
forall {m :: Type -> Type}.
Monad m =>
[TyVar] -> Type -> m ([TyVar], Type)
split1 [] Type
ty
    sep <$> sequenceA [ if showForalls then pprForAll tvs else pure emptyDoc
                      , pprType 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 a. a -> m a
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 :: forall (m :: Type -> Type).
Monad m =>
[TyVar] -> m (Doc ClashAnnotation)
pprForAll []  = Doc ClashAnnotation -> m (Doc ClashAnnotation)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Doc ClashAnnotation
forall ann. Doc ann
emptyDoc
pprForAll [TyVar]
tvs = do
  tvs' <- (TyVar -> m (Doc ClashAnnotation))
-> [TyVar] -> m [Doc ClashAnnotation]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM TyVar -> m (Doc ClashAnnotation)
forall (m :: Type -> Type).
Monad m =>
TyVar -> m (Doc ClashAnnotation)
pprTvBndr [TyVar]
tvs
  return $ forall_ <+> sep tvs' <> dot

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

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

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

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

  | Bool
isSym
  , [Type
ty1, Type
ty2] <- [Type]
tys
  = do ty1' <- TypePrec -> Type -> m (Doc ClashAnnotation)
pp TypePrec
FunPrec Type
ty1
       ty2' <- pp FunPrec ty2
       tc' <- pprM tc
       return $ maybeParen p FunPrec $
         sep [ty1', enclose "`" "`" tc' <+> ty2']

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

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

isSymName :: Name a -> Bool
isSymName :: forall a. 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
$ HasCallStack => Text -> Char
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 (HasCallStack => Text -> Char
Text -> Char
T.head Text
cs)

isLexVarSym :: Text -> Bool
isLexVarSym :: Text -> Bool
isLexVarSym Text
cs = Char -> Bool
startsVarSym (HasCallStack => Text -> Char
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 a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` (String
"!#$%&*+./<=>?@\\^|~-" :: String)