    -- | 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.Bifunctor (first)
    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 [(L 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)] -> Map Name (Pat StructType))
    -> [(Name, Pat StructType)] -> Map Name (Pat StructType)
    forall a b. (a -> b) -> a -> b
    $ ((L Name, Pat StructType) -> (Name, Pat StructType))
    -> [(L Name, Pat StructType)] -> [(Name, Pat StructType)]
    forall a b. (a -> b) -> [a] -> [b]
    map ((L Name -> Name)
    -> (L Name, Pat StructType) -> (Name, Pat StructType)
    forall a b c. (a -> b) -> (a, c) -> (b, c)
    forall (p :: * -> * -> *) a b c.
    Bifunctor p =>
    (a -> b) -> p a c -> p b c
    first L Name -> Name
    forall a. L a -> a
    unLoc) [(L 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