never executed always true always false
    1 
    2 
    3 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    4 
    5 -- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for
    6 -- user facing pattern match warnings.
    7 module GHC.HsToCore.Pmc.Ppr (
    8       pprUncovered
    9     ) where
   10 
   11 import GHC.Prelude
   12 
   13 import GHC.Types.Basic
   14 import GHC.Types.Id
   15 import GHC.Types.Var.Env
   16 import GHC.Types.Unique.DFM
   17 import GHC.Core.ConLike
   18 import GHC.Core.DataCon
   19 import GHC.Builtin.Types
   20 import GHC.Utils.Outputable
   21 import GHC.Utils.Panic
   22 import GHC.Utils.Panic.Plain
   23 import Control.Monad.Trans.RWS.CPS
   24 import GHC.Data.Maybe
   25 import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
   26 
   27 import GHC.HsToCore.Pmc.Types
   28 
   29 -- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its
   30 -- components and refutable shapes associated to any mentioned variables.
   31 --
   32 -- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@:
   33 --
   34 -- @
   35 -- (Just p) q
   36 --     where p is not one of {3, 4}
   37 --           q is not one of {0, 5}
   38 -- @
   39 --
   40 -- When the set of refutable shapes contains more than 3 elements, the
   41 -- additional elements are indicated by "...".
   42 pprUncovered :: Nabla -> [Id] -> SDoc
   43 pprUncovered nabla vas
   44   | isNullUDFM refuts = fsep vec -- there are no refutations
   45   | otherwise         = hang (fsep vec) 4 $
   46                           text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))
   47   where
   48     init_prec
   49       -- No outer parentheses when it's a unary pattern by assuming lowest
   50       -- precedence
   51       | [_] <- vas   = topPrec
   52       | otherwise    = appPrec
   53     ppr_action       = mapM (pprPmVar init_prec) vas
   54     (vec, renamings) = runPmPpr nabla ppr_action
   55     refuts           = prettifyRefuts nabla renamings
   56 
   57 -- | Output refutable shapes of a variable in the form of @var is not one of {2,
   58 -- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is
   59 -- indicated by an ellipsis.
   60 pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc
   61 pprRefutableShapes (var, alts)
   62   = var <+> text "is not one of" <+> format_alts alts
   63   where
   64     format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt
   65     shorten (a:b:c:_:_)       = a:b:c:[text "..."]
   66     shorten xs                = xs
   67     ppr_alt (PmAltConLike cl) = ppr cl
   68     ppr_alt (PmAltLit lit)    = ppr lit
   69 
   70 {- 1. Literals
   71 ~~~~~~~~~~~~~~
   72 Starting with a function definition like:
   73 
   74     f :: Int -> Bool
   75     f 5 = True
   76     f 6 = True
   77 
   78 The uncovered set looks like:
   79     { var |> var /= 5, var /= 6 }
   80 
   81 Yet, we would like to print this nicely as follows:
   82    x , where x not one of {5,6}
   83 
   84 Since these variables will be shown to the programmer, we give them better names
   85 (t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'.
   86 
   87 2. Residual Constraints
   88 ~~~~~~~~~~~~~~~~~~~~~~~
   89 Unhandled constraints that refer to HsExpr are typically ignored by the solver
   90 (it does not even substitute in HsExpr so they are even printed as wildcards).
   91 Additionally, the oracle returns a substitution if it succeeds so we apply this
   92 substitution to the vectors before printing them out (see function `pprOne' in
   93 "GHC.HsToCore.Pmc") to be more precise.
   94 -}
   95 
   96 -- | Extract and assigns pretty names to constraint variables with refutable
   97 -- shapes.
   98 prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (SDoc, [PmAltCon])
   99 prettifyRefuts nabla = listToUDFM_Directly . map attach_refuts . udfmToList
  100   where
  101     attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x))
  102 
  103 
  104 type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), [SDoc]) a
  105 
  106 -- Try nice names p,q,r,s,t before using the (ugly) t_i
  107 nameList :: [SDoc]
  108 nameList = map text ["p","q","r","s","t"] ++
  109             [ text ('t':show u) | u <- [(0 :: Int)..] ]
  110 
  111 runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))
  112 runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of
  113   (a, (renamings, _), _) -> (a, renamings)
  114 
  115 -- | Allocates a new, clean name for the given 'Id' if it doesn't already have
  116 -- one.
  117 getCleanName :: Id -> PmPprM SDoc
  118 getCleanName x = do
  119   (renamings, name_supply) <- get
  120   let (clean_name:name_supply') = name_supply
  121   case lookupDVarEnv renamings x of
  122     Just (_, nm) -> pure nm
  123     Nothing -> do
  124       put (extendDVarEnv renamings x (x, clean_name), name_supply')
  125       pure clean_name
  126 
  127 checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached
  128 checkRefuts x = do
  129   nabla <- ask
  130   case lookupRefuts nabla x of
  131     [] -> pure Nothing -- Will just be a wildcard later on
  132     _  -> Just <$> getCleanName x
  133 
  134 -- | Pretty print a variable, but remember to prettify the names of the variables
  135 -- that refer to neg-literals. The ones that cannot be shown are printed as
  136 -- underscores.
  137 pprPmVar :: PprPrec -> Id -> PmPprM SDoc
  138 pprPmVar prec x = do
  139   nabla <- ask
  140   case lookupSolution nabla x of
  141     Just (PACA alt _tvs args) -> pprPmAltCon prec alt args
  142     Nothing                   -> fromMaybe underscore <$> checkRefuts x
  143 
  144 pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc
  145 pprPmAltCon _prec (PmAltLit l)      _    = pure (ppr l)
  146 pprPmAltCon prec  (PmAltConLike cl) args = do
  147   nabla <- ask
  148   pprConLike nabla prec cl args
  149 
  150 pprConLike :: Nabla -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc
  151 pprConLike nabla _prec cl args
  152   | Just pm_expr_list <- pmExprAsList nabla (PmAltConLike cl) args
  153   = case pm_expr_list of
  154       NilTerminated list ->
  155         brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list
  156       WcVarTerminated pref x ->
  157         parens   . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])
  158 pprConLike _nabla _prec (RealDataCon con) args
  159   | isUnboxedTupleDataCon con
  160   , let hash_parens doc = text "(#" <+> doc <+> text "#)"
  161   = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args
  162   | isTupleDataCon con
  163   = parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args
  164 pprConLike _nabla prec cl args
  165   | conLikeIsInfix cl = case args of
  166       [x, y] -> do x' <- pprPmVar funPrec x
  167                    y' <- pprPmVar funPrec y
  168                    return (cparen (prec > opPrec) (x' <+> ppr cl <+> y'))
  169       -- can it be infix but have more than two arguments?
  170       list   -> pprPanic "pprConLike:" (ppr list)
  171   | null args = return (ppr cl)
  172   | otherwise = do args' <- mapM (pprPmVar appPrec) args
  173                    return (cparen (prec > funPrec) (fsep (ppr cl : args')))
  174 
  175 -- | The result of 'pmExprAsList'.
  176 data PmExprList
  177   = NilTerminated [Id]
  178   | WcVarTerminated (NonEmpty Id) Id
  179 
  180 -- | Extract a list of 'Id's out of a sequence of cons cells, optionally
  181 -- terminated by a wildcard variable instead of @[]@. Some examples:
  182 --
  183 -- * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular,
  184 --   @[]@-terminated list. Should be pretty-printed as @[1,2]@.
  185 -- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix
  186 --   ending in a wildcard variable x (of list type). Should be pretty-printed as
  187 --   (1:2:_).
  188 -- * @pmExprAsList [] == Just ('NilTerminated' [])@
  189 pmExprAsList :: Nabla -> PmAltCon -> [Id] -> Maybe PmExprList
  190 pmExprAsList nabla = go_con []
  191   where
  192     go_var rev_pref x
  193       | Just (PACA alt _tvs args) <- lookupSolution nabla x
  194       = go_con rev_pref alt args
  195     go_var rev_pref x
  196       | Just pref <- nonEmpty (reverse rev_pref)
  197       = Just (WcVarTerminated pref x)
  198     go_var _ _
  199       = Nothing
  200 
  201     go_con rev_pref (PmAltConLike (RealDataCon c)) es
  202       | c == nilDataCon
  203       = assert (null es) $ Just (NilTerminated (reverse rev_pref))
  204       | c == consDataCon
  205       = assert (length es == 2) $ go_var (es !! 0 : rev_pref) (es !! 1)
  206     go_con _ _ _
  207       = Nothing