-- | Checking for missing cases in a match expression.  Based on
-- "Warnings for pattern matching" by Luc Maranget.  We only detect
-- inexhaustiveness here - ideally, we would also like to check for
-- redundant cases.
module Language.Futhark.TypeChecker.Match
  ( unmatched,
    Match,
  )
where

import Data.List qualified as L
import Data.Map.Strict qualified as M
import Data.Maybe
import Futhark.Util (maybeHead, nubOrd)
import Futhark.Util.Pretty hiding (group, space)
import Language.Futhark hiding (ExpBase (Constr))

data Constr
  = Constr Name
  | ConstrTuple
  | ConstrRecord [Name]
  | -- | Treated as 0-ary.
    ConstrLit PatLit
  deriving (Constr -> Constr -> Bool
(Constr -> Constr -> Bool)
-> (Constr -> Constr -> Bool) -> Eq Constr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Constr -> Constr -> Bool
== :: Constr -> Constr -> Bool
$c/= :: Constr -> Constr -> Bool
/= :: Constr -> Constr -> Bool
Eq, Eq Constr
Eq Constr
-> (Constr -> Constr -> Ordering)
-> (Constr -> Constr -> Bool)
-> (Constr -> Constr -> Bool)
-> (Constr -> Constr -> Bool)
-> (Constr -> Constr -> Bool)
-> (Constr -> Constr -> Constr)
-> (Constr -> Constr -> Constr)
-> Ord Constr
Constr -> Constr -> Bool
Constr -> Constr -> Ordering
Constr -> Constr -> Constr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Constr -> Constr -> Ordering
compare :: Constr -> Constr -> Ordering
$c< :: Constr -> Constr -> Bool
< :: Constr -> Constr -> Bool
$c<= :: Constr -> Constr -> Bool
<= :: Constr -> Constr -> Bool
$c> :: Constr -> Constr -> Bool
> :: Constr -> Constr -> Bool
$c>= :: Constr -> Constr -> Bool
>= :: Constr -> Constr -> Bool
$cmax :: Constr -> Constr -> Constr
max :: Constr -> Constr -> Constr
$cmin :: Constr -> Constr -> Constr
min :: Constr -> Constr -> Constr
Ord, Int -> Constr -> ShowS
[Constr] -> ShowS
Constr -> String
(Int -> Constr -> ShowS)
-> (Constr -> String) -> ([Constr] -> ShowS) -> Show Constr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Constr -> ShowS
showsPrec :: Int -> Constr -> ShowS
$cshow :: Constr -> String
show :: Constr -> String
$cshowList :: [Constr] -> ShowS
showList :: [Constr] -> ShowS
Show)

