{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Pmc.Ppr (
pprUncovered
) where
#include "HsVersions.h"
import GHC.Prelude
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 Control.Monad.Trans.RWS.CPS
import GHC.Utils.Misc
import GHC.Data.Maybe
import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
import GHC.HsToCore.Pmc.Types
import GHC.HsToCore.Pmc.Solver
pprUncovered :: Nabla -> [Id] -> SDoc
pprUncovered :: Nabla -> [Id] -> SDoc
pprUncovered Nabla
nabla [Id]
vas
| forall key elt. UniqDFM key elt -> Bool
isNullUDFM DIdEnv (SDoc, [PmAltCon])
refuts = [SDoc] -> SDoc
fsep [SDoc]
vec
| Bool
otherwise = SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
fsep [SDoc]
vec) Int
4 forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"where" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map ((SDoc, [PmAltCon]) -> SDoc
pprRefutableShapes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall key elt. UniqDFM key elt -> [(Unique, elt)]
udfmToList DIdEnv (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), [SDoc]) Identity [SDoc]
ppr_action = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> PmPprM SDoc
pprPmVar PprPrec
init_prec) [Id]
vas
([SDoc]
vec, DIdEnv (Id, SDoc)
renamings) = forall a. Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))
runPmPpr Nabla
nabla RWST Nabla () (DIdEnv (Id, SDoc), [SDoc]) Identity [SDoc]
ppr_action
refuts :: DIdEnv (SDoc, [PmAltCon])
refuts = Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (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
<+> String -> SDoc
text String
"is not one of" SDoc -> SDoc -> SDoc
<+> [PmAltCon] -> SDoc
format_alts [PmAltCon]
alts
where
format_alts :: [PmAltCon] -> SDoc
format_alts = SDoc -> SDoc
braces forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
shorten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map PmAltCon -> SDoc
ppr_alt
shorten :: [SDoc] -> [SDoc]
shorten (SDoc
a:SDoc
b:SDoc
c:SDoc
_:[SDoc]
_) = SDoc
aforall a. a -> [a] -> [a]
:SDoc
bforall a. a -> [a] -> [a]
:SDoc
cforall a. a -> [a] -> [a]
:[String -> SDoc
text String
"..."]
shorten [SDoc]
xs = [SDoc]
xs
ppr_alt :: PmAltCon -> SDoc
ppr_alt (PmAltConLike ConLike
cl) = forall a. Outputable a => a -> SDoc
ppr ConLike
cl
ppr_alt (PmAltLit PmLit
lit) = forall a. Outputable a => a -> SDoc
ppr PmLit
lit
prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (SDoc, [PmAltCon])
prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (SDoc, [PmAltCon])
prettifyRefuts Nabla
nabla = forall elt key. [(Unique, elt)] -> UniqDFM key elt
listToUDFM_Directly forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Unique, (Id, SDoc)) -> (Unique, (SDoc, [PmAltCon]))
attach_refuts forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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), [SDoc]) a
nameList :: [SDoc]
nameList :: [SDoc]
nameList = forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text [String
"p",String
"q",String
"r",String
"s",String
"t"] forall a. [a] -> [a] -> [a]
++
[ String -> SDoc
text (Char
't'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show Int
u) | Int
u <- [(Int
0 :: Int)..] ]
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 forall w r s a. Monoid w => RWS r w s a -> r -> s -> (a, s, w)
runRWS PmPprM a
m Nabla
nabla (forall a. DVarEnv a
emptyDVarEnv, [SDoc]
nameList) of
(a
a, (DIdEnv (Id, SDoc)
renamings, [SDoc]
_), ()
_) -> (a
a, DIdEnv (Id, SDoc)
renamings)
getCleanName :: Id -> PmPprM SDoc
getCleanName :: Id -> PmPprM SDoc
getCleanName Id
x = do
(DIdEnv (Id, SDoc)
renamings, [SDoc]
name_supply) <- forall (m :: * -> *) r w s. Monad m => RWST r w s m s
get
let (SDoc
clean_name:[SDoc]
name_supply') = [SDoc]
name_supply
case forall a. DVarEnv a -> Id -> Maybe a
lookupDVarEnv DIdEnv (Id, SDoc)
renamings Id
x of
Just (Id
_, SDoc
nm) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
nm
Maybe (Id, SDoc)
Nothing -> do
forall (m :: * -> *) s r w. Monad m => s -> RWST r w s m ()
put (forall a. DVarEnv a -> Id -> a -> DVarEnv a
extendDVarEnv DIdEnv (Id, SDoc)
renamings Id
x (Id
x, SDoc
clean_name), [SDoc]
name_supply')
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 <- forall (m :: * -> *) r w s. Monad m => RWST r w s m r
ask
case Nabla -> Id -> [PmAltCon]
lookupRefuts Nabla
nabla Id
x of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
[PmAltCon]
_ -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> PmPprM SDoc
getCleanName Id
x
pprPmVar :: PprPrec -> Id -> PmPprM SDoc
pprPmVar :: PprPrec -> Id -> PmPprM SDoc
pprPmVar PprPrec
prec Id
x = do
Nabla
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] -> PmPprM SDoc
pprPmAltCon PprPrec
prec PmAltCon
alt [Id]
args
Maybe PmAltConApp
Nothing -> forall a. a -> Maybe a -> a
fromMaybe SDoc
underscore 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] -> PmPprM SDoc
pprPmAltCon PprPrec
_prec (PmAltLit PmLit
l) [Id]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Outputable a => a -> SDoc
ppr PmLit
l)
pprPmAltCon PprPrec
prec (PmAltConLike ConLike
cl) [Id]
args = do
Nabla
nabla <- forall (m :: * -> *) r w s. Monad m => RWST r w s m r
ask
Nabla -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc
pprConLike Nabla
nabla PprPrec
prec ConLike
cl [Id]
args
pprConLike :: Nabla -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc
pprConLike :: Nabla -> PprPrec -> ConLike -> [Id] -> PmPprM 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
brackets forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> PmPprM SDoc
pprPmVar PprPrec
appPrec) [Id]
list
WcVarTerminated NonEmpty Id
pref Id
x ->
SDoc -> SDoc
parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
colon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> PmPprM SDoc
pprPmVar PprPrec
appPrec) (forall a. NonEmpty a -> [a]
toList NonEmpty Id
pref 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 :: SDoc -> SDoc
hash_parens SDoc
doc = String -> SDoc
text String
"(#" SDoc -> SDoc -> SDoc
<+> SDoc
doc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"#)"
= SDoc -> SDoc
hash_parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> PmPprM SDoc
pprPmVar PprPrec
appPrec) [Id]
args
| DataCon -> Bool
isTupleDataCon DataCon
con
= SDoc -> SDoc
parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> PmPprM 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 -> PmPprM SDoc
pprPmVar PprPrec
funPrec Id
x
SDoc
y' <- PprPrec -> Id -> PmPprM SDoc
pprPmVar PprPrec
funPrec Id
y
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SDoc -> SDoc
cparen (PprPrec
prec forall a. Ord a => a -> a -> Bool
> PprPrec
opPrec) (SDoc
x' SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ConLike
cl SDoc -> SDoc -> SDoc
<+> SDoc
y'))
[Id]
list -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pprConLike:" (forall a. Outputable a => a -> SDoc
ppr [Id]
list)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Outputable a => a -> SDoc
ppr ConLike
cl)
| Bool
otherwise = do [SDoc]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> PmPprM SDoc
pprPmVar PprPrec
appPrec) [Id]
args
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> SDoc -> SDoc
cparen (PprPrec
prec forall a. Ord a => a -> a -> Bool
> PprPrec
funPrec) ([SDoc] -> SDoc
fsep (forall a. Outputable a => a -> SDoc
ppr ConLike
cl 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 <- forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (forall a. [a] -> [a]
reverse [Id]
rev_pref)
= forall a. a -> Maybe a
Just (NonEmpty Id -> Id -> PmExprList
WcVarTerminated NonEmpty Id
pref Id
x)
go_var [Id]
_ Id
_
= 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 forall a. Eq a => a -> a -> Bool
== DataCon
nilDataCon
= ASSERT( null es ) Just (NilTerminated (reverse rev_pref))
| DataCon
c forall a. Eq a => a -> a -> Bool
== DataCon
consDataCon
= ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)
go_con [Id]
_ PmAltCon
_ [Id]
_
= forall a. Maybe a
Nothing