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 vas
| isNullUDFM refuts = fsep vec
| otherwise = hang (fsep vec) 4 $
text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))
where
init_prec
| [_] <- vas = topPrec
| otherwise = appPrec
ppr_action = mapM (pprPmVar init_prec) vas
(vec, renamings) = runPmPpr delta ppr_action
refuts = prettifyRefuts delta renamings
pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc
pprRefutableShapes (var, alts)
= var <+> text "is not one of" <+> format_alts alts
where
format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt
shorten (a:b:c:_:_) = a:b:c:[text "..."]
shorten xs = xs
ppr_alt (PmAltConLike cl) = ppr cl
ppr_alt (PmAltLit lit) = ppr lit
prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])
prettifyRefuts delta = listToUDFM . map attach_refuts . udfmToList
where
attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u))
type PmPprM a = RWS Delta () (DIdEnv SDoc, [SDoc]) a
nameList :: [SDoc]
nameList = map text ["p","q","r","s","t"] ++
[ text ('t':show u) | u <- [(0 :: Int)..] ]
runPmPpr :: Delta -> PmPprM a -> (a, DIdEnv SDoc)
runPmPpr delta m = case runRWS m delta (emptyDVarEnv, nameList) of
(a, (renamings, _), _) -> (a, renamings)
getCleanName :: Id -> PmPprM SDoc
getCleanName x = do
(renamings, name_supply) <- get
let (clean_name:name_supply') = name_supply
case lookupDVarEnv renamings x of
Just nm -> pure nm
Nothing -> do
put (extendDVarEnv renamings x clean_name, name_supply')
pure clean_name
checkRefuts :: Id -> PmPprM (Maybe SDoc)
checkRefuts x = do
delta <- ask
case lookupRefuts delta x of
[] -> pure Nothing
_ -> Just <$> getCleanName x
pprPmVar :: PprPrec -> Id -> PmPprM SDoc
pprPmVar prec x = do
delta <- ask
case lookupSolution delta x of
Just (alt, args) -> pprPmAltCon prec alt args
Nothing -> fromMaybe typed_wildcard <$> checkRefuts x
where
typed_wildcard
| prec <= sigPrec
= underscore <+> text "::" <+> ppr (idType x)
| otherwise
= underscore
pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc
pprPmAltCon _prec (PmAltLit l) _ = pure (ppr l)
pprPmAltCon prec (PmAltConLike cl) args = do
delta <- ask
pprConLike delta prec cl args
pprConLike :: Delta -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc
pprConLike delta _prec cl args
| Just pm_expr_list <- pmExprAsList delta (PmAltConLike cl) args
= case pm_expr_list of
NilTerminated list ->
brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list
WcVarTerminated pref x ->
parens . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])
pprConLike _delta _prec (RealDataCon con) args
| isUnboxedTupleCon con
, let hash_parens doc = text "(#" <+> doc <+> text "#)"
= hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args
| isTupleDataCon con
= parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args
pprConLike _delta prec cl args
| conLikeIsInfix cl = case args of
[x, y] -> do x' <- pprPmVar funPrec x
y' <- pprPmVar funPrec y
return (cparen (prec > opPrec) (x' <+> ppr cl <+> y'))
list -> pprPanic "pprConLike:" (ppr list)
| null args = return (ppr cl)
| otherwise = do args' <- mapM (pprPmVar appPrec) args
return (cparen (prec > funPrec) (fsep (ppr cl : args')))
data PmExprList
= NilTerminated [Id]
| WcVarTerminated (NonEmpty Id) Id
pmExprAsList :: Delta -> PmAltCon -> [Id] -> Maybe PmExprList
pmExprAsList delta = go_con []
where
go_var rev_pref x
| Just (alt, args) <- lookupSolution delta x
= go_con rev_pref alt args
go_var rev_pref x
| Just pref <- nonEmpty (reverse rev_pref)
= Just (WcVarTerminated pref x)
go_var _ _
= Nothing
go_con rev_pref (PmAltConLike (RealDataCon c)) es
| c == nilDataCon
= ASSERT( null es ) Just (NilTerminated (reverse rev_pref))
| c == consDataCon
= ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)
go_con _ _ _
= Nothing