{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016     , Myrtle Software Ltd
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>

  PrettyPrec printing class and instances for CoreHW
-}

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE ViewPatterns      #-}
{-# LANGUAGE LambdaCase        #-}

{-# 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.Text                        (Text)
import Control.Monad.Identity
import qualified Data.Text              as T
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Internal
import Debug.Trace                      (trace)
import GHC.Show                         (showMultiLineString)
import Numeric                          (fromRat)
import qualified Outputable             as GHC

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)
import Clash.Core.TyCon                 (TyCon (..), TyConName, isTupleTyConLike)
import Clash.Core.Type                  (ConstTy (..), Kind, LitTy (..),
                                         Type (..), TypeView (..), tyView)
import Clash.Core.Var                   (Id, TyVar, Var (..))
import Clash.Util
import Clash.Pretty

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

-- | 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
  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 -> ShowS
[SyntaxElement] -> ShowS
SyntaxElement -> String
(Int -> SyntaxElement -> ShowS)
-> (SyntaxElement -> String)
-> ([SyntaxElement] -> ShowS)
-> Show SyntaxElement
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyntaxElement] -> ShowS
$cshowList :: [SyntaxElement] -> ShowS
show :: SyntaxElement -> String
$cshow :: SyntaxElement -> String
showsPrec :: Int -> SyntaxElement -> ShowS
$cshowsPrec :: Int -> SyntaxElement -> ShowS
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' opts :: PrettyOptions
opts p :: Rational
p = (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) 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 :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
p
    where
      hide :: ClashDoc -> ClashDoc
hide = \case
        FlatAlt d :: ClashDoc
d 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 d :: ClashDoc
d 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 i :: Int
i d :: ClashDoc
d             -> Int -> ClashDoc -> ClashDoc
forall ann. Int -> Doc ann -> Doc ann
Nest Int
i (ClashDoc -> ClashDoc
hide ClashDoc
d)
        Union d :: ClashDoc
d 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 f :: 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 f :: 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 f :: 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 ann :: ClashAnnotation
ann d' :: 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
            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')
        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 :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec 0

pprM' :: (Monad m, PrettyPrec p) => PrettyOptions -> p -> m ClashDoc
pprM' :: PrettyOptions -> p -> m ClashDoc
pprM' opts :: PrettyOptions
opts = PrettyOptions -> Rational -> p -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
PrettyOptions -> Rational -> p -> m ClashDoc
pprPrec' PrettyOptions
opts 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 :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM

ppr' :: PrettyPrec p => PrettyOptions -> p -> ClashDoc
ppr' :: PrettyOptions -> p -> ClashDoc
ppr' opts :: 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 :: * -> *) 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 = 0
opPrec :: a
opPrec = 1
appPrec :: a
appPrec = 2

-- | Print a PrettyPrec thing to a String
showPpr :: PrettyPrec p => p -> String
showPpr :: p -> String
showPpr = ClashDoc -> String
forall ann. Doc ann -> String
showDoc (ClashDoc -> String) -> (p -> ClashDoc) -> p -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> ClashDoc
forall p. PrettyPrec p => p -> ClashDoc
ppr

showPpr' :: PrettyPrec p => PrettyOptions -> p -> String
showPpr' :: PrettyOptions -> p -> String
showPpr' opts :: 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
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
p a :: 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 False = ClashDoc -> ClashDoc
forall a. a -> a
id
parensIf 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 False = ClashDoc -> ClashDoc
forall a. a -> a
id
tyParensIf True  = ClashDoc -> ClashDoc
tyParens