-- | A representation of the essentials of a pattern.
data Match t
  = MatchWild t
  | MatchConstr Constr [Match t] t
  deriving (Match t -> Match t -> Bool
(Match t -> Match t -> Bool)
-> (Match t -> Match t -> Bool) -> Eq (Match t)
forall t. Eq t => Match t -> Match t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall t. Eq t => Match t -> Match t -> Bool
== :: Match t -> Match t -> Bool
$c/= :: forall t. Eq t => Match t -> Match t -> Bool
/= :: Match t -> Match t -> Bool
Eq, Eq (Match t)
Eq (Match t)
-> (Match t -> Match t -> Ordering)
-> (Match t -> Match t -> Bool)
-> (Match t -> Match t -> Bool)
-> (Match t -> Match t -> Bool)
-> (Match t -> Match t -> Bool)
-> (Match t -> Match t -> Match t)
-> (Match t -> Match t -> Match t)
-> Ord (Match t)
Match t -> Match t -> Bool
Match t -> Match t -> Ordering
Match t -> Match t -> Match t
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {t}. Ord t => Eq (Match t)
forall t. Ord t => Match t -> Match t -> Bool
forall t. Ord t => Match t -> Match t -> Ordering
forall t. Ord t => Match t -> Match t -> Match t
$ccompare :: forall t. Ord t => Match t -> Match t -> Ordering
compare :: Match t -> Match t -> Ordering
$c< :: forall t. Ord t => Match t -> Match t -> Bool
< :: Match t -> Match t -> Bool
$c<= :: forall t. Ord t => Match t -> Match t -> Bool
<= :: Match t -> Match t -> Bool
$c> :: forall t. Ord t => Match t -> Match t -> Bool
> :: Match t -> Match t -> Bool
$c>= :: forall t. Ord t => Match t -> Match t -> Bool
>= :: Match t -> Match t -> Bool
$cmax :: forall t. Ord t => Match t -> Match t -> Match t
max :: Match t -> Match t -> Match t
$cmin :: forall t. Ord t => Match t -> Match t -> Match t
min :: Match t -> Match t -> Match t
Ord, Int -> Match t -> ShowS
[Match t] -> ShowS
Match t -> String
(Int -> Match t -> ShowS)
-> (Match t -> String) -> ([Match t] -> ShowS) -> Show (Match t)
forall t. Show t => Int -> Match t -> ShowS
forall t. Show t => [Match t] -> ShowS
forall t. Show t => Match t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall t. Show t => Int -> Match t -> ShowS
showsPrec :: Int -> Match t -> ShowS
$cshow :: forall t. Show t => Match t -> String
show :: Match t -> String
$cshowList :: forall t. Show t => [Match t] -> ShowS
showList :: [Match t] -> ShowS
Show)

matchType :: Match StructType -> StructType
matchType :: Match StructType -> StructType
matchType (MatchWild StructType
t) = StructType
t
matchType (MatchConstr Constr
_ [Match StructType]
_ StructType
t) = StructType
t

pprMatch :: Int -> Match t -> Doc a
pprMatch :: forall t a. Int -> Match t -> Doc a
pprMatch Int
_ MatchWild {} = Doc a
"_"
pprMatch Int
_ (MatchConstr (ConstrLit PatLit
l) [Match t]
_ t
_) = PatLit -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. PatLit -> Doc ann
pretty PatLit
l
pprMatch Int
p (MatchConstr (Constr Name
c) [Match t]
ps t
_) =
  Bool -> Doc a -> Doc a
forall a. Bool -> Doc a -> Doc a
parensIf (Bool -> Bool
not ([Match t] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Match t]
ps) Bool -> Bool -> Bool
&& Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10) (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$
    Doc a
"#" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Name -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall ann. Name -> Doc ann
pretty Name
c Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> [Doc a] -> Doc a
forall a. Monoid a => [a] -> a
mconcat ((Match t -> Doc a) -> [Match t] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc a
" " <>) (Doc a -> Doc a) -> (Match t -> Doc a) -> Match t -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Match t -> Doc a
forall t a. Int -> Match t -> Doc a
pprMatch Int
10) [Match t]
ps)
pprMatch Int
_ (MatchConstr Constr
ConstrTuple [Match t]
ps t
_) =
  Doc a -> Doc a
