{-# LANGUAGE CPP, ViewPatterns #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Provides factilities for pretty-printing 'Delta's in a way appropriate for
-- user facing pattern match warnings.
module GHC.HsToCore.PmCheck.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 Control.Monad.Trans.RWS.CPS
import GHC.Utils.Misc
import GHC.Data.Maybe
import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)

import GHC.HsToCore.PmCheck.Types
import GHC.HsToCore.PmCheck.Oracle

-- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its
-- components and refutable shapes associated to any mentioned variables.
--
-- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@:
--
-- @
-- (Just p) q
--     where p is not one of {3, 4}
--           q is not one of {0, 5}
-- @
--
-- When the set of refutable shapes contains more than 3 elements, the
-- additional elements are indicated by "...".
pprUncovered :: Delta -> [Id] -> SDoc
pprUncovered :: Delta -> [Id] -> SDoc
pprUncovered Delta
delta [Id]
vas
  | UniqDFM Id (SDoc, [PmAltCon]) -> Bool
forall key elt. UniqDFM key elt -> Bool
isNullUDFM UniqDFM Id (SDoc, [PmAltCon])
refuts = [SDoc] -> SDoc
fsep [SDoc]
vec -- there are no refutations
  | 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 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
      -- No outer parentheses when it's a unary pattern by assuming lowest
      -- precedence
      | [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 Id (SDoc, [PmAltCon])
refuts           = Delta -> DIdEnv SDoc -> UniqDFM Id (SDoc, [PmAltCon])
prettifyRefuts Delta
delta DIdEnv SDoc
renamings

-- | Output refutable shapes of a variable in the form of @var is not one of {2,
-- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is
-- indicated by an ellipsis.
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

{- 1. Literals
~~~~~~~~~~~~~~
Starting with a function definition like:

    f :: Int -> Bool
    f 5 = True
    f 6 = True

The uncovered set looks like:
    { var |> var /= 5, var /= 6 }

Yet, we would like to print this nicely as follows:
   x , where x not one of {5,6}

Since these variables will be shown to the programmer, we give them better names
(t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'.

2. Residual Constraints
~~~~~~~~~~~~~~~~~~~~~~~
Unhandled constraints that refer to HsExpr are typically ignored by the solver
(it does not even substitute in HsExpr so they are even printed as wildcards).
Additionally, the oracle returns a substitution if it succeeds so we apply this
substitution to the vectors before printing them out (see function `pprOne' in
"GHC.HsToCore.PmCheck") to be more precise.
-}

-- | Extract and assigns pretty names to constraint variables with refutable
-- shapes.
prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])
prettifyRefuts :: Delta -> DIdEnv SDoc -> UniqDFM Id (SDoc, [PmAltCon])
prettifyRefuts Delta
delta = [(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 SDoc -> [(Unique, (SDoc, [PmAltCon]))])
-> DIdEnv SDoc
-> UniqDFM Id (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 key elt. UniqDFM key 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

-- Try nice names p,q,r,s,t before using the (ugly) t_i
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 :: forall a. 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)

-- | Allocates a new, clean name for the given 'Id' if it doesn't already have
-- one.
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) -- the clean name if it has negative info attached
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 -- Will just be a wildcard later on
    [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

-- | Pretty print a variable, but remember to prettify the names of the variables
-- that refer to neg-literals. The ones that cannot be shown are printed as
-- underscores. Even with a type signature, if it's not too noisy.
pprPmVar :: PprPrec -> Id -> PmPprM SDoc
-- Type signature is "too noisy" by my definition if it needs to parenthesize.
-- I like           "not matched: _ :: Proxy (DIdEnv SDoc)",
-- but I don't like "not matched: (_ :: stuff) (_:_) (_ :: Proxy (DIdEnv SDoc))"
-- The useful information in the latter case is the constructor that we missed,
-- not the types of the wildcards in the places that aren't matched as a result.
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], [Id])
lookupSolution Delta
delta Id
x of
    Just (PmAltCon
alt, [Id]
_tvs, [Id]
args) -> PprPrec
-> PmAltCon
-> [Id]
-> RWST Delta () (DIdEnv SDoc, [SDoc]) Identity SDoc
pprPmAltCon PprPrec
prec PmAltCon
alt [Id]
args
    Maybe (PmAltCon, [Id], [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
        -- if we have no info about the parameter and would just print a
        -- wildcard, also show its type.
        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'))
      -- can it be infix but have more than two arguments?
      [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')))

-- | The result of 'pmExprAsList'.
data PmExprList
  = NilTerminated [Id]
  | WcVarTerminated (NonEmpty Id) Id

-- | Extract a list of 'Id's out of a sequence of cons cells, optionally
-- terminated by a wildcard variable instead of @[]@. Some examples:
--
-- * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular,
--   @[]@-terminated list. Should be pretty-printed as @[1,2]@.
-- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix
--   ending in a wildcard variable x (of list type). Should be pretty-printed as
--   (1:2:_).
-- * @pmExprAsList [] == Just ('NilTerminated' [])@
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]
_tvs, [Id]
args) <- Delta -> Id -> Maybe (PmAltCon, [Id], [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