vsepHard :: [ClashDoc] -> ClashDoc
vsepHard :: [ClashDoc] -> ClashDoc
vsepHard = (ClashDoc -> ClashDoc -> ClashDoc) -> [ClashDoc] -> ClashDoc
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (\x :: ClashDoc
x y :: 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 n :: 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 (qual :: Text
qual, occ :: Text
occ) = Text -> Text -> (Text, Text)
T.breakOnEnd "." (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 p :: Rational
p (Name a -> (Text, Text, Text)
forall a. Name a -> (Text, Text, Text)
viewName -> (qual :: Text
qual, occ :: Text
occ, uniq :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Text -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
p Text
qual
    ClashDoc
occ'  <- Rational -> Text -> m ClashDoc
forall p (m :: * -> *).
(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) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Text -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
p Text
uniq
    ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 prec :: Rational
prec = ([ClashDoc] -> ClashDoc) -> m [ClashDoc] -> m ClashDoc
forall (f :: * -> *) 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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Rational -> a -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec)

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

pprTopLevelBndr :: Monad m => (Id,Term) -> m ClashDoc
pprTopLevelBndr :: (Id, Term) -> m ClashDoc
pprTopLevelBndr (bndr :: Id
bndr,expr :: Term
expr) = do
  ClashDoc
bndr'    <- Id -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM Id
bndr
  ClashDoc
bndrName <- Name Term -> m ClashDoc
forall (m :: * -> *) 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 :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM Term
expr
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 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, letrec, in_, case_, of_, forall_
  :: ClashDoc
[dcolon :: ClashDoc
dcolon, rarrow :: ClashDoc
rarrow, lam :: ClashDoc
lam, tylam :: ClashDoc
tylam, at :: ClashDoc
at, cast :: ClashDoc
cast, coerce :: ClashDoc
coerce, letrec :: ClashDoc
letrec, in_ :: ClashDoc
in_, case_ :: ClashDoc
case_, of_ :: ClashDoc
of_, forall_ :: ClashDoc
forall_]
  = ClashAnnotation -> ClashDoc -> ClashDoc
forall ann. ann -> Doc ann -> Doc ann
annotate (SyntaxElement -> ClashAnnotation
AnnSyntax SyntaxElement
Keyword) (ClashDoc -> ClashDoc) -> [ClashDoc] -> [ClashDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ["::", "->", "λ", "Λ", "@", "▷", "~", "letrec", "in", "case", "of", "forall"]

instance PrettyPrec Text where
  pprPrec :: Rational -> Text -> m ClashDoc
pprPrec _ = ClashDoc -> m ClashDoc
forall (f :: * -> *) 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 _ t :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m ClashDoc
forall (m :: * -> *). 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 _ t :: TyCon
t = TyConName -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM (TyCon -> TyConName
tyConName TyCon
t)

instance Pretty LitTy where
  pretty :: LitTy -> Doc ann
pretty (NumTy i :: Integer
i) = Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i
  pretty (SymTy s :: 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 _ = ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 prec :: Rational
prec e :: Term
e = case Term
e of
    Var x :: Id
x           -> Rational -> Name Term -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec (Id -> Name Term
forall a. Var a -> Name a
varName Id
x)
    Data dc :: DataCon
dc         -> Rational -> DataCon -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec DataCon
dc
    Literal l :: Literal
l       -> Rational -> Literal -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Literal
l
    Prim nm :: Text
nm _       -> Rational -> Text -> m ClashDoc
forall (m :: * -> *). Monad m => Rational -> Text -> m ClashDoc
pprPrecPrim Rational
prec Text
nm
    Lam  v :: Id
v e1 :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         Rational -> [Id] -> Term -> m ClashDoc
forall (m :: * -> *).
Monad m =>
Rational -> [Id] -> Term -> m ClashDoc
pprPrecLam Rational
prec [Id
v] Term
e1
    TyLam tv :: TyVar
tv e1 :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         Rational -> [TyVar] -> Term -> m ClashDoc
forall (m :: * -> *).
Monad m =>
Rational -> [TyVar] -> Term -> m ClashDoc
pprPrecTyLam Rational
prec [TyVar
tv] Term
e1
    App fun :: Term
fun arg :: Term
arg     -> Rational -> Term -> Term -> m ClashDoc
forall (m :: * -> *).
Monad m =>
Rational -> Term -> Term -> m ClashDoc
pprPrecApp Rational
prec Term
fun Term
arg
    TyApp e' :: Term
e' ty :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         Rational -> Term -> Type -> m ClashDoc
forall (m :: * -> *).
Monad m =>
Rational -> Term -> Type -> m ClashDoc
pprPrecTyApp Rational
prec Term
e' Type
ty
    Letrec xes :: [(Id, Term)]
xes e1 :: Term
e1   -> Rational -> [(Id, Term)] -> Term -> m ClashDoc
forall (m :: * -> *).
Monad m =>
Rational -> [(Id, Term)] -> Term -> m ClashDoc
pprPrecLetrec Rational
prec [(Id, Term)]
xes Term
e1
    Case e' :: Term
e' _ alts :: [Alt]
alts  -> Rational -> Term -> [Alt] -> m ClashDoc
forall (m :: * -> *).
Monad m =>
Rational -> Term -> [Alt] -> m ClashDoc
pprPrecCase Rational
prec Term
e' [Alt]
alts
    Cast e' :: Term
e' ty1 :: Type
ty1 ty2 :: Type
ty2 -> Rational -> Term -> Type -> Type -> m ClashDoc
forall (m :: * -> *).
Monad m =>
Rational -> Term -> Type -> Type -> m ClashDoc
pprPrecCast Rational
prec Term
e' Type
ty1 Type
ty2
    Tick t :: TickInfo
t e' :: Term
e'       -> do
      ClashDoc
tDoc <- Rational -> TickInfo -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec TickInfo
t
      ClashDoc
eDoc <- Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Term
e'
      ClashDoc -> m ClashDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (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 prec :: Rational
prec (SrcSpan sp :: SrcSpan
sp)   = Rational -> SrcSpan -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec SrcSpan
sp
  pprPrec prec :: Rational
prec (NameMod PrefixName t :: Type
t) = ("<prefixName>" ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<>) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Type -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Type
t
  pprPrec prec :: Rational
prec (NameMod SuffixName t :: Type
t) = ("<suffixName>" ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<>) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Type -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Type
t
  pprPrec prec :: Rational
prec (NameMod SetName t :: Type
t)    = ("<setName>" ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
<>) (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Type -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Type
t

instance PrettyPrec SrcSpan where
  pprPrec :: Rational -> SrcSpan -> m ClashDoc
pprPrec _ sp :: SrcSpan
sp = ClashDoc -> m ClashDoc
forall (m :: * -> *) a. Monad m => a -> m a
return ("<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 _ v :: Var a
v@(TyVar {}) = Name a -> m ClashDoc
forall (m :: * -> *) 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 _ v :: Var a
v@(Id {})    = do
    ClashDoc
v'  <- Name a -> m ClashDoc
forall (m :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 _ = DcName -> m ClashDoc
forall (m :: * -> *) 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 _ l :: Literal
l = ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 i :: Integer
i
      | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 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 i :: Integer
i
      | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 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
    Int64Literal i :: Integer
i
      | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 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
    WordLiteral w :: Integer
w      -> Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
w
    Word64Literal w :: Integer
w    -> Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
w
    FloatLiteral r :: Rational
r     -> Float -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty (Rational -> Float
forall a. RealFloat a => Rational -> a
fromRat Rational
r :: Float)
    DoubleLiteral r :: Rational
r    -> Double -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty (Rational -> Double
forall a. RealFloat a => Rational -> a
fromRat Rational
r :: Double)
    CharLiteral c :: Char
c      -> Char -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
c
    StringLiteral s :: 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 n :: Integer
n   -> Integer -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
n
    ByteArrayLiteral s :: Vector Word8
s -> String -> ClashDoc
forall a ann. Pretty a => a -> Doc ann
pretty (String -> ClashDoc) -> String -> ClashDoc
forall a b. (a -> b) -> a -> b
$ Vector Word8 -> String
forall a. Show a => a -> String
show Vector Word8
s

instance PrettyPrec Pat where
  pprPrec :: Rational -> Pat -> m ClashDoc
pprPrec prec :: Rational
prec pat :: Pat
pat = case Pat
pat of
    DataPat dc :: DataCon
dc txs :: [TyVar]
txs xs :: [Id]
xs -> do
      ClashDoc
dc'  <- DataCon -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM DataCon
dc
      [ClashDoc]
txs' <- (TyVar -> m ClashDoc) -> [TyVar] -> m [ClashDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BindingSite -> TyVar -> m ClashDoc
forall (m :: * -> *) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m ClashDoc
pprBndr BindingSite
LetBind) [TyVar]
txs
      [ClashDoc]
xs'  <- (Id -> m ClashDoc) -> [Id] -> m [ClashDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BindingSite -> Id -> m ClashDoc
forall (m :: * -> *) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m ClashDoc
pprBndr BindingSite
CaseBind) [Id]
xs
      ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 2 ([ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
sep [ClashDoc]
xs') ]
    LitPat l :: Literal
l   -> Literal -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM Literal
l
    DefaultPat -> ClashDoc -> m ClashDoc
forall (m :: * -> *) a. Monad m => a -> m a
return "_"

pprPrecPrim :: Monad m => Rational -> Text -> m ClashDoc
pprPrecPrim :: Rational -> Text -> m ClashDoc
pprPrecPrim prec :: Rational
prec nm :: Text
nm =
  ClashDoc -> ClashDoc -> ClashDoc
forall a. Semigroup a => a -> a -> a
(<>) (ClashDoc -> ClashDoc -> ClashDoc)
-> m ClashDoc -> m (ClashDoc -> ClashDoc)
forall (f :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Text -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Text
qual)
       m (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Rational -> Text -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Text
occ
  where (qual :: Text
qual, occ :: Text
occ) = Text -> Text -> (Text, Text)
T.breakOnEnd "." Text
nm

pprPrecLam :: Monad m => Rational -> [Id] -> Term -> m ClashDoc
pprPrecLam :: Rational -> [Id] -> Term -> m ClashDoc
pprPrecLam prec :: Rational
prec xs :: [Id]
xs e :: Term
e = do
  [ClashDoc]
xs' <- (Id -> m ClashDoc) -> [Id] -> m [ClashDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BindingSite -> Id -> m ClashDoc
forall (m :: * -> *) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m ClashDoc
pprBndr BindingSite
LambdaBind) [Id]
xs
  ClashDoc
e'  <- Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Term
e
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 prec :: Rational
prec tvs :: [TyVar]
tvs e :: Term
e = do
  [ClashDoc]
tvs' <- (TyVar -> m ClashDoc) -> [TyVar] -> m [ClashDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM [TyVar]
tvs
  ClashDoc
e'   <- Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Term
e
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 prec :: Rational
prec e1 :: Term
e1 e2 :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
appPrec Term
e2
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 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 prec :: Rational
prec e :: Term
e ty :: Type
ty = do
  ClashDoc
e'  <- Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(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 :: * -> *). Monad m => Type -> m ClashDoc
pprParendType Type
ty
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 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 prec :: Rational
prec e :: Term
e ty1 :: Type
ty1 ty2 :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(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 :: * -> *). Monad m => Type -> m ClashDoc
pprType Type
ty1
  ClashDoc
ty2' <- Type -> m ClashDoc
forall (m :: * -> *). Monad m => Type -> m ClashDoc
pprType Type
ty2
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 2 ([ClashDoc] -> ClashDoc
forall ann. [Doc ann] -> Doc ann
vsep [ClashDoc
cast, ClashDoc
ty1', ClashDoc
coerce, ClashDoc
ty2']))

pprPrecLetrec :: Monad m => Rational -> [(Id, Term)] -> Term -> m ClashDoc
pprPrecLetrec :: Rational -> [(Id, Term)] -> Term -> m ClashDoc
pprPrecLetrec prec :: Rational
prec xes :: [(Id, Term)]
xes body :: 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 :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(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 :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(x :: Id
x,e :: Term
e) -> do
                  ClashDoc
x' <- BindingSite -> Id -> m ClashDoc
forall (m :: * -> *) a.
(Monad m, PrettyPrec a) =>
BindingSite -> a -> m ClashDoc
pprBndr BindingSite
LetBind Id
x
                  ClashDoc
e' <- Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Term
e
                  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 { [] -> ["EmptyLetrec"]; _  -> [ClashDoc]
xes' }
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 2 ([ClashDoc] -> ClashDoc
vsepHard ([ClashDoc] -> ClashDoc) -> [ClashDoc] -> ClashDoc
forall a b. (a -> b) -> a -> b
$ ClashDoc
letrec 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 prec :: Rational
prec e :: Term
e alts :: [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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Rational -> Term -> m ClashDoc
forall p (m :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
prec Term
e
  [ClashDoc]
alts' <- (Alt -> m ClashDoc) -> [Alt] -> m [ClashDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Rational -> Alt -> m ClashDoc
forall (m :: * -> *). Monad m => Rational -> Alt -> m ClashDoc
pprPrecAlt Rational
forall a. Num a => a
noPrec) [Alt]
alts
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 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 _ (altPat :: Pat
altPat, altE :: Term
altE) = do
  ClashDoc
altPat' <- Rational -> Pat -> m ClashDoc
forall p (m :: * -> *).
(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 :: * -> *).
(PrettyPrec p, Monad m) =>
Rational -> p -> m ClashDoc
pprPrec Rational
forall a. Num a => a
noPrec Term
altE
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 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 LetBind = a -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM
pprBndr _       = (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) 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 :: * -> *) 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 ctxt_prec :: TypePrec
ctxt_prec inner_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 :: * -> *). 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 :: * -> *). 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 _ (VarTy tv :: TyVar
tv)                   = TyVar -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM TyVar
tv
ppr_type _ (LitTy tyLit :: LitTy
tyLit)                = LitTy -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM LitTy
tyLit
ppr_type p :: TypePrec
p ty :: Type
ty@(ForAllTy {})             = TypePrec -> Type -> m ClashDoc
forall (m :: * -> *). Monad m => TypePrec -> Type -> m ClashDoc
pprForAllType TypePrec
p Type
ty
ppr_type p :: TypePrec
p (ConstTy (TyCon tc :: TyConName
tc))         = TypePrec
-> (TypePrec -> Type -> m ClashDoc)
-> TyConName
-> [Type]
-> m ClashDoc
forall (m :: * -> *).
Monad m =>
TypePrec
-> (TypePrec -> Type -> m ClashDoc)
-> TyConName
-> [Type]
-> m ClashDoc
pprTcApp TypePrec
p TypePrec -> Type -> m ClashDoc
forall (m :: * -> *). Monad m => TypePrec -> Type -> m ClashDoc
ppr_type TyConName
tc []
ppr_type p :: TypePrec
p (AnnType _ann :: [Attr']
_ann typ :: Type
typ)           = TypePrec -> Type -> m ClashDoc
forall (m :: * -> *). Monad m => TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
p Type
typ
ppr_type p :: TypePrec
p (Type -> TypeView
tyView -> TyConApp tc :: TyConName
tc args :: [Type]
args) = TypePrec
-> (TypePrec -> Type -> m ClashDoc)
-> TyConName
-> [Type]
-> m ClashDoc
forall (m :: * -> *).
Monad m =>
TypePrec
-> (TypePrec -> Type -> m ClashDoc)
-> TyConName
-> [Type]
-> m ClashDoc
pprTcApp TypePrec
p TypePrec -> Type -> m ClashDoc
forall (m :: * -> *). Monad m => TypePrec -> Type -> m ClashDoc
ppr_type TyConName
tc [Type]
args
ppr_type p :: TypePrec
p (Type -> TypeView
tyView -> FunTy ty1 :: Type
ty1 ty2 :: Type
ty2)
  = [ClashDoc] -> ClashDoc
pprArrowChain ([ClashDoc] -> ClashDoc) -> m [ClashDoc] -> m ClashDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypePrec -> Type -> m ClashDoc
forall (m :: * -> *). Monad m => TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
FunPrec Type
ty1 m ClashDoc -> m [ClashDoc] -> m [ClashDoc]
forall (f :: * -> *) a. Applicative f => f a -> f [a] -> f [a]
<:> Type -> m [ClashDoc]
forall (f :: * -> *). Monad f => Type -> f [ClashDoc]
pprFunTail Type
ty2
  where
    pprFunTail :: Type -> f [ClashDoc]
pprFunTail (Type -> TypeView
tyView -> FunTy ty1' :: Type
ty1' ty2' :: Type
ty2')
      = TypePrec -> Type -> f ClashDoc
forall (m :: * -> *). Monad m => TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
FunPrec Type
ty1' f ClashDoc -> f [ClashDoc] -> f [ClashDoc]
forall (f :: * -> *) a. Applicative f => f a -> f [a] -> f [a]
<:> Type -> f [ClashDoc]
pprFunTail Type
ty2'
    pprFunTail otherTy :: Type
otherTy
      = TypePrec -> Type -> f ClashDoc
forall (m :: * -> *). Monad m => TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
TopPrec Type
otherTy f ClashDoc -> f [ClashDoc] -> f [ClashDoc]
forall (f :: * -> *) a. Applicative f => f a -> f [a] -> f [a]
<:> [ClashDoc] -> f [ClashDoc]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

    pprArrowChain :: [ClashDoc] -> ClashDoc
pprArrowChain []
      = ClashDoc
forall ann. Doc ann
emptyDoc
    pprArrowChain (arg :: ClashDoc
arg:args :: [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 p :: TypePrec
p (AppTy ty1 :: Type
ty1 ty2 :: Type
ty2) = TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen TypePrec
p TypePrec
TyConPrec (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m ClashDoc
forall (m :: * -> *). Monad m => Type -> m ClashDoc
pprType Type
ty1
                                                               m (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypePrec -> Type -> m ClashDoc
forall (m :: * -> *). Monad m => TypePrec -> Type -> m ClashDoc
ppr_type TypePrec
TyConPrec Type
ty2)
ppr_type _ (ConstTy Arrow) = ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 p :: TypePrec
p ty :: Type
ty = TypePrec -> TypePrec -> ClashDoc -> ClashDoc
maybeParen TypePrec
p TypePrec
FunPrec (ClashDoc -> ClashDoc) -> m ClashDoc -> m ClashDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Type -> m ClashDoc
forall (m :: * -> *). Monad m => Bool -> Type -> m ClashDoc
pprSigmaType Bool
True Type
ty

pprSigmaType :: Monad m => Bool -> Type -> m ClashDoc
pprSigmaType :: Bool -> Type -> m ClashDoc
pprSigmaType showForalls :: Bool
showForalls ty :: Type
ty = do
    (tvs :: [TyVar]
tvs, rho :: Type
rho)     <- [TyVar] -> Type -> m ([TyVar], Type)
forall (m :: * -> *).
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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m ClashDoc] -> m [ClashDoc]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [ if Bool
showForalls then [TyVar] -> m ClashDoc
forall (m :: * -> *). Monad m => [TyVar] -> m ClashDoc
pprForAll [TyVar]
tvs else ClashDoc -> m ClashDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClashDoc
forall ann. Doc ann
emptyDoc
                      , Type -> m ClashDoc
forall (m :: * -> *). Monad m => Type -> m ClashDoc
pprType Type
rho
                      ]
  where
    split1 :: [TyVar] -> Type -> m ([TyVar], Type)
split1 tvs :: [TyVar]
tvs (ForAllTy tv :: TyVar
tv resTy :: Type
resTy) = [TyVar] -> Type -> m ([TyVar], Type)
split1 (TyVar
tvTyVar -> [TyVar] -> [TyVar]
forall a. a -> [a] -> [a]
:[TyVar]
tvs) Type
resTy
    split1 tvs :: [TyVar]
tvs resTy :: Type
resTy               = ([TyVar], Type) -> m ([TyVar], Type)
forall (m :: * -> *) 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 :: * -> *) a. Monad m => a -> m a
return ClashDoc
forall ann. Doc ann
emptyDoc
pprForAll tvs :: [TyVar]
tvs = do
  [ClashDoc]
tvs' <- (TyVar -> m ClashDoc) -> [TyVar] -> m [ClashDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyVar -> m ClashDoc
forall (m :: * -> *). Monad m => TyVar -> m ClashDoc
pprTvBndr [TyVar]
tvs
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 tv :: TyVar
tv = do
  ClashDoc
tv'   <- TyVar -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM TyVar
tv
  ClashDoc
kind' <- Type -> m ClashDoc
forall (m :: * -> *). Monad m => Type -> m ClashDoc
pprKind (TyVar -> Type
forall a. Var a -> Type
varType TyVar
tv)
  ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 :: * -> *). 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 p :: TypePrec
p pp :: TypePrec -> Type -> m ClashDoc
pp tc :: TyConName
tc tys :: [Type]
tys
  | [Type] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
tys
  = TyConName -> m ClashDoc
forall (m :: * -> *) 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 :: * -> *) (m :: * -> *) 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 :: * -> *) 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
  , [ty1 :: Type
ty1, ty2 :: 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 :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM TyConName
tc
       ClashDoc -> m ClashDoc
forall (m :: * -> *) 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
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 :: * -> *) (m :: * -> *) 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyConName -> m ClashDoc
forall (m :: * -> *) p. (Monad m, PrettyPrec p) => p -> m ClashDoc
pprM TyConName
tc
       ClashDoc -> m ClashDoc
forall (m :: * -> *) 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 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 n :: Name a
n = Text -> Bool
go (Name a -> Text
forall a. Name a -> Text
nameOcc Name a
n)
  where
    go :: Text -> Bool
go s :: 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 cs :: Text
cs = Text -> Bool
isLexConSym Text
cs Bool -> Bool -> Bool
|| Text -> Bool
isLexVarSym Text
cs

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

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

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

startsVarSym :: Char -> Bool
startsVarSym :: Char -> Bool
startsVarSym c :: 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
> 0x7f Bool -> Bool -> Bool
&& Char -> Bool
isSymbol Char
c)

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