forall ann. Doc ann -> Doc ann
parens (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$ [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
commasep ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$ (Match t -> Doc a) -> [Match t] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Match t -> Doc a
forall t a. Int -> Match t -> Doc a
pprMatch (-Int
1)) [Match t]
ps
pprMatch Int
_ (MatchConstr (ConstrRecord [Name]
fs) [Match t]
ps t
_) =
  Doc a -> Doc a
forall ann. Doc ann -> Doc ann
braces (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$ [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
commasep ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$ (Name -> Match t -> Doc a) -> [Name] -> [Match t] -> [Doc a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Match t -> Doc a
forall {t} {ann}. Name -> Match t -> Doc ann
ppField [Name]
fs [Match t]
ps
  where
    ppField :: Name -> Match t -> Doc ann
ppField Name
name Match t
t = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Name -> String
nameToString Name
name) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
equals Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Match t -> Doc ann
forall t a. Int -> Match t -> Doc a
pprMatch (-Int
1) Match t
t

instance Pretty (Match t) where
  pretty :: forall ann. Match t -> Doc ann
pretty = Int -> Match t -> Doc ann
forall t a. Int -> Match t -> Doc a
pprMatch (-Int
1)

patternToMatch :: Pat StructType -> Match StructType
patternToMatch :: Pat StructType -> Match StructType
patternToMatch (Id VName
_ (Info StructType
t) SrcLoc
_) = StructType -> Match StructType
forall t. t -> Match t
MatchWild StructType
t
patternToMatch (Wildcard (Info StructType
t) SrcLoc
_) = StructType -> Match StructType
forall t. t -> Match t
MatchWild StructType
t
patternToMatch (PatParens Pat StructType
p SrcLoc
_) = Pat StructType -> Match StructType
patternToMatch Pat StructType
p
patternToMatch (PatAttr AttrInfo VName
_ Pat StructType
p SrcLoc
_) = Pat StructType -> Match StructType
patternToMatch Pat StructType
p
patternToMatch (PatAscription Pat StructType
p TypeExp (ExpBase Info VName) VName
_ SrcLoc
_) = Pat StructType -> Match StructType
patternToMatch Pat StructType
p
patternToMatch (PatLit PatLit
l (Info StructType
t) SrcLoc
_) =
  Constr -> [Match StructType] -> StructType -> Match StructType
forall t. Constr -> [Match t] -> t -> Match t
MatchConstr (PatLit -> Constr
ConstrLit PatLit
l) [] StructType
t
patternToMatch p :: Pat StructType
p@(TuplePat [Pat StructType]
ps SrcLoc
_) =
  Constr -> [Match StructType] -> StructType -> Match StructType
forall t. Constr -> [Match t] -> t -> Match t
MatchConstr Constr
ConstrTuple ((Pat StructType -> Match StructType)
-> [Pat StructType] -> [Match StructType]
forall a b. (a -> b) -> [a] -> [b]
map Pat StructType -> Match StructType
patternToMatch [Pat StructType]
ps) (StructType -> Match StructType) -> StructType -> Match StructType
forall a b. (a -> b) -> a -> b
$
    Pat StructType -> StructType
forall u. Pat (TypeBase (ExpBase Info VName) u) -> StructType
patternStructType Pat StructType
p
patternToMatch p :: Pat StructType
p@(RecordPat [(Name, Pat StructType)]
fs SrcLoc
_) =
  Constr -> [Match StructType] -> StructType -> Match StructType
forall t. Constr -> [Match t] -> t -> Match t
MatchConstr ([Name] -> Constr
ConstrRecord [Name]
fnames) ((Pat StructType -> Match StructType)
-> [Pat StructType] -> [Match StructType]
forall a b. (a -> b) -> [a] -> [b]
map Pat StructType -> Match StructType
patternToMatch [Pat StructType]
ps) (StructType -> Match StructType) -> StructType -> Match StructType
forall a b. (a -> b) -> a -> b
$
    Pat StructType -> StructType
forall u. Pat (TypeBase (ExpBase Info VName) u) -> StructType
patternStructType Pat StructType
p
  where
    ([Name]
fnames, [Pat StructType]
ps) = [(Name, Pat StructType)] -> ([Name], [Pat StructType])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Name, Pat StructType)] -> ([Name], [Pat StructType]))
-> [(Name, Pat StructType)] -> ([Name], [Pat StructType])
forall a b. (a -> b) -> a -> b
$ Map Name (Pat StructType) -> [(Name, Pat StructType)]
forall a. Map Name a -> [(Name, a)]
sortFields (Map Name (Pat StructType) -> [(Name, Pat StructType)])
-> Map Name (Pat StructType) -> [(Name, Pat StructType)]
forall a b. (a -> b) -> a -> b
$ [(Name, Pat StructType)] -> Map Name (Pat StructType)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Name, Pat StructType)]
fs
patternToMatch (PatConstr Name
c (Info StructType
t) [Pat StructType]
args SrcLoc
_) =
  Constr -> [Match StructType] -> StructType -> Match StructType
