module GHC.HsToCore.Pmc.Ppr (
pprUncovered
) where
import GHC.Prelude
import GHC.Data.List.Infinite (Infinite (..))
import qualified GHC.Data.List.Infinite as Inf
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Var.Env
import GHC.Types.Unique.DFM
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Builtin.Types
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad.Trans.RWS.CPS
import GHC.Data.Maybe
import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
import GHC.HsToCore.Pmc.Types
pprUncovered :: Nabla -> [Id] -> SDoc
pprUncovered :: Nabla -> [Id] -> SDoc
pprUncovered Nabla
nabla [Id]
vas
| UniqDFM Id (SDoc, [PmAltCon]) -> Bool
forall key elt. UniqDFM key elt -> Bool
isNullUDFM UniqDFM Id (SDoc, [PmAltCon])
refuts = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [SDoc]
vec
| Bool
otherwise = SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep [SDoc]
vec) Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"where" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((Unique, (SDoc, [PmAltCon])) -> SDoc)
-> [(Unique, (SDoc, [PmAltCon]))] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((SDoc, [PmAltCon]) -> SDoc
pprRefutableShapes ((SDoc, [PmAltCon]) -> SDoc)
-> ((Unique, (SDoc, [PmAltCon])) -> (SDoc, [PmAltCon]))
-> (Unique, (SDoc, [PmAltCon]))
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unique, (SDoc, [PmAltCon])) -> (SDoc, [PmAltCon])
forall a b. (a, b) -> b
snd) (UniqDFM Id (SDoc, [PmAltCon]) -> [(Unique, (SDoc, [PmAltCon]))]
forall key elt. UniqDFM key elt -> [(Unique, elt)]
udfmToList UniqDFM Id (SDoc, [PmAltCon])
refuts))
where
init_prec :: PprPrec
init_prec
| [Id
_] <- [Id]
vas = PprPrec
topPrec
| Bool
otherwise = PprPrec
appPrec
ppr_action :: RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
ppr_action = (Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc)
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PprPrec
-> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmVar PprPrec
init_prec) [Id]
vas
([SDoc]
vec, DIdEnv (Id, SDoc)
renamings) = Nabla
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
-> ([SDoc], DIdEnv (Id, SDoc))
forall a. Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))
runPmPpr Nabla
nabla RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
ppr_action
refuts :: UniqDFM Id (SDoc, [PmAltCon])
refuts = Nabla -> DIdEnv (Id, SDoc) -> UniqDFM Id (SDoc, [PmAltCon])
prettifyRefuts Nabla
nabla DIdEnv (Id, SDoc)
renamings
pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc
pprRefutableShapes :: (SDoc, [PmAltCon]) -> SDoc
pprRefutableShapes (SDoc
var, [PmAltCon]
alts)
= SDoc
var SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is not one of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [PmAltCon] -> SDoc
format_alts [PmAltCon]
alts
where
format_alts :: [PmAltCon] -> SDoc
format_alts = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SDoc -> SDoc) -> ([PmAltCon] -> SDoc) -> [PmAltCon] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep ([SDoc] -> SDoc) -> ([PmAltCon] -> [SDoc]) -> [PmAltCon] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> [SDoc])
-> ([PmAltCon] -> [SDoc]) -> [PmAltCon] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
forall {a}. IsLine a => [a] -> [a]
shorten ([SDoc] -> [SDoc])
-> ([PmAltCon] -> [SDoc]) -> [PmAltCon] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PmAltCon -> SDoc) -> [PmAltCon] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map PmAltCon -> SDoc
ppr_alt
shorten :: [a] -> [a]
shorten (a
a:a
b:a
c:a
_:[a]
_) = a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:a
ca -> [a] -> [a]
forall a. a -> [a] -> [a]
:[String -> a
forall doc. IsLine doc => String -> doc
text String
"..."]
shorten [a]
xs = [a]
xs
ppr_alt :: PmAltCon -> SDoc
ppr_alt (PmAltConLike ConLike
cl) = ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl
ppr_alt (PmAltLit PmLit
lit) = PmLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmLit
lit
prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (SDoc, [PmAltCon])
prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> UniqDFM Id (SDoc, [PmAltCon])
prettifyRefuts Nabla
nabla = [(Unique, (SDoc, [PmAltCon]))] -> UniqDFM Id (SDoc, [PmAltCon])
forall elt key. [(Unique, elt)] -> UniqDFM key elt
listToUDFM_Directly ([(Unique, (SDoc, [PmAltCon]))] -> UniqDFM Id (SDoc, [PmAltCon]))
-> (DIdEnv (Id, SDoc) -> [(Unique, (SDoc, [PmAltCon]))])
-> DIdEnv (Id, SDoc)
-> UniqDFM Id (SDoc, [PmAltCon])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Unique, (Id, SDoc)) -> (Unique, (SDoc, [PmAltCon])))
-> [(Unique, (Id, SDoc))] -> [(Unique, (SDoc, [PmAltCon]))]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, (Id, SDoc)) -> (Unique, (SDoc, [PmAltCon]))
attach_refuts ([(Unique, (Id, SDoc))] -> [(Unique, (SDoc, [PmAltCon]))])
-> (DIdEnv (Id, SDoc) -> [(Unique, (Id, SDoc))])
-> DIdEnv (Id, SDoc)
-> [(Unique, (SDoc, [PmAltCon]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DIdEnv (Id, SDoc) -> [(Unique, (Id, SDoc))]
forall key elt. UniqDFM key elt -> [(Unique, elt)]
udfmToList
where
attach_refuts :: (Unique, (Id, SDoc)) -> (Unique, (SDoc, [PmAltCon]))
attach_refuts (Unique
u, (Id
x, SDoc
sdoc)) = (Unique
u, (SDoc
sdoc, Nabla -> Id -> [PmAltCon]
lookupRefuts Nabla
nabla Id
x))
type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) a
nameList :: Infinite SDoc
nameList :: Infinite SDoc
nameList = (String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
forall doc. IsLine doc => String -> doc
text [String
"p",String
"q",String
"r",String
"s",String
"t"] [SDoc] -> Infinite SDoc -> Infinite SDoc
forall (f :: * -> *) a.
Foldable f =>
f a -> Infinite a -> Infinite a
Inf.++ ((Int -> (SDoc, Int)) -> Int -> Infinite SDoc)
-> Int -> (Int -> (SDoc, Int)) -> Infinite SDoc
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> (SDoc, Int)) -> Int -> Infinite SDoc
forall b a. (b -> (a, b)) -> b -> Infinite a
Inf.unfoldr (Int
0 :: Int) (\ Int
u -> (String -> SDoc
forall doc. IsLine doc => String -> doc
text (Char
't'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
u), Int
uInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))
runPmPpr :: forall a. Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))
runPmPpr Nabla
nabla PmPprM a
m = case PmPprM a
-> Nabla
-> (DIdEnv (Id, SDoc), Infinite SDoc)
-> (a, (DIdEnv (Id, SDoc), Infinite SDoc), ())
forall w r s a. Monoid w => RWS r w s a -> r -> s -> (a, s, w)
runRWS PmPprM a
m Nabla
nabla (DIdEnv (Id, SDoc)
forall a. DVarEnv a
emptyDVarEnv, Infinite SDoc
nameList) of
(a
a, (DIdEnv (Id, SDoc)
renamings, Infinite SDoc
_), ()
_) -> (a
a, DIdEnv (Id, SDoc)
renamings)
getCleanName :: Id -> PmPprM SDoc
getCleanName :: Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
getCleanName Id
x = do
(DIdEnv (Id, SDoc)
renamings, Infinite SDoc
name_supply) <- RWST
Nabla
()
(DIdEnv (Id, SDoc), Infinite SDoc)
Identity
(DIdEnv (Id, SDoc), Infinite SDoc)
forall (m :: * -> *) r w s. Monad m => RWST r w s m s
get
let Inf SDoc
clean_name Infinite SDoc
name_supply' = Infinite SDoc
name_supply
case DIdEnv (Id, SDoc) -> Id -> Maybe (Id, SDoc)
forall a. DVarEnv a -> Id -> Maybe a
lookupDVarEnv DIdEnv (Id, SDoc)
renamings Id
x of
Just (Id
_, SDoc
nm) -> SDoc
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall a.
a -> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
nm
Maybe (Id, SDoc)
Nothing -> do
(DIdEnv (Id, SDoc), Infinite SDoc)
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity ()
forall (m :: * -> *) s r w. Monad m => s -> RWST r w s m ()
put (DIdEnv (Id, SDoc) -> Id -> (Id, SDoc) -> DIdEnv (Id, SDoc)
forall a. DVarEnv a -> Id -> a -> DVarEnv a
extendDVarEnv DIdEnv (Id, SDoc)
renamings Id
x (Id
x, SDoc
clean_name), Infinite SDoc
name_supply')
SDoc
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall a.
a -> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
clean_name
checkRefuts :: Id -> PmPprM (Maybe SDoc)
checkRefuts :: Id -> PmPprM (Maybe SDoc)
checkRefuts Id
x = do
Nabla
nabla <- RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity Nabla
forall (m :: * -> *) r w s. Monad m => RWST r w s m r
ask
case Nabla -> Id -> [PmAltCon]
lookupRefuts Nabla
nabla Id
x of
[] -> Maybe SDoc -> PmPprM (Maybe SDoc)
forall a.
a -> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SDoc
forall a. Maybe a
Nothing
[PmAltCon]
_ -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc)
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
-> PmPprM (Maybe SDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
getCleanName Id
x
pprPmVar :: PprPrec -> Id -> PmPprM SDoc
pprPmVar :: PprPrec
-> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmVar PprPrec
prec Id
x = do
Nabla
nabla <- RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity Nabla
forall (m :: * -> *) r w s. Monad m => RWST r w s m r
ask
case Nabla -> Id -> Maybe PmAltConApp
lookupSolution Nabla
nabla Id
x of
Just (PACA PmAltCon
alt [Id]
_tvs [Id]
args) -> PprPrec
-> PmAltCon
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmAltCon PprPrec
prec PmAltCon
alt [Id]
args
Maybe PmAltConApp
Nothing -> SDoc -> Maybe SDoc -> SDoc
forall a. a -> Maybe a -> a
fromMaybe SDoc
forall doc. IsLine doc => doc
underscore (Maybe SDoc -> SDoc)
-> PmPprM (Maybe SDoc)
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> PmPprM (Maybe SDoc)
checkRefuts Id
x
pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc
pprPmAltCon :: PprPrec
-> PmAltCon
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmAltCon PprPrec
_prec (PmAltLit PmLit
l) [Id]
_ = SDoc
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall a.
a -> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PmLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmLit
l)
pprPmAltCon PprPrec
prec (PmAltConLike ConLike
cl) [Id]
args = do
Nabla
nabla <- RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity Nabla
forall (m :: * -> *) r w s. Monad m => RWST r w s m r
ask
Nabla
-> PprPrec
-> ConLike
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprConLike Nabla
nabla PprPrec
prec ConLike
cl [Id]
args
pprConLike :: Nabla -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc
pprConLike :: Nabla
-> PprPrec
-> ConLike
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprConLike Nabla
nabla PprPrec
_prec ConLike
cl [Id]
args
| Just PmExprList
pm_expr_list <- Nabla -> PmAltCon -> [Id] -> Maybe PmExprList
pmExprAsList Nabla
nabla (ConLike -> PmAltCon
PmAltConLike ConLike
cl) [Id]
args
= case PmExprList
pm_expr_list of
NilTerminated [Id]
list ->
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> SDoc)
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc)
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PprPrec
-> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmVar PprPrec
appPrec) [Id]
list
WcVarTerminated NonEmpty Id
pref Id
x ->
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
colon ([SDoc] -> SDoc)
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc)
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PprPrec
-> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmVar PprPrec
appPrec) (NonEmpty Id -> [Id]
forall a. NonEmpty a -> [a]
toList NonEmpty Id
pref [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
x])
pprConLike Nabla
_nabla PprPrec
_prec (RealDataCon DataCon
con) [Id]
args
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
, let hash_parens :: doc -> doc
hash_parens doc
doc = String -> doc
forall doc. IsLine doc => String -> doc
text String
"(#" doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<+> doc
doc doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> doc
forall doc. IsLine doc => String -> doc
text String
"#)"
= SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
hash_parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> SDoc)
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc)
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PprPrec
-> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmVar PprPrec
appPrec) [Id]
args
| DataCon -> Bool
isTupleDataCon DataCon
con
= SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> SDoc)
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc)
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PprPrec
-> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmVar PprPrec
appPrec) [Id]
args
pprConLike Nabla
_nabla PprPrec
prec ConLike
cl [Id]
args
| ConLike -> Bool
conLikeIsInfix ConLike
cl = case [Id]
args of
[Id
x, Id
y] -> do SDoc
x' <- PprPrec
-> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmVar PprPrec
funPrec Id
x
SDoc
y' <- PprPrec
-> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmVar PprPrec
funPrec Id
y
SDoc
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall a.
a -> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SDoc -> SDoc
cparen (PprPrec
prec PprPrec -> PprPrec -> Bool
forall a. Ord a => a -> a -> Bool
> PprPrec
opPrec) (SDoc
x' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
y'))
[Id]
list -> String
-> SDoc
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pprConLike:" ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
list)
| [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args = SDoc
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall a.
a -> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl)
| Bool
otherwise = do [SDoc]
args' <- (Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc)
-> [Id]
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (PprPrec
-> Id
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
pprPmVar PprPrec
appPrec) [Id]
args
SDoc
-> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity SDoc
forall a.
a -> RWST Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SDoc -> SDoc
cparen (PprPrec
prec PprPrec -> PprPrec -> Bool
forall a. Ord a => a -> a -> Bool
> PprPrec
funPrec) ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [SDoc]
args')))
data PmExprList
= NilTerminated [Id]
| WcVarTerminated (NonEmpty Id) Id
pmExprAsList :: Nabla -> PmAltCon -> [Id] -> Maybe PmExprList
pmExprAsList :: Nabla -> PmAltCon -> [Id] -> Maybe PmExprList
pmExprAsList Nabla
nabla = [Id] -> PmAltCon -> [Id] -> Maybe PmExprList
go_con []
where
go_var :: [Id] -> Id -> Maybe PmExprList
go_var [Id]
rev_pref Id
x
| Just (PACA PmAltCon
alt [Id]
_tvs [Id]
args) <- Nabla -> Id -> Maybe PmAltConApp
lookupSolution Nabla
nabla Id
x
= [Id] -> PmAltCon -> [Id] -> Maybe PmExprList
go_con [Id]
rev_pref PmAltCon
alt [Id]
args
go_var [Id]
rev_pref Id
x
| Just NonEmpty Id
pref <- [Id] -> Maybe (NonEmpty Id)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
rev_pref)
= PmExprList -> Maybe PmExprList
forall a. a -> Maybe a
Just (NonEmpty Id -> Id -> PmExprList
WcVarTerminated NonEmpty Id
pref Id
x)
go_var [Id]
_ Id
_
= Maybe PmExprList
forall a. Maybe a
Nothing
go_con :: [Id] -> PmAltCon -> [Id] -> Maybe PmExprList
go_con [Id]
rev_pref (PmAltConLike (RealDataCon DataCon
c)) [Id]
es
| DataCon
c DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
nilDataCon
= Bool -> Maybe PmExprList -> Maybe PmExprList
forall a. HasCallStack => Bool -> a -> a
assert ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
es) (Maybe PmExprList -> Maybe PmExprList)
-> Maybe PmExprList -> Maybe PmExprList
forall a b. (a -> b) -> a -> b
$ PmExprList -> Maybe PmExprList
forall a. a -> Maybe a
Just ([Id] -> PmExprList
NilTerminated ([Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
rev_pref))
| DataCon
c DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon
= Bool -> Maybe PmExprList -> Maybe PmExprList
forall a. HasCallStack => Bool -> a -> a
assert ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
es Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2) (Maybe PmExprList -> Maybe PmExprList)
-> Maybe PmExprList -> Maybe PmExprList
forall a b. (a -> b) -> a -> b
$ [Id] -> Id -> Maybe PmExprList
go_var ([Id]
es [Id] -> Int -> Id
forall a. HasCallStack => [a] -> Int -> a
!! Int
0 Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
rev_pref) ([Id]
es [Id] -> Int -> Id
forall a. HasCallStack => [a] -> Int -> a
!! Int
1)
go_con [Id]
_ PmAltCon
_ [Id]
_
= Maybe PmExprList
forall a. Maybe a
Nothing