    {- Language/Haskell/TH/Desugar/Match.hs

    (c) Richard Eisenberg 2013
    rae@cs.brynmawr.edu

    Simplifies case statements in desugared TH. After this pass, there are no
    more nested patterns.

    This code is directly based on the analogous operation as written in GHC.
    -}

    {-# LANGUAGE CPP, TemplateHaskellQuotes #-}

    module Language.Haskell.TH.Desugar.Match (scExp, scLetDec) where

    import Prelude hiding ( fail, exp )

    import Control.Monad hiding ( fail )
    import qualified Control.Monad as Monad
    import Data.Data
    import qualified Data.Foldable as F
    import Data.Generics
    import qualified Data.List.NonEmpty as NE
    import Data.List.NonEmpty (NonEmpty(..))
    import qualified Data.Set as S
    import qualified Data.Map as Map
    import Language.Haskell.TH.Instances ()
    import Language.Haskell.TH.Syntax

    import Language.Haskell.TH.Desugar.AST
    import Language.Haskell.TH.Desugar.Core (dsReify, maybeDLetE, mkTupleDExp)
    import Language.Haskell.TH.Desugar.FV
    import qualified Language.Haskell.TH.Desugar.OSet as OS
    import Language.Haskell.TH.Desugar.Util
    import Language.Haskell.TH.Desugar.Reify

    -- | Remove all nested pattern-matches within this expression. This also
    -- removes all 'DTildePa's and 'DBangPa's. After this is run, every pattern
    -- is guaranteed to be either a 'DConPa' with bare variables as arguments,
    -- a 'DLitPa', or a 'DWildPa'.
    scExp :: DsMonad q => DExp -> q DExp
    scExp :: forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp (DAppE DExp
    e1 DExp
    e2) = DExp -> DExp -> DExp
    DAppE (DExp -> DExp -> DExp) -> q DExp -> q (DExp -> DExp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    e1 q (DExp -> DExp) -> q DExp -> q DExp
    forall a b. q (a -> b) -> q a -> q b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    e2
    scExp (DLamE [Name]
    names DExp
    exp) = [Name] -> DExp -> DExp
    DLamE [Name]
    names (DExp -> DExp) -> q DExp -> q DExp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    exp
    scExp (DCaseE DExp
    scrut [DMatch]
    matches)
      | DVarE Name
    name <- DExp
    scrut
      = [Name] -> [DClause] -> q DExp
    forall (q :: * -> *). DsMonad q => [Name] -> [DClause] -> q DExp
    simplCaseExp [Name
    name] [DClause]
    clauses
      | Bool
    otherwise
      = do scrut_name <- String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName String
    "scrut"
           case_exp <- simplCaseExp [scrut_name] clauses
           return $ DLetE [DValD (DVarP scrut_name) scrut] case_exp
      where
        clauses :: [DClause]
    clauses = (DMatch -> DClause) -> [DMatch] -> [DClause]
    forall a b. (a -> b) -> [a] -> [b]
    map DMatch -> DClause
    match_to_clause [DMatch]
    matches
        match_to_clause :: DMatch -> DClause
    match_to_clause (DMatch DPat
    pat DExp
    exp) = [DPat] -> DExp -> DClause
    DClause [DPat
    pat] DExp
    exp

    scExp (DLetE [DLetDec]
    decs DExp
    body) = [DLetDec] -> DExp -> DExp
    DLetE ([DLetDec] -> DExp -> DExp) -> q [DLetDec] -> q (DExp -> DExp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> (DLetDec -> q DLetDec) -> [DLetDec] -> q [DLetDec]
    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 DLetDec -> q DLetDec
    forall (q :: * -> *). DsMonad q => DLetDec -> q DLetDec
    scLetDec [DLetDec]
    decs q (DExp -> DExp) -> q DExp -> q DExp
    forall a b. q (a -> b) -> q a -> q b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    body
    scExp (DSigE DExp
    exp DType
    ty) = DExp -> DType -> DExp
    DSigE (DExp -> DType -> DExp) -> q DExp -> q (DType -> DExp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    exp q (DType -> DExp) -> q DType -> q DExp
    forall a b. q (a -> b) -> q a -> q b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> DType -> q DType
    forall a. a -> q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure DType
    ty
    scExp (DAppTypeE DExp
    exp DType
    ty) = DExp -> DType -> DExp
    DAppTypeE (DExp -> DType -> DExp) -> q DExp -> q (DType -> DExp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    exp q (DType -> DExp) -> q DType -> q DExp
    forall a b. q (a -> b) -> q a -> q b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> DType -> q DType
    forall a. a -> q a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure DType
    ty
    scExp (DTypedBracketE DExp
    exp) = DExp -> DExp
    DTypedBracketE (DExp -> DExp) -> q DExp -> q DExp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    exp
    scExp (DTypedSpliceE DExp
    exp) = DExp -> DExp
    DTypedSpliceE (DExp -> DExp) -> q DExp -> q DExp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    exp
    scExp e :: DExp
    e@(DVarE {}) = DExp -> q DExp
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DExp
    e
    scExp e :: DExp
    e@(DConE {}) = DExp -> q DExp
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DExp
    e
    scExp e :: DExp
    e@(DLitE {}) = DExp -> q DExp
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DExp
    e
    scExp e :: DExp
    e@(DStaticE {}) = DExp -> q DExp
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DExp
    e
    scExp e :: DExp
    e@(DTypeE {}) = DExp -> q DExp
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DExp
    e

    -- | Like 'scExp', but for a 'DLetDec'.
    scLetDec :: DsMonad q => DLetDec -> q DLetDec
    scLetDec :: forall (q :: * -> *). DsMonad q => DLetDec -> q DLetDec
    scLetDec (DFunD Name
    name clauses :: [DClause]
    clauses@(DClause [DPat]
    pats1 DExp
    _ : [DClause]
    _)) = do
      arg_names <- (DPat -> q Name) -> [DPat] -> q [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 (q Name -> DPat -> q Name
    forall a b. a -> b -> a
    const (String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName String
    "_arg")) [DPat]
    pats1
      clauses' <- mapM sc_clause_rhs clauses
      case_exp <- simplCaseExp arg_names clauses'
      return $ DFunD name [DClause (map DVarP arg_names) case_exp]
      where
        sc_clause_rhs :: DClause -> f DClause
    sc_clause_rhs (DClause [DPat]
    pats DExp
    exp) = [DPat] -> DExp -> DClause
    DClause [DPat]
    pats (DExp -> DClause) -> f DExp -> f DClause
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DExp -> f DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    exp
    scLetDec (DValD DPat
    pat DExp
    exp) = DPat -> DExp -> DLetDec
    DValD DPat
    pat (DExp -> DLetDec) -> q DExp -> q DLetDec
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp DExp
    exp
    scLetDec (DPragmaD DPragma
    prag) = DPragma -> DLetDec
    DPragmaD (DPragma -> DLetDec) -> q DPragma -> q DLetDec
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> DPragma -> q DPragma
    forall (q :: * -> *). DsMonad q => DPragma -> q DPragma
    scLetPragma DPragma
    prag
    scLetDec dec :: DLetDec
    dec@(DSigD {}) = DLetDec -> q DLetDec
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DLetDec
    dec
    scLetDec dec :: DLetDec
    dec@(DInfixD {}) = DLetDec -> q DLetDec
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DLetDec
    dec
    scLetDec dec :: DLetDec
    dec@(DFunD Name
    _ []) = DLetDec -> q DLetDec
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DLetDec
    dec

    scLetPragma :: DsMonad q => DPragma -> q DPragma
    scLetPragma :: forall (q :: * -> *). DsMonad q => DPragma -> q DPragma
    scLetPragma = (DExp -> q DExp) -> DPragma -> q DPragma
    forall a b (m :: * -> *).
    (Typeable a, Data b, Monad m) =>
    (a -> m a) -> b -> m b
    topEverywhereM DExp -> q DExp
    forall (q :: * -> *). DsMonad q => DExp -> q DExp
    scExp -- Only topEverywhereM because scExp already recurses on its own

    type MatchResult = DExp -> DExp

    matchResultToDExp :: MatchResult -> DExp
    matchResultToDExp :: (DExp -> DExp) -> DExp
    matchResultToDExp DExp -> DExp
    mr = DExp -> DExp
    mr DExp
    failed_pattern_match
      where
        failed_pattern_match :: DExp
    failed_pattern_match = DExp -> DExp -> DExp
    DAppE (Name -> DExp
    DVarE 'error)
                                     (Lit -> DExp
    DLitE (Lit -> DExp) -> Lit -> DExp
    forall a b. (a -> b) -> a -> b
    $ String -> Lit
    StringL String
    "Pattern-match failure")

    simplCaseExp :: DsMonad q
                 => [Name]
                 -> [DClause]
                 -> q DExp
    simplCaseExp :: forall (q :: * -> *). DsMonad q => [Name] -> [DClause] -> q DExp
    simplCaseExp [Name]
    vars [DClause]
    clauses =
      do let eis :: [EquationInfo]
    eis = [ NonEmpty DPat -> (DExp -> DExp) -> EquationInfo
    EquationInfo ([DPat] -> NonEmpty DPat
    to_ne_pats [DPat]
    pats) (\DExp
    _ -> DExp
    rhs) |
                     DClause [DPat]
    pats DExp
    rhs <- [DClause]
    clauses ]
         (DExp -> DExp) -> DExp
    matchResultToDExp ((DExp -> DExp) -> DExp) -> q (DExp -> DExp) -> q DExp
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    `liftM` [Name] -> [EquationInfo] -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    [Name] -> [EquationInfo] -> q (DExp -> DExp)
    simplCase [Name]
    vars [EquationInfo]
    eis
      where
        to_ne_pats :: [DPat] -> NonEmpty DPat
        to_ne_pats :: [DPat] -> NonEmpty DPat
    to_ne_pats [DPat]
    pats =
          case [DPat]
    pats of
            DPat
    p:[DPat]
    ps -> DPat
    pDPat -> [DPat] -> NonEmpty DPat
    forall a. a -> [a] -> NonEmpty a
    :|[DPat]
    ps
            [] -> String -> NonEmpty DPat
    forall a. HasCallStack => String -> a
    error String
    "Clause encountered with no patterns -- should never happen"

    data EquationInfo = EquationInfo (NonEmpty DPat) MatchResult  -- like DClause, but with a hole

    -- analogous to GHC's match (in deSugar/Match.lhs)
    simplCase :: DsMonad q
              => [Name]         -- the names of the scrutinees
              -> [EquationInfo] -- the matches (where the # of pats == length (1st arg))
              -> q MatchResult
    simplCase :: forall (q :: * -> *).
    DsMonad q =>
    [Name] -> [EquationInfo] -> q (DExp -> DExp)
    simplCase [] [EquationInfo]
    clauses = (DExp -> DExp) -> q (DExp -> DExp)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (((DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp)
    -> [DExp -> DExp] -> DExp -> DExp
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldr1 (DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    (.) [DExp -> DExp]
    match_results)
      where
        match_results :: [DExp -> DExp]
    match_results = [ DExp -> DExp
    mr | EquationInfo NonEmpty DPat
    _ DExp -> DExp
    mr <- [EquationInfo]
    clauses ]
    simplCase (Name
    v:[Name]
    vs) [EquationInfo]
    clauses = do
      (aux_binds, tidy_clauses) <- (EquationInfo -> q (DExp -> DExp, EquationInfo))
    -> [EquationInfo] -> q ([DExp -> DExp], [EquationInfo])
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> m (b, c)) -> [a] -> m ([b], [c])
    mapAndUnzipM (Name -> EquationInfo -> q (DExp -> DExp, EquationInfo)
    forall (q :: * -> *).
    DsMonad q =>
    Name -> EquationInfo -> q (DExp -> DExp, EquationInfo)
    tidyClause Name
    v) [EquationInfo]
    clauses
      let grouped = [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
    groupClauses [EquationInfo]
    tidy_clauses
      match_results <- match_groups grouped
      return (adjustMatchResult (foldr (.) id aux_binds) $
              foldr1 (.) match_results)
      where
        match_groups :: DsMonad q => [NonEmpty (PatGroup, EquationInfo)] -> q [MatchResult]
        match_groups :: forall (q :: * -> *).
    DsMonad q =>
    [NonEmpty (PatGroup, EquationInfo)] -> q [DExp -> DExp]
    match_groups [] = Name -> q [DExp -> DExp]
    forall (q :: * -> *). DsMonad q => Name -> q [DExp -> DExp]
    matchEmpty Name
    v
        match_groups [NonEmpty (PatGroup, EquationInfo)]
    gs = (NonEmpty (PatGroup, EquationInfo) -> q (DExp -> DExp))
    -> [NonEmpty (PatGroup, EquationInfo)] -> q [DExp -> DExp]
    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 NonEmpty (PatGroup, EquationInfo) -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    NonEmpty (PatGroup, EquationInfo) -> q (DExp -> DExp)
    match_group [NonEmpty (PatGroup, EquationInfo)]
    gs

        match_group :: DsMonad q => NonEmpty (PatGroup, EquationInfo) -> q MatchResult
        match_group :: forall (q :: * -> *).
    DsMonad q =>
    NonEmpty (PatGroup, EquationInfo) -> q (DExp -> DExp)
    match_group eqns :: NonEmpty (PatGroup, EquationInfo)
    eqns@((PatGroup
    group,EquationInfo
    _) :| [(PatGroup, EquationInfo)]
    _) =
          case PatGroup
    group of
            PgCon Name
    _ -> NonEmpty Name
    -> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    NonEmpty Name
    -> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
    matchConFamily NonEmpty Name
    vars (NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp))
    -> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
    forall a b. (a -> b) -> a -> b
    $ [(Name, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo)
    forall a.
    Ord a =>
    [(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo)
    subGroup [(Name
    c,EquationInfo
    e) | (PgCon Name
    c, EquationInfo
    e) <- NonEmpty (PatGroup, EquationInfo) -> [(PatGroup, EquationInfo)]
    forall a. NonEmpty a -> [a]
    NE.toList NonEmpty (PatGroup, EquationInfo)
    eqns]
            PgLit Lit
    _ -> NonEmpty Name
    -> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    NonEmpty Name
    -> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
    matchLiterals  NonEmpty Name
    vars (NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp))
    -> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
    forall a b. (a -> b) -> a -> b
    $ [(Lit, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo)
    forall a.
    Ord a =>
    [(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo)
    subGroup [(Lit
    l,EquationInfo
    e) | (PgLit Lit
    l, EquationInfo
    e) <- NonEmpty (PatGroup, EquationInfo) -> [(PatGroup, EquationInfo)]
    forall a. NonEmpty a -> [a]
    NE.toList NonEmpty (PatGroup, EquationInfo)
    eqns]
            PatGroup
    PgBang  -> NonEmpty Name -> NonEmpty EquationInfo -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    NonEmpty Name -> NonEmpty EquationInfo -> q (DExp -> DExp)
    matchBangs     NonEmpty Name
    vars (NonEmpty EquationInfo -> q (DExp -> DExp))
    -> NonEmpty EquationInfo -> q (DExp -> DExp)
    forall a b. (a -> b) -> a -> b
    $ NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
    drop_group NonEmpty (PatGroup, EquationInfo)
    eqns
            PatGroup
    PgAny   -> NonEmpty Name -> NonEmpty EquationInfo -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    NonEmpty Name -> NonEmpty EquationInfo -> q (DExp -> DExp)
    matchVariables NonEmpty Name
    vars (NonEmpty EquationInfo -> q (DExp -> DExp))
    -> NonEmpty EquationInfo -> q (DExp -> DExp)
    forall a b. (a -> b) -> a -> b
    $ NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
    drop_group NonEmpty (PatGroup, EquationInfo)
    eqns

        drop_group :: NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
        drop_group :: NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
    drop_group = ((PatGroup, EquationInfo) -> EquationInfo)
    -> NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (PatGroup, EquationInfo) -> EquationInfo
    forall a b. (a, b) -> b
    snd

        vars :: NonEmpty Name
    vars = Name
    vName -> [Name] -> NonEmpty Name
    forall a. a -> [a] -> NonEmpty a
    :|[Name]
    vs

    -- analogous to GHC's tidyEqnInfo
    tidyClause :: DsMonad q => Name -> EquationInfo -> q (DExp -> DExp, EquationInfo)
    tidyClause :: forall (q :: * -> *).
    DsMonad q =>
    Name -> EquationInfo -> q (DExp -> DExp, EquationInfo)
    tidyClause Name
    v (EquationInfo (DPat
    pat :| [DPat]
    pats) DExp -> DExp
    body) = do
      (wrap, pat') <- Name -> DPat -> q (DExp -> DExp, DPat)
    forall (q :: * -> *).
    DsMonad q =>
    Name -> DPat -> q (DExp -> DExp, DPat)
    tidy1 Name
    v DPat
    pat
      return (wrap, EquationInfo (pat' :| pats) body)

    tidy1 :: DsMonad q
          => Name   -- the name of the variable that ...
          -> DPat   -- ... this pattern is matching against
          -> q (DExp -> DExp, DPat)   -- a wrapper and tidied pattern
    tidy1 :: forall (q :: * -> *).
    DsMonad q =>
    Name -> DPat -> q (DExp -> DExp, DPat)
    tidy1 Name
    _ p :: DPat
    p@(DLitP {}) = (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> DExp
    forall a. a -> a
    id, DPat
    p)
    tidy1 Name
    v (DVarP Name
    var) = (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> Name -> DExp -> DExp
    wrapBind Name
    var Name
    v, DPat
    DWildP)
    tidy1 Name
    _ p :: DPat
    p@(DConP {}) = (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> DExp
    forall a. a -> a
    id, DPat
    p)
    tidy1 Name
    v (DTildeP DPat
    pat) = do
      sel_decs <- DPat -> Name -> q [DLetDec]
    forall (q :: * -> *). DsMonad q => DPat -> Name -> q [DLetDec]
    mkSelectorDecs DPat
    pat Name
    v
      return (maybeDLetE sel_decs, DWildP)
    tidy1 Name
    v (DBangP DPat
    pat) =
      case DPat
    pat of
        DLitP Lit
    _   -> Name -> DPat -> q (DExp -> DExp, DPat)
    forall (q :: * -> *).
    DsMonad q =>
    Name -> DPat -> q (DExp -> DExp, DPat)
    tidy1 Name
    v DPat
    pat   -- already strict
        DVarP Name
    _   -> (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> DExp
    forall a. a -> a
    id, DPat -> DPat
    DBangP DPat
    pat)  -- no change
        DConP{}   -> Name -> DPat -> q (DExp -> DExp, DPat)
    forall (q :: * -> *).
    DsMonad q =>
    Name -> DPat -> q (DExp -> DExp, DPat)
    tidy1 Name
    v DPat
    pat   -- already strict
        DTildeP DPat
    p -> Name -> DPat -> q (DExp -> DExp, DPat)
    forall (q :: * -> *).
    DsMonad q =>
    Name -> DPat -> q (DExp -> DExp, DPat)
    tidy1 Name
    v (DPat -> DPat
    DBangP DPat
    p) -- discard ~ under !
        DBangP DPat
    p  -> Name -> DPat -> q (DExp -> DExp, DPat)
    forall (q :: * -> *).
    DsMonad q =>
    Name -> DPat -> q (DExp -> DExp, DPat)
    tidy1 Name
    v (DPat -> DPat
    DBangP DPat
    p) -- discard ! under !
        DSigP DPat
    p DType
    _ -> Name -> DPat -> q (DExp -> DExp, DPat)
    forall (q :: * -> *).
    DsMonad q =>
    Name -> DPat -> q (DExp -> DExp, DPat)
    tidy1 Name
    v (DPat -> DPat
    DBangP DPat
    p) -- discard sig under !
        DPat
    DWildP    -> (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> DExp
    forall a. a -> a
    id, DPat -> DPat
    DBangP DPat
    pat)  -- no change
        DTypeP DType
    _  -> (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> DExp
    forall a. a -> a
    id, DPat -> DPat
    DBangP DPat
    pat)  -- no change
        DInvisP DType
    _ -> (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> DExp
    forall a. a -> a
    id, DPat -> DPat
    DBangP DPat
    pat)  -- no change
    tidy1 Name
    v (DSigP DPat
    pat DType
    ty)
      | DType -> Bool
    forall a. Data a => a -> Bool
    no_tyvars_ty DType
    ty = Name -> DPat -> q (DExp -> DExp, DPat)
    forall (q :: * -> *).
    DsMonad q =>
    Name -> DPat -> q (DExp -> DExp, DPat)
    tidy1 Name
    v DPat
    pat
      -- The match-flattener doesn't know how to deal with patterns that mention
      -- type variables properly, so we give up if we encounter one.
      -- See https://github.com/goldfirere/th-desugar/pull/48#issuecomment-266778976
      -- for further discussion.
      | Bool
    otherwise = String -> q (DExp -> DExp, DPat)
    forall a. String -> q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    Monad.fail
        String
    "Match-flattening patterns that mention type variables is not supported."
      where
        no_tyvars_ty :: Data a => a -> Bool
        no_tyvars_ty :: forall a. Data a => a -> Bool
    no_tyvars_ty = (Bool -> Bool -> Bool)
    -> (forall a. Data a => a -> Bool) -> forall a. Data a => a -> Bool
    forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
    everything Bool -> Bool -> Bool
    (&&) (Bool -> (DType -> Bool) -> a -> Bool
    forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
    mkQ Bool
    True DType -> Bool
    no_tyvar_ty)

        no_tyvar_ty :: DType -> Bool
        no_tyvar_ty :: DType -> Bool
    no_tyvar_ty (DVarT{}) = Bool
    False
        no_tyvar_ty DType
    t         = (Bool -> Bool -> Bool)
    -> Bool -> (forall a. Data a => a -> Bool) -> DType -> Bool
    forall a r r'.
    Data a =>
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
    forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> DType -> r
    gmapQl Bool -> Bool -> Bool
    (&&) Bool
    True d -> Bool
    forall a. Data a => a -> Bool
    no_tyvars_ty DType
    t
    tidy1 Name
    _ DPat
    DWildP = (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> DExp
    forall a. a -> a
    id, DPat
    DWildP)
    tidy1 Name
    _ (DTypeP DType
    ty) = (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> DExp
    forall a. a -> a
    id, DType -> DPat
    DTypeP DType
    ty)
    tidy1 Name
    _ (DInvisP DType
    ty) = (DExp -> DExp, DPat) -> q (DExp -> DExp, DPat)
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DExp -> DExp
    forall a. a -> a
    id, DType -> DPat
    DInvisP DType
    ty)

    wrapBind :: Name -> Name -> DExp -> DExp
    wrapBind :: Name -> Name -> DExp -> DExp
    wrapBind Name
    new Name
    old
      | Name
    new Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    old = DExp -> DExp
    forall a. a -> a
    id
      | Bool
    otherwise  = [DLetDec] -> DExp -> DExp
    DLetE [DPat -> DExp -> DLetDec
    DValD (Name -> DPat
    DVarP Name
    new) (Name -> DExp
    DVarE Name
    old)]

    -- like GHC's mkSelectorBinds
    mkSelectorDecs :: DsMonad q
                   => DPat      -- pattern to deconstruct
                   -> Name      -- variable being matched against
                   -> q [DLetDec]
    mkSelectorDecs :: forall (q :: * -> *). DsMonad q => DPat -> Name -> q [DLetDec]
    mkSelectorDecs (DVarP Name
    v) Name
    name = [DLetDec] -> q [DLetDec]
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [DPat -> DExp -> DLetDec
    DValD (Name -> DPat
    DVarP Name
    v) (Name -> DExp
    DVarE Name
    name)]
    mkSelectorDecs DPat
    pat Name
    name
      | OSet Name -> Bool
    forall a. OSet a -> Bool
    OS.null OSet Name
    binders
      = [DLetDec] -> q [DLetDec]
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

      | [Name
    binder] <- OSet Name -> [Name]
    forall a. OSet a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    F.toList OSet Name
    binders
      = do val_var <- String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName String
    "var"
           err_var <- newUniqueName "err"
           bind    <- mk_bind val_var err_var binder
           return [DValD (DVarP val_var) (DVarE name),
                   DValD (DVarP err_var) (DVarE 'error `DAppE`
                                           (DLitE $ StringL "Irrefutable match failed")),
                   bind]

      | Bool
    otherwise
      = do tuple_expr <- [Name] -> [DClause] -> q DExp
    forall (q :: * -> *). DsMonad q => [Name] -> [DClause] -> q DExp
    simplCaseExp [Name
    name] [[DPat] -> DExp -> DClause
    DClause [DPat
    pat] DExp
    local_tuple]
           tuple_var <- newUniqueName "tuple"
           projections <- mapM (mk_projection tuple_var) [0 .. tuple_size-1]
           return (DValD (DVarP tuple_var) tuple_expr :
                   zipWith DValD (map DVarP binders_list) projections)

      where
        binders :: OSet Name
    binders = DPat -> OSet Name
    extractBoundNamesDPat DPat
    pat
        binders_list :: [Name]
    binders_list = OSet Name -> [Name]
    forall a. OSet a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    F.toList OSet Name
    binders
        tuple_size :: Int
    tuple_size = [Name] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Name]
    binders_list
        local_tuple :: DExp
    local_tuple = [DExp] -> DExp
    mkTupleDExp ((Name -> DExp) -> [Name] -> [DExp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> DExp
    DVarE [Name]
    binders_list)

        mk_projection :: DsMonad q
                      => Name   -- of the tuple
                      -> Int    -- which element to get (0-indexed)
                      -> q DExp
        mk_projection :: forall (q :: * -> *). DsMonad q => Name -> Int -> q DExp
    mk_projection Name
    tup_name Int
    i = do
          var_name <- String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName String
    "proj"
          return $ DCaseE (DVarE tup_name) [DMatch (DConP (tupleDataName tuple_size) [] (mk_tuple_pats var_name i))
                                                   (DVarE var_name)]

        mk_tuple_pats :: Name   -- of the projected element
                      -> Int    -- which element to get (0-indexed)
                      -> [DPat]
        mk_tuple_pats :: Name -> Int -> [DPat]
    mk_tuple_pats Name
    elt_name Int
    i = Int -> DPat -> [DPat]
    forall a. Int -> a -> [a]
    replicate Int
    i DPat
    DWildP [DPat] -> [DPat] -> [DPat]
    forall a. [a] -> [a] -> [a]
    ++ Name -> DPat
    DVarP Name
    elt_name DPat -> [DPat] -> [DPat]
    forall a. a -> [a] -> [a]
    : Int -> DPat -> [DPat]
    forall a. Int -> a -> [a]
    replicate (Int
    tuple_size Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    i Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) DPat
    DWildP

        mk_bind :: Name -> Name -> Name -> m DLetDec
    mk_bind Name
    scrut_var Name
    err_var Name
    bndr_var = do
          rhs_mr <- [Name] -> [EquationInfo] -> m (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    [Name] -> [EquationInfo] -> q (DExp -> DExp)
    simplCase [Name
    scrut_var] [NonEmpty DPat -> (DExp -> DExp) -> EquationInfo
    EquationInfo (DPat
    patDPat -> [DPat] -> NonEmpty DPat
    forall a. a -> [a] -> NonEmpty a
    :|[]) (\DExp
    _ -> Name -> DExp
    DVarE Name
    bndr_var)]
          return (DValD (DVarP bndr_var) (rhs_mr (DVarE err_var)))

    data PatGroup
      = PgAny         -- immediate match (wilds, vars, lazies)
      | PgCon Name
      | PgLit Lit
      | PgBang

    -- like GHC's groupEquations
    groupClauses :: [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
    groupClauses :: [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
    groupClauses [EquationInfo]
    clauses
      = ((PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool)
    -> [(PatGroup, EquationInfo)]
    -> [NonEmpty (PatGroup, EquationInfo)]
    forall (f :: * -> *) a.
    Foldable f =>
    (a -> a -> Bool) -> f a -> [NonEmpty a]
    NE.groupBy (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool
    same_gp [(DPat -> PatGroup
    patGroup (EquationInfo -> DPat
    firstPat EquationInfo
    clause), EquationInfo
    clause) | EquationInfo
    clause <- [EquationInfo]
    clauses]
      where
        same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool
        (PatGroup
    pg1,EquationInfo
    _) same_gp :: (PatGroup, EquationInfo) -> (PatGroup, EquationInfo) -> Bool
    `same_gp` (PatGroup
    pg2,EquationInfo
    _) = PatGroup
    pg1 PatGroup -> PatGroup -> Bool
    `sameGroup` PatGroup
    pg2

    patGroup :: DPat -> PatGroup
    patGroup :: DPat -> PatGroup
    patGroup (DLitP Lit
    l)       = Lit -> PatGroup
    PgLit Lit
    l
    patGroup (DVarP {})      = String -> PatGroup
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (patGroup DVarP)"
    patGroup (DConP Name
    con [DType]
    _ [DPat]
    _) = Name -> PatGroup
    PgCon Name
    con
    patGroup (DTildeP {})    = String -> PatGroup
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (patGroup DTildeP)"
    patGroup (DBangP {})     = PatGroup
    PgBang
    patGroup (DSigP{})       = String -> PatGroup
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (patGroup DSigP)"
    patGroup DPat
    DWildP          = PatGroup
    PgAny
    patGroup (DTypeP {})     = PatGroup
    PgAny
    patGroup (DInvisP {})    = PatGroup
    PgAny

    sameGroup :: PatGroup -> PatGroup -> Bool
    sameGroup :: PatGroup -> PatGroup -> Bool
    sameGroup PatGroup
    PgAny     PatGroup
    PgAny     = Bool
    True
    sameGroup PatGroup
    PgBang    PatGroup
    PgBang    = Bool
    True
    sameGroup (PgCon Name
    _) (PgCon Name
    _) = Bool
    True
    sameGroup (PgLit Lit
    _) (PgLit Lit
    _) = Bool
    True
    sameGroup PatGroup
    _         PatGroup
    _         = Bool
    False

    -- Precondition: the input list contains at least one element.
    subGroup :: Ord a => [(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo)
    subGroup :: forall a.
    Ord a =>
    [(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo)
    subGroup [(a, EquationInfo)]
    group
      = case (NonEmpty EquationInfo -> NonEmpty EquationInfo)
    -> [NonEmpty EquationInfo] -> [NonEmpty EquationInfo]
    forall a b. (a -> b) -> [a] -> [b]
    map NonEmpty EquationInfo -> NonEmpty EquationInfo
    forall a. NonEmpty a -> NonEmpty a
    NE.reverse ([NonEmpty EquationInfo] -> [NonEmpty EquationInfo])
    -> [NonEmpty EquationInfo] -> [NonEmpty EquationInfo]
    forall a b. (a -> b) -> a -> b
    $ Map a (NonEmpty EquationInfo) -> [NonEmpty EquationInfo]
    forall k a. Map k a -> [a]
    Map.elems (Map a (NonEmpty EquationInfo) -> [NonEmpty EquationInfo])
    -> Map a (NonEmpty EquationInfo) -> [NonEmpty EquationInfo]
    forall a b. (a -> b) -> a -> b
    $ (Map a (NonEmpty EquationInfo)
     -> (a, EquationInfo) -> Map a (NonEmpty EquationInfo))
    -> Map a (NonEmpty EquationInfo)
    -> [(a, EquationInfo)]
    -> Map a (NonEmpty EquationInfo)
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Map a (NonEmpty EquationInfo)
    -> (a, EquationInfo) -> Map a (NonEmpty EquationInfo)
    forall {k} {a}.
    Ord k =>
    Map k (NonEmpty a) -> (k, a) -> Map k (NonEmpty a)
    accumulate Map a (NonEmpty EquationInfo)
    forall k a. Map k a
    Map.empty [(a, EquationInfo)]
    group of
          NonEmpty EquationInfo
    e:[NonEmpty EquationInfo]
    es -> NonEmpty EquationInfo
    eNonEmpty EquationInfo
    -> [NonEmpty EquationInfo] -> NonEmpty (NonEmpty EquationInfo)
    forall a. a -> [a] -> NonEmpty a
    :|[NonEmpty EquationInfo]
    es
          [] -> String -> NonEmpty (NonEmpty EquationInfo)
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (subGroup)"
      where
        accumulate :: Map k (NonEmpty a) -> (k, a) -> Map k (NonEmpty a)
    accumulate Map k (NonEmpty a)
    pg_map (k
    pg, a
    eqn)
          = case k -> Map k (NonEmpty a) -> Maybe (NonEmpty a)
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup k
    pg Map k (NonEmpty a)
    pg_map of
              Just NonEmpty a
    eqns -> k -> NonEmpty a -> Map k (NonEmpty a) -> Map k (NonEmpty a)
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert k
    pg (a -> NonEmpty a -> NonEmpty a
    forall a. a -> NonEmpty a -> NonEmpty a
    NE.cons a
    eqn NonEmpty a
    eqns) Map k (NonEmpty a)
    pg_map
              Maybe (NonEmpty a)
    Nothing   -> k -> NonEmpty a -> Map k (NonEmpty a) -> Map k (NonEmpty a)
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    Map.insert k
    pg (a
    eqn a -> [a] -> NonEmpty a
    forall a. a -> [a] -> NonEmpty a
    :| [])        Map k (NonEmpty a)
    pg_map

    firstPat :: EquationInfo -> DPat
    firstPat :: EquationInfo -> DPat
    firstPat (EquationInfo (DPat
    pat :| [DPat]
    _) DExp -> DExp
    _) = DPat
    pat

    data CaseAlt = CaseAlt { CaseAlt -> Name
    alt_con  :: Name         -- con name
                           , CaseAlt -> [Name]
    _alt_args :: [Name]       -- bound var names
                           , CaseAlt -> DExp -> DExp
    _alt_rhs  :: MatchResult  -- RHS
                           }

    -- from GHC's MatchCon.lhs
    matchConFamily :: DsMonad q => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult
    matchConFamily :: forall (q :: * -> *).
    DsMonad q =>
    NonEmpty Name
    -> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
    matchConFamily (Name
    var:|[Name]
    vars) NonEmpty (NonEmpty EquationInfo)
    groups
      = do alts <- (NonEmpty EquationInfo -> q CaseAlt)
    -> NonEmpty (NonEmpty EquationInfo) -> q (NonEmpty CaseAlt)
    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) -> NonEmpty a -> m (NonEmpty b)
    mapM ([Name] -> NonEmpty EquationInfo -> q CaseAlt
    forall (q :: * -> *).
    DsMonad q =>
    [Name] -> NonEmpty EquationInfo -> q CaseAlt
    matchOneCon [Name]
    vars) NonEmpty (NonEmpty EquationInfo)
    groups
           mkDataConCase var alts

    -- like matchOneConLike from MatchCon
    matchOneCon :: DsMonad q => [Name] -> NonEmpty EquationInfo -> q CaseAlt
    matchOneCon :: forall (q :: * -> *).
    DsMonad q =>
    [Name] -> NonEmpty EquationInfo -> q CaseAlt
    matchOneCon [Name]
    vars eqns :: NonEmpty EquationInfo
    eqns@(EquationInfo
    eqn1 :| [EquationInfo]
    _)
      = do arg_vars <- [DPat] -> q [Name]
    forall (q :: * -> *). DsMonad q => [DPat] -> q [Name]
    selectMatchVars (DPat -> [DPat]
    pat_args DPat
    pat1)
           match_result <- match_group arg_vars

           return $ CaseAlt (pat_con pat1) arg_vars match_result
      where
        pat1 :: DPat
    pat1 = EquationInfo -> DPat
    firstPat EquationInfo
    eqn1

        pat_args :: DPat -> [DPat]
    pat_args (DConP Name
    _ [DType]
    _ [DPat]
    pats) = [DPat]
    pats
        pat_args DPat
    _                = String -> [DPat]
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (pat_args)"

        pat_con :: DPat -> Name
    pat_con (DConP Name
    con [DType]
    _ [DPat]
    _) = Name
    con
        pat_con DPat
    _               = String -> Name
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (pat_con)"

        match_group :: DsMonad q => [Name] -> q MatchResult
        match_group :: forall (q :: * -> *). DsMonad q => [Name] -> q (DExp -> DExp)
    match_group [Name]
    arg_vars
          = [Name] -> [EquationInfo] -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    [Name] -> [EquationInfo] -> q (DExp -> DExp)
    simplCase ([Name]
    arg_vars [Name] -> [Name] -> [Name]
    forall a. [a] -> [a] -> [a]
    ++ [Name]
    vars) ([EquationInfo] -> q (DExp -> DExp))
    -> [EquationInfo] -> q (DExp -> DExp)
    forall a b. (a -> b) -> a -> b
    $ NonEmpty EquationInfo -> [EquationInfo]
    forall a. NonEmpty a -> [a]
    NE.toList (NonEmpty EquationInfo -> [EquationInfo])
    -> NonEmpty EquationInfo -> [EquationInfo]
    forall a b. (a -> b) -> a -> b
    $ (EquationInfo -> EquationInfo)
    -> NonEmpty EquationInfo -> NonEmpty EquationInfo
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap EquationInfo -> EquationInfo
    shift NonEmpty EquationInfo
    eqns

        shift :: EquationInfo -> EquationInfo
    shift (EquationInfo (DConP Name
    _ [DType]
    _ [DPat]
    args :| [DPat]
    pats) DExp -> DExp
    exp)
          = NonEmpty DPat -> (DExp -> DExp) -> EquationInfo
    EquationInfo ([DPat] -> NonEmpty DPat
    to_ne_pats ([DPat]
    args [DPat] -> [DPat] -> [DPat]
    forall a. [a] -> [a] -> [a]
    ++ [DPat]
    pats)) DExp -> DExp
    exp
        shift EquationInfo
    _ = String -> EquationInfo
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (shift)"

        to_ne_pats :: [DPat] -> NonEmpty DPat
        to_ne_pats :: [DPat] -> NonEmpty DPat
    to_ne_pats [DPat]
    pats =
          case [DPat]
    pats of
            DPat
    p:[DPat]
    ps -> DPat
    pDPat -> [DPat] -> NonEmpty DPat
    forall a. a -> [a] -> NonEmpty a
    :|[DPat]
    ps
            [] -> String -> NonEmpty DPat
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (matchOneCon.to_ne_pats)"

    mkDataConCase :: DsMonad q => Name -> NonEmpty CaseAlt -> q MatchResult
    mkDataConCase :: forall (q :: * -> *).
    DsMonad q =>
    Name -> NonEmpty CaseAlt -> q (DExp -> DExp)
    mkDataConCase Name
    var NonEmpty CaseAlt
    case_alts = do
      all_ctors <- Name -> q (Set Name)
    forall (q :: * -> *). DsMonad q => Name -> q (Set Name)
    get_all_ctors (CaseAlt -> Name
    alt_con (CaseAlt -> Name) -> CaseAlt -> Name
    forall a b. (a -> b) -> a -> b
    $ NonEmpty CaseAlt -> CaseAlt
    forall a. NonEmpty a -> a
    NE.head NonEmpty CaseAlt
    case_alts)
      return $ \DExp
    fail ->
        let matches :: [DMatch]
    matches = (CaseAlt -> DMatch) -> [CaseAlt] -> [DMatch]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (DExp -> CaseAlt -> DMatch
    mk_alt DExp
    fail) [CaseAlt]
    case_alt_list in
        DExp -> [DMatch] -> DExp
    DCaseE (Name -> DExp
    DVarE Name
    var) ([DMatch]
    matches [DMatch] -> [DMatch] -> [DMatch]
    forall a. [a] -> [a] -> [a]
    ++ Set Name -> DExp -> [DMatch]
    mk_default Set Name
    all_ctors DExp
    fail)
      where
        case_alt_list :: [CaseAlt]
    case_alt_list = NonEmpty CaseAlt -> [CaseAlt]
    forall a. NonEmpty a -> [a]
    NE.toList NonEmpty CaseAlt
    case_alts

        mk_alt :: DExp -> CaseAlt -> DMatch
    mk_alt DExp
    fail (CaseAlt Name
    con [Name]
    args DExp -> DExp
    body_fn)
          = let body :: DExp
    body = DExp -> DExp
    body_fn DExp
    fail in
            DPat -> DExp -> DMatch
    DMatch (Name -> [DType] -> [DPat] -> DPat
    DConP Name
    con [] ((Name -> DPat) -> [Name] -> [DPat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> DPat
    DVarP [Name]
    args)) DExp
    body

        mk_default :: Set Name -> DExp -> [DMatch]
    mk_default Set Name
    all_ctors DExp
    fail | Set Name -> Bool
    exhaustive_case Set Name
    all_ctors = []
                                  | Bool
    otherwise       = [DPat -> DExp -> DMatch
    DMatch DPat
    DWildP DExp
    fail]

        mentioned_ctors :: Set Name
    mentioned_ctors = [Name] -> Set Name
    forall a. Ord a => [a] -> Set a
    S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
    forall a b. (a -> b) -> a -> b
    $ (CaseAlt -> Name) -> [CaseAlt] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map CaseAlt -> Name
    alt_con [CaseAlt]
    case_alt_list
        exhaustive_case :: Set Name -> Bool
    exhaustive_case Set Name
    all_ctors = Set Name
    all_ctors Set Name -> Set Name -> Bool
    forall a. Ord a => Set a -> Set a -> Bool
    `S.isSubsetOf` Set Name
    mentioned_ctors

        get_all_ctors :: DsMonad q => Name -> q (S.Set Name)
        get_all_ctors :: forall (q :: * -> *). DsMonad q => Name -> q (Set Name)
    get_all_ctors Name
    con_name = do
          ty_name <- Name -> q Name
    forall (q :: * -> *). DsMonad q => Name -> q Name
    dataConNameToDataName Name
    con_name
          Just (DTyConI tycon_dec _) <- dsReify ty_name
          return $ S.fromList $ map get_con_name $ get_cons tycon_dec

        get_cons :: DDec -> [DCon]
    get_cons (DDataD DataFlavor
    _ [DType]
    _ Name
    _ [DTyVarBndrVis]
    _ Maybe DType
    _ [DCon]
    cons [DDerivClause]
    _)     = [DCon]
    cons
        get_cons (DDataInstD DataFlavor
    _ [DType]
    _ Maybe [DTyVarBndrUnit]
    _ DType
    _ Maybe DType
    _ [DCon]
    cons [DDerivClause]
    _) = [DCon]
    cons
        get_cons DDec
    _                             = []

        get_con_name :: DCon -> Name
    get_con_name (DCon [DTyVarBndrSpec]
    _ [DType]
    _ Name
    n DConFields
    _ DType
    _) = Name
    n

    matchEmpty :: DsMonad q => Name -> q [MatchResult]
    matchEmpty :: forall (q :: * -> *). DsMonad q => Name -> q [DExp -> DExp]
    matchEmpty Name
    var = [DExp -> DExp] -> q [DExp -> DExp]
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [DExp -> DExp
    mk_seq]
      where
        mk_seq :: DExp -> DExp
    mk_seq DExp
    fail = DExp -> [DMatch] -> DExp
    DCaseE (Name -> DExp
    DVarE Name
    var) [DPat -> DExp -> DMatch
    DMatch DPat
    DWildP DExp
    fail]

    matchLiterals :: DsMonad q => NonEmpty Name -> NonEmpty (NonEmpty EquationInfo) -> q MatchResult
    matchLiterals :: forall (q :: * -> *).
    DsMonad q =>
    NonEmpty Name
    -> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
    matchLiterals (Name
    var:|[Name]
    vars) NonEmpty (NonEmpty EquationInfo)
    sub_groups
      = do alts <- (NonEmpty EquationInfo -> q (Lit, DExp -> DExp))
    -> NonEmpty (NonEmpty EquationInfo)
    -> q (NonEmpty (Lit, DExp -> DExp))
    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) -> NonEmpty a -> m (NonEmpty b)
    mapM NonEmpty EquationInfo -> q (Lit, DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    NonEmpty EquationInfo -> q (Lit, DExp -> DExp)
    match_group NonEmpty (NonEmpty EquationInfo)
    sub_groups
           return (mkCoPrimCaseMatchResult var alts)
      where
        match_group :: DsMonad q => NonEmpty EquationInfo -> q (Lit, MatchResult)
        match_group :: forall (q :: * -> *).
    DsMonad q =>
    NonEmpty EquationInfo -> q (Lit, DExp -> DExp)
    match_group NonEmpty EquationInfo
    eqns
          = do let lit :: Lit
    lit = case EquationInfo -> DPat
    firstPat (NonEmpty EquationInfo -> EquationInfo
    forall a. NonEmpty a -> a
    NE.head NonEmpty EquationInfo
    eqns) of
                           DLitP Lit
    lit' -> Lit
    lit'
                           DPat
    _          -> String -> Lit
    forall a. HasCallStack => String -> a
    error (String -> Lit) -> String -> Lit
    forall a b. (a -> b) -> a -> b
    $ String
    "Internal error in th-desugar "
                                              String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "(matchLiterals.match_group)"
               match_result <- [Name] -> [EquationInfo] -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    [Name] -> [EquationInfo] -> q (DExp -> DExp)
    simplCase [Name]
    vars ([EquationInfo] -> q (DExp -> DExp))
    -> [EquationInfo] -> q (DExp -> DExp)
    forall a b. (a -> b) -> a -> b
    $ NonEmpty EquationInfo -> [EquationInfo]
    forall a. NonEmpty a -> [a]
    NE.toList (NonEmpty EquationInfo -> [EquationInfo])
    -> NonEmpty EquationInfo -> [EquationInfo]
    forall a b. (a -> b) -> a -> b
    $ NonEmpty EquationInfo -> NonEmpty EquationInfo
    shiftEqns NonEmpty EquationInfo
    eqns
               return (lit, match_result)

    mkCoPrimCaseMatchResult :: Name -- Scrutinee
                            -> NonEmpty (Lit, MatchResult)
                            -> MatchResult
    mkCoPrimCaseMatchResult :: Name -> NonEmpty (Lit, DExp -> DExp) -> DExp -> DExp
    mkCoPrimCaseMatchResult Name
    var NonEmpty (Lit, DExp -> DExp)
    match_alts = DExp -> DExp
    mk_case
      where
        mk_case :: DExp -> DExp
    mk_case DExp
    fail = let alts :: [DMatch]
    alts = NonEmpty DMatch -> [DMatch]
    forall a. NonEmpty a -> [a]
    NE.toList (NonEmpty DMatch -> [DMatch]) -> NonEmpty DMatch -> [DMatch]
    forall a b. (a -> b) -> a -> b
    $ ((Lit, DExp -> DExp) -> DMatch)
    -> NonEmpty (Lit, DExp -> DExp) -> NonEmpty DMatch
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (DExp -> (Lit, DExp -> DExp) -> DMatch
    forall {t}. t -> (Lit, t -> DExp) -> DMatch
    mk_alt DExp
    fail) NonEmpty (Lit, DExp -> DExp)
    match_alts in
                       DExp -> [DMatch] -> DExp
    DCaseE (Name -> DExp
    DVarE Name
    var) ([DMatch]
    alts [DMatch] -> [DMatch] -> [DMatch]
    forall a. [a] -> [a] -> [a]
    ++ [DPat -> DExp -> DMatch
    DMatch DPat
    DWildP DExp
    fail])
        mk_alt :: t -> (Lit, t -> DExp) -> DMatch
    mk_alt t
    fail (Lit
    lit, t -> DExp
    body_fn)
          = DPat -> DExp -> DMatch
    DMatch (Lit -> DPat
    DLitP Lit
    lit) (t -> DExp
    body_fn t
    fail)

    matchBangs :: DsMonad q => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult
    matchBangs :: forall (q :: * -> *).
    DsMonad q =>
    NonEmpty Name -> NonEmpty EquationInfo -> q (DExp -> DExp)
    matchBangs (Name
    var:|[Name]
    vars) NonEmpty EquationInfo
    eqns
      = do match_result <- [Name] -> [EquationInfo] -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    [Name] -> [EquationInfo] -> q (DExp -> DExp)
    simplCase (Name
    varName -> [Name] -> [Name]
    forall a. a -> [a] -> [a]
    :[Name]
    vars) ([EquationInfo] -> q (DExp -> DExp))
    -> [EquationInfo] -> q (DExp -> DExp)
    forall a b. (a -> b) -> a -> b
    $ NonEmpty EquationInfo -> [EquationInfo]
    forall a. NonEmpty a -> [a]
    NE.toList (NonEmpty EquationInfo -> [EquationInfo])
    -> NonEmpty EquationInfo -> [EquationInfo]
    forall a b. (a -> b) -> a -> b
    $
                           (EquationInfo -> EquationInfo)
    -> NonEmpty EquationInfo -> NonEmpty EquationInfo
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((DPat -> DPat) -> EquationInfo -> EquationInfo
    decomposeFirstPat DPat -> DPat
    getBangPat) NonEmpty EquationInfo
    eqns
           return (mkEvalMatchResult var match_result)

    decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo
    decomposeFirstPat :: (DPat -> DPat) -> EquationInfo -> EquationInfo
    decomposeFirstPat DPat -> DPat
    extractpat (EquationInfo (DPat
    pat:|[DPat]
    pats) DExp -> DExp
    body)
      = NonEmpty DPat -> (DExp -> DExp) -> EquationInfo
    EquationInfo (DPat -> DPat
    extractpat DPat
    pat DPat -> [DPat] -> NonEmpty DPat
    forall a. a -> [a] -> NonEmpty a
    :| [DPat]
    pats) DExp -> DExp
    body

    getBangPat :: DPat -> DPat
    getBangPat :: DPat -> DPat
    getBangPat (DBangP DPat
    p) = DPat
    p
    getBangPat DPat
    _          = String -> DPat
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (getBangPat)"

    mkEvalMatchResult :: Name -> MatchResult -> MatchResult
    mkEvalMatchResult :: Name -> (DExp -> DExp) -> DExp -> DExp
    mkEvalMatchResult Name
    var DExp -> DExp
    body_fn DExp
    fail
      = (DExp -> DExp -> DExp) -> DExp -> [DExp] -> DExp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl DExp -> DExp -> DExp
    DAppE (Name -> DExp
    DVarE 'seq) [Name -> DExp
    DVarE Name
    var, DExp -> DExp
    body_fn DExp
    fail]

    matchVariables :: DsMonad q => NonEmpty Name -> NonEmpty EquationInfo -> q MatchResult
    matchVariables :: forall (q :: * -> *).
    DsMonad q =>
    NonEmpty Name -> NonEmpty EquationInfo -> q (DExp -> DExp)
    matchVariables (Name
    _:|[Name]
    vars) NonEmpty EquationInfo
    eqns = [Name] -> [EquationInfo] -> q (DExp -> DExp)
    forall (q :: * -> *).
    DsMonad q =>
    [Name] -> [EquationInfo] -> q (DExp -> DExp)
    simplCase [Name]
    vars ([EquationInfo] -> q (DExp -> DExp))
    -> [EquationInfo] -> q (DExp -> DExp)
    forall a b. (a -> b) -> a -> b
    $ NonEmpty EquationInfo -> [EquationInfo]
    forall a. NonEmpty a -> [a]
    NE.toList (NonEmpty EquationInfo -> [EquationInfo])
    -> NonEmpty EquationInfo -> [EquationInfo]
    forall a b. (a -> b) -> a -> b
    $ NonEmpty EquationInfo -> NonEmpty EquationInfo
    shiftEqns NonEmpty EquationInfo
    eqns

    shiftEqns :: NonEmpty EquationInfo -> NonEmpty EquationInfo
    shiftEqns :: NonEmpty EquationInfo -> NonEmpty EquationInfo
    shiftEqns = (EquationInfo -> EquationInfo)
    -> NonEmpty EquationInfo -> NonEmpty EquationInfo
    forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap EquationInfo -> EquationInfo
    shift
      where
        shift :: EquationInfo -> EquationInfo
    shift (EquationInfo NonEmpty DPat
    pats DExp -> DExp
    rhs) = NonEmpty DPat -> (DExp -> DExp) -> EquationInfo
    EquationInfo ([DPat] -> NonEmpty DPat
    to_ne_pats (NonEmpty DPat -> [DPat]
    forall a. NonEmpty a -> [a]
    NE.tail NonEmpty DPat
    pats)) DExp -> DExp
    rhs

        to_ne_pats :: [DPat] -> NonEmpty DPat
        to_ne_pats :: [DPat] -> NonEmpty DPat
    to_ne_pats [DPat]
    pats =
          case [DPat]
    pats of
            DPat
    p:[DPat]
    ps -> DPat
    pDPat -> [DPat] -> NonEmpty DPat
    forall a. a -> [a] -> NonEmpty a
    :|[DPat]
    ps
            [] -> String -> NonEmpty DPat
    forall a. HasCallStack => String -> a
    error String
    "Internal error in th-desugar (shiftEqns.to_ne_pats)"

    adjustMatchResult :: (DExp -> DExp) -> MatchResult -> MatchResult
    adjustMatchResult :: (DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp
    adjustMatchResult DExp -> DExp
    wrap DExp -> DExp
    mr DExp
    fail = DExp -> DExp
    wrap (DExp -> DExp) -> DExp -> DExp
    forall a b. (a -> b) -> a -> b
    $ DExp -> DExp
    mr DExp
    fail

    -- from DsUtils
    selectMatchVars :: DsMonad q => [DPat] -> q [Name]
    selectMatchVars :: forall (q :: * -> *). DsMonad q => [DPat] -> q [Name]
    selectMatchVars = (DPat -> q Name) -> [DPat] -> q [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 DPat -> q Name
    forall (q :: * -> *). DsMonad q => DPat -> q Name
    selectMatchVar

    -- from DsUtils
    selectMatchVar :: DsMonad q => DPat -> q Name
    selectMatchVar :: forall (q :: * -> *). DsMonad q => DPat -> q Name
    selectMatchVar (DBangP DPat
    pat)  = DPat -> q Name
    forall (q :: * -> *). DsMonad q => DPat -> q Name
    selectMatchVar DPat
    pat
    selectMatchVar (DTildeP DPat
    pat) = DPat -> q Name
    forall (q :: * -> *). DsMonad q => DPat -> q Name
    selectMatchVar DPat
    pat
    selectMatchVar (DVarP Name
    var)   = String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName (Char
    '_' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Name -> String
    nameBase Name
    var)
    selectMatchVar DPat
    _             = String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName String
    "_pat"