forall t. Constr -> [Match t] -> t -> Match t
MatchConstr (Name -> Constr
Constr Name
c) ((Pat StructType -> Match StructType)
-> [Pat StructType] -> [Match StructType]
forall a b. (a -> b) -> [a] -> [b]
map Pat StructType -> Match StructType
patternToMatch [Pat StructType]
args) StructType
t

isConstr :: Match t -> Maybe Name
isConstr :: forall t. Match t -> Maybe Name
isConstr (MatchConstr (Constr Name
c) [Match t]
_ t
_) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
c
isConstr Match t
_ = Maybe Name
forall a. Maybe a
Nothing

isBool :: Match t -> Maybe Bool
isBool :: forall t. Match t -> Maybe Bool
isBool (MatchConstr (ConstrLit (PatLitPrim (BoolValue Bool
b))) [Match t]
_ t
_) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b
isBool Match t
_ = Maybe Bool
forall a. Maybe a
Nothing

complete :: [Match StructType] -> Bool
complete :: [Match StructType] -> Bool
complete [Match StructType]
xs
  | Just Match StructType
x <- [Match StructType] -> Maybe (Match StructType)
forall a. [a] -> Maybe a
maybeHead [Match StructType]
xs,
    Scalar (Sum Map Name [StructType]
all_cs) <- Match StructType -> StructType
matchType Match StructType
x,
    Just [Name]
