{-# LANGUAGE CPP, ViewPatterns #-}
module GHC.HsToCore.PmCheck.Ppr (
pprUncovered
) where
#include "HsVersions.h"
import GhcPrelude
import BasicTypes
import Id
import VarEnv
import UniqDFM
import ConLike
import DataCon
import TysWiredIn
import Outputable
import Control.Monad.Trans.RWS.CPS
import Util
import Maybes
import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
import GHC.HsToCore.PmCheck.Types
import GHC.HsToCore.PmCheck.Oracle
pprUncovered :: Delta -> [Id] -> SDoc
pprUncovered :: Delta -> [Id] -> SDoc
pprUncovered Delta
delta [Id]
vas
| UniqDFM (SDoc, [PmAltCon]) -> Bool
forall elt. UniqDFM elt -> Bool
isNullUDFM UniqDFM (SDoc, [PmAltCon])
refuts = [SDoc] -> SDoc
fsep [SDoc]
vec
| Bool
otherwise = SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
fsep [SDoc]
vec) Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"where" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
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 (SDoc, [PmAltCon]) -> [(Unique, (SDoc, [PmAltCon]))]
forall elt. UniqDFM elt -> [(Unique, elt)]
udfmToList UniqDFM (SDoc, [PmAltCon])
refuts))
where
init_prec :: PprPrec
init_prec
| [Id
_] <- [Id]
vas = PprPrec
topPrec
| Bool
otherwise = PprPrec
appPrec
ppr_action :: RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
ppr_action = (Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc)
-> [Id] -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmVar PprPrec
init_prec) [Id]
vas
([SDoc]
vec, DIdEnv SDoc
renamings) = Delta
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
-> ([SDoc], DIdEnv SDoc)
forall a. Delta -> PmPprM a -> (a, DIdEnv SDoc)
runPmPpr Delta
delta RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
ppr_action
refuts :: UniqDFM (SDoc, [PmAltCon])
refuts = Delta -> DIdEnv SDoc -> UniqDFM (SDoc, [PmAltCon])
prettifyRefuts Delta
delta DIdEnv 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 (SDoc -> SDoc) -> ([PmAltCon] -> SDoc) -> [PmAltCon] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep ([SDoc] -> SDoc) -> ([PmAltCon] -> [SDoc]) -> [PmAltCon] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc])
-> ([PmAltCon] -> [SDoc]) -> [PmAltCon] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> [SDoc]
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 :: [SDoc] -> [SDoc]
shorten (SDoc
a:SDoc
b:SDoc
c:SDoc
_:[SDoc]
_) = SDoc
aSDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:SDoc
bSDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:SDoc
cSDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:[String -> SDoc
text String
"..."]
shorten [SDoc]
xs = [SDoc]
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 :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])
prettifyRefuts :: Delta -> DIdEnv SDoc -> UniqDFM (SDoc, [PmAltCon])
prettifyRefuts Delta
delta = [(Unique, (SDoc, [PmAltCon]))] -> UniqDFM (SDoc, [PmAltCon])
forall key elt. Uniquable key => [(key, elt)] -> UniqDFM elt
listToUDFM ([(Unique, (SDoc, [PmAltCon]))] -> UniqDFM (SDoc, [PmAltCon]))
-> (DIdEnv SDoc -> [(Unique, (SDoc, [PmAltCon]))])
-> DIdEnv SDoc
-> UniqDFM (SDoc, [PmAltCon])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Unique, SDoc) -> (Unique, (SDoc, [PmAltCon])))
-> [(Unique, SDoc)] -> [(Unique, (SDoc, [PmAltCon]))]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, SDoc) -> (Unique, (SDoc, [PmAltCon]))
forall k a. Uniquable k => (k, a) -> (k, (a, [PmAltCon]))
attach_refuts ([(Unique, SDoc)] -> [(Unique, (SDoc, [PmAltCon]))])
-> (DIdEnv SDoc -> [(Unique, SDoc)])
-> DIdEnv SDoc
-> [(Unique, (SDoc, [PmAltCon]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DIdEnv SDoc -> [(Unique, SDoc)]
forall elt. UniqDFM elt -> [(Unique, elt)]
udfmToList
where
attach_refuts :: (k, a) -> (k, (a, [PmAltCon]))
attach_refuts (k
u, a
sdoc) = (k
u, (a
sdoc, Delta -> k -> [PmAltCon]
forall k. Uniquable k => Delta -> k -> [PmAltCon]
lookupRefuts Delta
delta k
u))
type PmPprM a = RWS Delta () (DIdEnv SDoc, [SDoc]) a
nameList :: [SDoc]
nameList :: [SDoc]
nameList = (String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
text [String
"p",String
"q",String
"r",String
"s",String
"t"] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
[ String -> SDoc
text (Char
't'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
u) | Int
u <- [(Int
0 :: Int)..] ]
runPmPpr :: Delta -> PmPprM a -> (a, DIdEnv SDoc)
runPmPpr :: Delta -> PmPprM a -> (a, DIdEnv SDoc)
runPmPpr Delta
delta PmPprM a
m = case PmPprM a
-> Delta -> (DIdEnv SDoc, [SDoc]) -> (a, (DIdEnv SDoc, [SDoc]), ())
forall w r s a. Monoid w => RWS r w s a -> r -> s -> (a, s, w)
runRWS PmPprM a
m Delta
delta (DIdEnv SDoc
forall a. DVarEnv a
emptyDVarEnv, [SDoc]
nameList) of
(a
a, (DIdEnv SDoc
renamings, [SDoc]
_), ()
_) -> (a
a, DIdEnv SDoc
renamings)
getCleanName :: Id -> PmPprM SDoc
getCleanName :: Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
getCleanName Id
x = do
(DIdEnv SDoc
renamings, [SDoc]
name_supply) <- RWST Delta () (DIdEnv SDoc, [SDoc]) Identity (DIdEnv SDoc, [SDoc])
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 DIdEnv SDoc -> Id -> Maybe SDoc
forall a. DVarEnv a -> Id -> Maybe a
lookupDVarEnv DIdEnv SDoc
renamings Id
x of
Just SDoc
nm -> SDoc -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SDoc
nm
Maybe SDoc
Nothing -> do
(DIdEnv SDoc, [SDoc])
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity ()
forall (m :: * -> *) s r w. Monad m => s -> RWST r w s m ()
put (DIdEnv SDoc -> Id -> SDoc -> DIdEnv SDoc
forall a. DVarEnv a -> Id -> a -> DVarEnv a
extendDVarEnv DIdEnv SDoc
renamings Id
x SDoc
clean_name, [SDoc]
name_supply')
SDoc -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
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
Delta
delta <- RWST Delta () (DIdEnv SDoc, [SDoc]) Identity Delta
forall (m :: * -> *) r w s. Monad m => RWST r w s m r
ask
case Delta -> Id -> [PmAltCon]
forall k. Uniquable k => Delta -> k -> [PmAltCon]
lookupRefuts Delta
delta Id
x of
[] -> Maybe SDoc -> PmPprM (Maybe SDoc)
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 Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
-> PmPprM (Maybe SDoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
getCleanName Id
x
pprPmVar :: PprPrec -> Id -> PmPprM SDoc
pprPmVar :: PprPrec -> Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmVar PprPrec
prec Id
x = do
Delta
delta <- RWST Delta () (DIdEnv SDoc, [SDoc]) Identity Delta
forall (m :: * -> *) r w s. Monad m => RWST r w s m r
ask
case Delta -> Id -> Maybe (PmAltCon, [Id])
lookupSolution Delta
delta Id
x of
Just (PmAltCon
alt, [Id]
args) -> PprPrec
-> PmAltCon
-> [Id]
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmAltCon PprPrec
prec PmAltCon
alt [Id]
args
Maybe (PmAltCon, [Id])
Nothing -> SDoc -> Maybe SDoc -> SDoc
forall a. a -> Maybe a -> a
fromMaybe SDoc
typed_wildcard (Maybe SDoc -> SDoc)
-> PmPprM (Maybe SDoc)
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Id -> PmPprM (Maybe SDoc)
checkRefuts Id
x
where
typed_wildcard :: SDoc
typed_wildcard
| PprPrec
prec PprPrec -> PprPrec -> Bool
forall a. Ord a => a -> a -> Bool
<= PprPrec
sigPrec
= SDoc
underscore SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"::" SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Kind
idType Id
x)
| Bool
otherwise
= SDoc
underscore
pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc
pprPmAltCon :: PprPrec
-> PmAltCon
-> [Id]
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmAltCon PprPrec
_prec (PmAltLit PmLit
l) [Id]
_ = SDoc -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
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
Delta
delta <- RWST Delta () (DIdEnv SDoc, [SDoc]) Identity Delta
forall (m :: * -> *) r w s. Monad m => RWST r w s m r
ask
Delta
-> PprPrec
-> ConLike
-> [Id]
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprConLike Delta
delta PprPrec
prec ConLike
cl [Id]
args
pprConLike :: Delta -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc
pprConLike :: Delta
-> PprPrec
-> ConLike
-> [Id]
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprConLike Delta
delta PprPrec
_prec ConLike
cl [Id]
args
| Just PmExprList
pm_expr_list <- Delta -> PmAltCon -> [Id] -> Maybe PmExprList
pmExprAsList Delta
delta (ConLike -> PmAltCon
PmAltConLike ConLike
cl) [Id]
args
= case PmExprList
pm_expr_list of
NilTerminated [Id]
list ->
SDoc -> SDoc
brackets (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> SDoc)
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc)
-> [Id] -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmVar PprPrec
appPrec) [Id]
list
WcVarTerminated NonEmpty Id
pref Id
x ->
SDoc -> SDoc
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]
punctuate SDoc
colon ([SDoc] -> SDoc)
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc)
-> [Id] -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> RWST Delta () (DIdEnv SDoc, [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 Delta
_delta PprPrec
_prec (RealDataCon DataCon
con) [Id]
args
| DataCon -> Bool
isUnboxedTupleCon 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 (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> SDoc)
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc)
-> [Id] -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmVar PprPrec
appPrec) [Id]
args
| DataCon -> Bool
isTupleDataCon DataCon
con
= SDoc -> SDoc
parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> SDoc)
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc)
-> [Id] -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmVar PprPrec
appPrec) [Id]
args
pprConLike Delta
_delta 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 Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmVar PprPrec
funPrec Id
x
SDoc
y' <- PprPrec -> Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmVar PprPrec
funPrec Id
y
SDoc -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
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
<+> ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl SDoc -> SDoc -> SDoc
<+> SDoc
y'))
[Id]
list -> String -> SDoc -> RWST Delta () (DIdEnv SDoc, [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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args = SDoc -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
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 Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc)
-> [Id] -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (PprPrec -> Id -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmVar PprPrec
appPrec) [Id]
args
SDoc -> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
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
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 :: Delta -> PmAltCon -> [Id] -> Maybe PmExprList
pmExprAsList :: Delta -> PmAltCon -> [Id] -> Maybe PmExprList
pmExprAsList Delta
delta = [Id] -> PmAltCon -> [Id] -> Maybe PmExprList
go_con []
where
go_var :: [Id] -> Id -> Maybe PmExprList
go_var [Id]
rev_pref Id
x
| Just (PmAltCon
alt, [Id]
args) <- Delta -> Id -> Maybe (PmAltCon, [Id])
lookupSolution Delta
delta 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
= ASSERT( null es ) Just (NilTerminated (reverse rev_pref))
| DataCon
c DataCon -> DataCon -> Bool
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]
_
= Maybe PmExprList
forall a. Maybe a
Nothing