xs_cs <- (Match StructType -> Maybe Name)
-> [Match StructType] -> Maybe [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Match StructType -> Maybe Name
forall t. Match t -> Maybe Name
isConstr [Match StructType]
xs =
      (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
xs_cs) (Map Name [StructType] -> [Name]
forall k a. Map k a -> [k]
M.keys Map Name [StructType]
all_cs)
  | Bool
otherwise =
      (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> [Bool] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Bool] -> Maybe [Bool] -> [Bool]
forall a. a -> Maybe a -> a
fromMaybe [] ((Match StructType -> Maybe Bool)
-> [Match StructType] -> Maybe [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Match StructType -> Maybe Bool
forall t. Match t -> Maybe Bool
isBool [Match StructType]
xs)) [Bool
True, Bool
False]
        Bool -> Bool -> Bool
|| (Match StructType -> Bool) -> [Match StructType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Match StructType -> Bool
forall {t}. Match t -> Bool
isRecord [Match StructType]
xs
        Bool -> Bool -> Bool
|| (Match StructType -> Bool) -> [Match StructType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Match StructType -> Bool
forall {t}. Match t -> Bool
isTuple [Match StructType]
xs
  where
    isRecord :: Match t -> Bool
isRecord (MatchConstr ConstrRecord {} [Match t]
_ t
_) = Bool
True
    isRecord Match t
_ = Bool
False
    isTuple :: Match t -> Bool
isTuple (MatchConstr Constr
ConstrTuple [Match t]
_ t
_) = Bool
True
    isTuple Match t
_ = Bool
False

specialise ::
  [StructType] ->
  Match StructType ->
  [[Match StructType]] ->
  [[Match StructType]]
specialise :: [StructType]
-> Match StructType -> [[Match StructType]] -> [[Match StructType]]
specialise [StructType]
ats Match StructType
c1 = [[Match StructType]] -> [[Match StructType]]
go
  where
    go :: [[Match StructType]] -> [[Match StructType]]
go ((Match StructType
c2 : [Match StructType]
row) : [[Match StructType]]
ps)
      | Just [Match StructType]
args <- Match StructType -> Match StructType -> Maybe [Match StructType]
forall {t}. Match t -> Match StructType -> Maybe [Match StructType]
match Match StructType
c1 Match StructType
c2 =
          ([Match StructType]
args [Match StructType] -> [Match StructType] -> [Match StructType]
forall a. [a] -> [a] -> [a]
++ [Match StructType]
row) [Match StructType] -> [[Match StructType]] -> [[Match StructType]]
forall a. a -> [a] -> [a]
: [[Match StructType]] -> [[Match StructType]]
go [[Match StructType]]
ps
      | Bool
otherwise =
          [[Match StructType]] -> [[Match StructType]]
go [[Match StructType]]
ps
    go [[Match StructType]]
_ = []

    match :: Match t -> Match StructType -> Maybe [Match StructType]
match (MatchConstr Constr
c1' [Match t]
_ t
_) (MatchConstr Constr
c2' [Match StructType]
args StructType
_)
      | Constr
c1' Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== Constr
c2' =
          [Match StructType] -> Maybe [Match StructType]
forall a. a -> Maybe a
Just [Match StructType]
args
      | Bool
otherwise =
          Maybe [Match StructType]
forall a. Maybe a
Nothing
    match Match t
_ MatchWild {} =
      [Match StructType] -> Maybe [Match StructType]
forall a. a -> Maybe a
Just ([Match StructType] -> Maybe [Match StructType])
-> [Match StructType] -> Maybe [Match StructType]
forall a b. (a -> b) -> a -> b
$ (StructType -> Match StructType)
-> [StructType] -> [Match StructType]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> Match StructType
forall t. t -> Match t
MatchWild [StructType]
ats
    match Match t
_ Match StructType
_ =
      Maybe [Match StructType]
forall a. Maybe a
Nothing

defaultMat :: [[Match t]] -> [[Match t]]
defaultMat :: forall t. [[Match t]] -> [[Match t]]
defaultMat = ([Match t] -> Maybe [Match t]) -> [[Match t]] -> [[Match t]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Match t] -> Maybe [Match t]
forall {t}. [Match t] -> Maybe [Match t]
onRow
  where
    onRow :: [Match t] -> Maybe [Match t]
onRow (MatchConstr {} : [Match t]
_) = Maybe [Match t]
forall a. Maybe a
Nothing
    onRow (MatchWild {} : [Match t]
ps) = [Match t] -> Maybe [Match t]
forall a. a -> Maybe a
Just [Match t]
ps
    onRow [] = Maybe [Match t]
forall a. Maybe a
Nothing -- Should not happen.

findUnmatched :: [[Match StructType]] -> Int -> [[Match ()]]
findUnmatched :: [[Match StructType]] -> Int -> [[Match ()]]
findUnmatched [[Match StructType]]
pmat Int
n
  | ((Match StructType
p : [Match StructType]
_) : [[Match StructType]]
_) <- [[Match StructType]]
pmat,
    Just [Match StructType]
heads <- ([Match StructType] -> Maybe (Match StructType))
-> [[Match StructType]] -> Maybe [Match StructType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Match StructType] -> Maybe (Match StructType)
forall a. [a] -> Maybe a
maybeHead [[Match StructType]]
pmat =
      if [Match StructType] -> Bool
complete [Match StructType]
heads
        then [Match StructType] -> [[Match ()]]
completeCase [Match StructType]
heads
        else StructType -> [Match StructType] -> [[Match ()]]
forall {dim} {u} {t}. TypeBase dim u -> [Match t] -> [[Match ()]]
incompleteCase (Match StructType -> StructType
matchType Match StructType
p) [Match StructType]
heads
  where
    completeCase :: [Match StructType] -> [[Match ()]]
completeCase [Match StructType]
cs = do
      Match StructType
c <- [Match StructType]
cs
      let ats :: [StructType]
ats = case Match StructType
c of
            MatchConstr Constr
_ [Match StructType]
args StructType
_ -> (Match StructType -> StructType)
-> [Match StructType] -> [StructType]
forall a b. (a -> b) -> [a] -> [b]
map Match StructType -> StructType
matchType [Match StructType]
args
            MatchWild StructType
_ -> []
          a_k :: Int
a_k = [StructType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StructType]
ats
          pmat' :: [[Match StructType]]
pmat' = [StructType]
-> Match StructType -> [[Match StructType]] -> [[Match StructType]]
specialise [StructType]
ats Match StructType
c [[Match StructType]]
pmat
      [Match ()]
u <- [[Match StructType]] -> Int -> [[Match ()]]
findUnmatched [[Match StructType]]
pmat' (Int
a_k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      [Match ()] -> [[Match ()]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Match ()] -> [[Match ()]]) -> [Match ()] -> [[Match ()]]
forall a b. (a -> b) -> a -> b
$ case Match StructType
c of
        MatchConstr Constr
c' [Match StructType]
_ StructType
_ ->
          let ([Match ()]
r, [Match ()]
p) = Int -> [Match ()] -> ([Match ()], [Match ()])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
a_k [Match ()]
u
           in Constr -> [Match ()] -> () -> Match ()
forall t. Constr -> [Match t] -> t -> Match t
MatchConstr Constr
c' [Match ()]
r () Match () -> [Match ()] -> [Match ()]
forall a. a -> [a] -> [a]
: [Match ()]
p
        MatchWild StructType
_ ->
          () -> Match ()
forall t. t -> Match t
MatchWild () Match () -> [Match ()] -> [Match ()]
forall a. a -> [a] -> [a]
: [Match ()]
u

    incompleteCase :: TypeBase dim u -> [Match t] -> [[Match ()]]
incompleteCase TypeBase dim u
pt [Match t]
cs = do
      [Match ()]
u <- [[Match StructType]] -> Int -> [[Match ()]]
findUnmatched ([[Match StructType]] -> [[Match StructType]]
forall t. [[Match t]] -> [[Match t]]
defaultMat [[Match StructType]]
pmat) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      if [Match t] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Match t]
cs
        then [Match ()] -> [[Match ()]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Match ()] -> [[Match ()]]) -> [Match ()] -> [[Match ()]]
forall a b. (a -> b) -> a -> b
$ () -> Match ()
forall t. t -> Match t
MatchWild () Match () -> [Match ()] -> [Match ()]
forall a. a -> [a] -> [a]
: [Match ()]
u
        else case TypeBase dim u
pt of
          Scalar (Sum Map Name [TypeBase dim u]
all_cs) -> do
            -- Figure out which constructors are missing.
            let sigma :: [Name]
sigma = (Match t -> Maybe Name) -> [Match t] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Match t -> Maybe Name
forall t. Match t -> Maybe Name
isConstr [Match t]
cs
                notCovered :: (Name, b) -> Bool
notCovered (Name
k, b
_) = Name
k Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
sigma
            (Name
cname, [TypeBase dim u]
ts) <- ((Name, [TypeBase dim u]) -> Bool)
-> [(Name, [TypeBase dim u])] -> [(Name, [TypeBase dim u])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name, [TypeBase dim u]) -> Bool
forall {b}. (Name, b) -> Bool
notCovered ([(Name, [TypeBase dim u])] -> [(Name, [TypeBase dim u])])
-> [(Name, [TypeBase dim u])] -> [(Name, [TypeBase dim u])]
forall a b. (a -> b) -> a -> b
$ Map Name [TypeBase dim u] -> [(Name, [TypeBase dim u])]
forall k a. Map k a -> [(k, a)]
M.toList Map Name [TypeBase dim u]
all_cs
            [Match ()] -> [[Match ()]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Match ()] -> [[Match ()]]) -> [Match ()] -> [[Match ()]]
forall a b. (a -> b) -> a -> b
$ Constr -> [Match ()] -> () -> Match ()
forall t. Constr -> [Match t] -> t -> Match t
MatchConstr (Name -> Constr
Constr Name
cname) ((TypeBase dim u -> Match ()) -> [TypeBase dim u] -> [Match ()]
forall a b. (a -> b) -> [a] -> [b]
map (Match () -> TypeBase dim u -> Match ()
forall a b. a -> b -> a
const (() -> Match ()
forall t. t -> Match t
MatchWild ())) [TypeBase dim u]
ts) () Match () -> [Match ()] -> [Match ()]
forall a. a -> [a] -> [a]
: [Match ()]
u
          Scalar (Prim PrimType
Bool) -> do
            -- Figure out which constants are missing.
            let sigma :: [Bool]
sigma = (Match t -> Maybe Bool) -> [Match t] -> [Bool]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Match t -> Maybe Bool
forall t. Match t -> Maybe Bool
isBool [Match t]
cs
            Bool
b <- (Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> [Bool] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Bool]
sigma) [Bool
True, Bool
False]
            [Match ()] -> [[Match ()]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Match ()] -> [[Match ()]]) -> [Match ()] -> [[Match ()]]
forall a b. (a -> b) -> a -> b
$ Constr -> [Match ()] -> () -> Match ()
forall t. Constr -> [Match t] -> t -> Match t
MatchConstr (PatLit -> Constr
ConstrLit (PrimValue -> PatLit
PatLitPrim (Bool -> PrimValue
BoolValue Bool
b))) [] () Match () -> [Match ()] -> [Match ()]
forall a. a -> [a] -> [a]
: [Match ()]
u
          TypeBase dim u
_ -> do
            -- FIXME: this is wrong in the unlikely case where someone
            -- is pattern-matching every single possible number for
            -- some numeric type.  It should be handled more like Bool
            -- above.
            [Match ()] -> [[Match ()]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Match ()] -> [[Match ()]]) -> [Match ()] -> [[Match ()]]
forall a b. (a -> b) -> a -> b
$ () -> Match ()
forall t. t -> Match t
MatchWild () Match () -> [Match ()] -> [Match ()]
forall a. a -> [a] -> [a]
: [Match ()]
u
findUnmatched [] Int
n = [Int -> Match () -> [Match ()]
forall a. Int -> a -> [a]
replicate Int
n (Match () -> [Match ()]) -> Match () -> [Match ()]
forall a b. (a -> b) -> a -> b
$ () -> Match ()
forall t. t -> Match t
MatchWild ()]
findUnmatched [[Match StructType]]
_ Int
_ = []

{-# NOINLINE unmatched #-}

-- | Find the unmatched cases.
unmatched :: [Pat StructType] -> [Match ()]
unmatched :: [Pat StructType] -> [Match ()]
unmatched [Pat StructType]
orig_ps =
  -- The algorithm may find duplicate example, which we filter away
  -- here.
  [Match ()] -> [Match ()]
forall a. Ord a => [a] -> [a]
nubOrd ([Match ()] -> [Match ()]) -> [Match ()] -> [Match ()]
forall a b. (a -> b) -> a -> b
$
    ([Match ()] -> Maybe (Match ())) -> [[Match ()]] -> [Match ()]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Match ()] -> Maybe (Match ())
forall a. [a] -> Maybe a
maybeHead ([[Match ()]] -> [Match ()]) -> [[Match ()]] -> [Match ()]
forall a b. (a -> b) -> a -> b
$
      [[Match StructType]] -> Int -> [[Match ()]]
findUnmatched ((Pat StructType -> [Match StructType])
-> [Pat StructType] -> [[Match StructType]]
forall a b. (a -> b) -> [a] -> [b]
map (Match StructType -> [Match StructType]
forall a. a -> [a]
L.singleton (Match StructType -> [Match StructType])
-> (Pat StructType -> Match StructType)
-> Pat StructType
-> [Match StructType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat StructType -> Match StructType
patternToMatch) [Pat StructType]
orig_ps) Int
1