{- 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
e1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
e2
scExp (DLamE [Name]
names DExp
exp) = [Name] -> DExp -> DExp
DLamE [Name]
names forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
exp
scExp (DCaseE DExp
scrut [DMatch]
matches)
  | DVarE Name
name <- DExp
scrut
  = forall (q :: * -> *). DsMonad q => [Name] -> [DClause] -> q DExp
simplCaseExp [Name
name] [DClause]
clauses
  | Bool
otherwise
  = do Name
scrut_name <- forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"scrut"
       DExp
case_exp <- forall (q :: * -> *). DsMonad q => [Name] -> [DClause] -> q DExp
simplCaseExp [Name
scrut_name] [DClause]
clauses
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [DLetDec] -> DExp -> DExp
DLetE [DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
scrut_name) DExp
scrut] DExp
case_exp
  where
    clauses :: [DClause]
clauses = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *). DsMonad q => DLetDec -> q DLetDec
scLetDec [DLetDec]
decs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
body
scExp (DSigE DExp
exp DType
ty) = DExp -> DType -> DExp
DSigE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
exp forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
ty
scExp (DAppTypeE DExp
exp DType
ty) = DExp -> DType -> DExp
DAppTypeE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
exp forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure DType
ty
scExp (DTypedBracketE DExp
exp) = DExp -> DExp
DTypedBracketE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
exp
scExp (DTypedSpliceE DExp
exp) = DExp -> DExp
DTypedSpliceE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
exp
scExp e :: DExp
e@(DVarE {}) = forall (m :: * -> *) a. Monad m => a -> m a
return DExp
e
scExp e :: DExp
e@(DConE {}) = forall (m :: * -> *) a. Monad m => a -> m a
return DExp
e
scExp e :: DExp
e@(DLitE {}) = forall (m :: * -> *) a. Monad m => a -> m a
return DExp
e
scExp e :: DExp
e@(DStaticE {}) = 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
  [Name]
arg_names <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const (forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"_arg")) [DPat]
pats1
  [DClause]
clauses' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {f :: * -> *}. DsMonad f => DClause -> f DClause
sc_clause_rhs [DClause]
clauses
  DExp
case_exp <- forall (q :: * -> *). DsMonad q => [Name] -> [DClause] -> q DExp
simplCaseExp [Name]
arg_names [DClause]
clauses'
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [DClause] -> DLetDec
DFunD Name
name [[DPat] -> DExp -> DClause
DClause (forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
arg_names) DExp
case_exp]
  where
    sc_clause_rhs :: DClause -> f DClause
sc_clause_rhs (DClause [DPat]
pats DExp
exp) = [DPat] -> DExp -> DClause
DClause [DPat]
pats forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
exp
scLetDec (DValD DPat
pat DExp
exp) = DPat -> DExp -> DLetDec
DValD DPat
pat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DExp -> q DExp
scExp DExp
exp
scLetDec (DPragmaD DPragma
prag) = DPragma -> DLetDec
DPragmaD forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (q :: * -> *). DsMonad q => DPragma -> q DPragma
scLetPragma DPragma
prag
scLetDec dec :: DLetDec
dec@(DSigD {}) = forall (m :: * -> *) a. Monad m => a -> m a
return DLetDec
dec
scLetDec dec :: DLetDec
dec@(DInfixD {}) = forall (m :: * -> *) a. Monad m => a -> m a
return DLetDec
dec
scLetDec dec :: DLetDec
dec@(DFunD Name
_ []) = 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 = forall a b (m :: * -> *).
(Typeable a, Data b, Monad m) =>
(a -> m a) -> b -> m b
topEverywhereM 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 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 forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` 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
pforall a. a -> [a] -> NonEmpty a
:|[DPat]
ps
        [] -> 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 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
  ([DExp -> DExp]
aux_binds, [EquationInfo]
tidy_clauses) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (forall (q :: * -> *).
DsMonad q =>
Name -> EquationInfo -> q (DExp -> DExp, EquationInfo)
tidyClause Name
v) [EquationInfo]
clauses
  let grouped :: [NonEmpty (PatGroup, EquationInfo)]
grouped = [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
groupClauses [EquationInfo]
tidy_clauses
  [DExp -> DExp]
match_results <- forall (q :: * -> *).
DsMonad q =>
[NonEmpty (PatGroup, EquationInfo)] -> q [DExp -> DExp]
match_groups [NonEmpty (PatGroup, EquationInfo)]
grouped
  forall (m :: * -> *) a. Monad m => a -> m a
return ((DExp -> DExp) -> (DExp -> DExp) -> DExp -> DExp
adjustMatchResult (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [DExp -> DExp]
aux_binds) forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) [DExp -> DExp]
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 [] = forall (q :: * -> *). DsMonad q => Name -> q [DExp -> DExp]
matchEmpty Name
v
    match_groups [NonEmpty (PatGroup, EquationInfo)]
gs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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
_ -> forall (q :: * -> *).
DsMonad q =>
NonEmpty Name
-> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
matchConFamily NonEmpty Name
vars forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
[(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo)
subGroup [(Name
c,EquationInfo
e) | (PgCon Name
c, EquationInfo
e) <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty (PatGroup, EquationInfo)
eqns]
        PgLit Lit
_ -> forall (q :: * -> *).
DsMonad q =>
NonEmpty Name
-> NonEmpty (NonEmpty EquationInfo) -> q (DExp -> DExp)
matchLiterals  NonEmpty Name
vars forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
[(a, EquationInfo)] -> NonEmpty (NonEmpty EquationInfo)
subGroup [(Lit
l,EquationInfo
e) | (PgLit Lit
l, EquationInfo
e) <- forall a. NonEmpty a -> [a]
NE.toList NonEmpty (PatGroup, EquationInfo)
eqns]
        PatGroup
PgBang  -> forall (q :: * -> *).
DsMonad q =>
NonEmpty Name -> NonEmpty EquationInfo -> q (DExp -> DExp)
matchBangs     NonEmpty Name
vars forall a b. (a -> b) -> a -> b
$ NonEmpty (PatGroup, EquationInfo) -> NonEmpty EquationInfo
drop_group NonEmpty (PatGroup, EquationInfo)
eqns
        PatGroup
PgAny   -> forall (q :: * -> *).
DsMonad q =>
NonEmpty Name -> NonEmpty EquationInfo -> q (DExp -> DExp)
matchVariables NonEmpty Name
vars 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd

    vars :: NonEmpty Name
vars = Name
vforall 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
  (DExp -> DExp
wrap, DPat
pat') <- forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v DPat
pat
  forall (m :: * -> *) a. Monad m => a -> m a
return (DExp -> DExp
wrap, NonEmpty DPat -> (DExp -> DExp) -> EquationInfo
EquationInfo (DPat
pat' forall a. a -> [a] -> NonEmpty a
:| [DPat]
pats) DExp -> DExp
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 {}) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> a
id, DPat
p)
tidy1 Name
v (DVarP Name
var) = 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 {}) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> a
id, DPat
p)
tidy1 Name
v (DTildeP DPat
pat) = do
  [DLetDec]
sel_decs <- forall (q :: * -> *). DsMonad q => DPat -> Name -> q [DLetDec]
mkSelectorDecs DPat
pat Name
v
  forall (m :: * -> *) a. Monad m => a -> m a
return ([DLetDec] -> DExp -> DExp
maybeDLetE [DLetDec]
sel_decs, DPat
DWildP)
tidy1 Name
v (DBangP DPat
pat) =
  case DPat
pat of
    DLitP Lit
_   -> forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v DPat
pat   -- already strict
    DVarP Name
_   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> a
id, DPat -> DPat
DBangP DPat
pat)  -- no change
    DConP{}   -> forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v DPat
pat   -- already strict
    DTildeP DPat
p -> forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v (DPat -> DPat
DBangP DPat
p) -- discard ~ under !
    DBangP DPat
p  -> forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v (DPat -> DPat
DBangP DPat
p) -- discard ! under !
    DSigP DPat
p DType
_ -> forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v (DPat -> DPat
DBangP DPat
p) -- discard sig under !
    DPat
DWildP    -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> a
id, DPat -> DPat
DBangP DPat
pat)  -- no change
tidy1 Name
v (DSigP DPat
pat DType
ty)
  | forall a. Data a => a -> Bool
no_tyvars_ty DType
ty = 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 = 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 = forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything Bool -> Bool -> 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         = forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
gmapQl Bool -> Bool -> Bool
(&&) Bool
True forall a. Data a => a -> Bool
no_tyvars_ty DType
t
tidy1 Name
_ DPat
DWildP = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> a
id, DPat
DWildP)

wrapBind :: Name -> Name -> DExp -> DExp
wrapBind :: Name -> Name -> DExp -> DExp
wrapBind Name
new Name
old
  | Name
new forall a. Eq a => a -> a -> Bool
== Name
old = 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 = 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
  | forall a. OSet a -> Bool
OS.null OSet Name
binders
  = forall (m :: * -> *) a. Monad m => a -> m a
return []

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

  | Bool
otherwise
  = do DExp
tuple_expr <- forall (q :: * -> *). DsMonad q => [Name] -> [DClause] -> q DExp
simplCaseExp [Name
name] [[DPat] -> DExp -> DClause
DClause [DPat
pat] DExp
local_tuple]
       Name
tuple_var <- forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"tuple"
       [DExp]
projections <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (q :: * -> *). DsMonad q => Name -> Int -> q DExp
mk_projection Name
tuple_var) [Int
0 .. Int
tuple_sizeforall a. Num a => a -> a -> a
-Int
1]
       forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
tuple_var) DExp
tuple_expr forall a. a -> [a] -> [a]
:
               forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith DPat -> DExp -> DLetDec
DValD (forall a b. (a -> b) -> [a] -> [b]
map Name -> DPat
DVarP [Name]
binders_list) [DExp]
projections)

  where
    binders :: OSet Name
binders = DPat -> OSet Name
extractBoundNamesDPat DPat
pat
    binders_list :: [Name]
binders_list = forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList OSet Name
binders
    tuple_size :: Int
tuple_size = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
binders_list
    local_tuple :: DExp
local_tuple = [DExp] -> DExp
mkTupleDExp (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
      Name
var_name <- forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"proj"
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DExp -> [DMatch] -> DExp
DCaseE (Name -> DExp
DVarE Name
tup_name) [DPat -> DExp -> DMatch
DMatch (Name -> [DType] -> [DPat] -> DPat
DConP (Int -> Name
tupleDataName Int
tuple_size) [] (Name -> Int -> [DPat]
mk_tuple_pats Name
var_name Int
i))
                                               (Name -> DExp
DVarE Name
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 = forall a. Int -> a -> [a]
replicate Int
i DPat
DWildP forall a. [a] -> [a] -> [a]
++ Name -> DPat
DVarP Name
elt_name forall a. a -> [a] -> [a]
: forall a. Int -> a -> [a]
replicate (Int
tuple_size forall a. Num a => a -> a -> a
- Int
i 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
      DExp -> DExp
rhs_mr <- forall (q :: * -> *).
DsMonad q =>
[Name] -> [EquationInfo] -> q (DExp -> DExp)
simplCase [Name
scrut_var] [NonEmpty DPat -> (DExp -> DExp) -> EquationInfo
EquationInfo (DPat
patforall a. a -> [a] -> NonEmpty a
:|[]) (\DExp
_ -> Name -> DExp
DVarE Name
bndr_var)]
      forall (m :: * -> *) a. Monad m => a -> m a
return (DPat -> DExp -> DLetDec
DValD (Name -> DPat
DVarP Name
bndr_var) (DExp -> DExp
rhs_mr (Name -> DExp
DVarE Name
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
  = 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 {})      = 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 {})    = forall a. HasCallStack => String -> a
error String
"Internal error in th-desugar (patGroup DTildeP)"
patGroup (DBangP {})     = PatGroup
PgBang
patGroup (DSigP{})       = forall a. HasCallStack => String -> a
error String
"Internal error in th-desugar (patGroup DSigP)"
patGroup DPat
DWildP          = 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 forall a b. (a -> b) -> [a] -> [b]
map forall a. NonEmpty a -> NonEmpty a
NE.reverse forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {k} {a}.
Ord k =>
Map k (NonEmpty a) -> (k, a) -> Map k (NonEmpty a)
accumulate forall k a. Map k a
Map.empty [(a, EquationInfo)]
group of
      NonEmpty EquationInfo
e:[NonEmpty EquationInfo]
es -> NonEmpty EquationInfo
eforall a. a -> [a] -> NonEmpty a
:|[NonEmpty EquationInfo]
es
      [] -> 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 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 -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
pg (forall a. a -> NonEmpty a -> NonEmpty a
NE.cons a
eqn NonEmpty a
eqns) Map k (NonEmpty a)
pg_map
          Maybe (NonEmpty a)
Nothing   -> forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
pg (a
eqn 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 NonEmpty CaseAlt
alts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (q :: * -> *).
DsMonad q =>
[Name] -> NonEmpty EquationInfo -> q CaseAlt
matchOneCon [Name]
vars) NonEmpty (NonEmpty EquationInfo)
groups
       forall (q :: * -> *).
DsMonad q =>
Name -> NonEmpty CaseAlt -> q (DExp -> DExp)
mkDataConCase Name
var NonEmpty CaseAlt
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 [Name]
arg_vars <- forall (q :: * -> *). DsMonad q => [DPat] -> q [Name]
selectMatchVars (DPat -> [DPat]
pat_args DPat
pat1)
       DExp -> DExp
match_result <- forall (q :: * -> *). DsMonad q => [Name] -> q (DExp -> DExp)
match_group [Name]
arg_vars

       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> (DExp -> DExp) -> CaseAlt
CaseAlt (DPat -> Name
pat_con DPat
pat1) [Name]
arg_vars DExp -> DExp
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
_                = 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
_               = 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
      = forall (q :: * -> *).
DsMonad q =>
[Name] -> [EquationInfo] -> q (DExp -> DExp)
simplCase ([Name]
arg_vars forall a. [a] -> [a] -> [a]
++ [Name]
vars) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> 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 forall a. [a] -> [a] -> [a]
++ [DPat]
pats)) DExp -> DExp
exp
    shift 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
pforall a. a -> [a] -> NonEmpty a
:|[DPat]
ps
        [] -> 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
  Set Name
all_ctors <- forall (q :: * -> *). DsMonad q => Name -> q (Set Name)
get_all_ctors (CaseAlt -> Name
alt_con forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty CaseAlt
case_alts)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \DExp
fail ->
    let matches :: [DMatch]
matches = 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 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 = 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 [] (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 = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ 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 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
      Name
ty_name <- forall (q :: * -> *). DsMonad q => Name -> q Name
dataConNameToDataName Name
con_name
      Just (DTyConI DDec
tycon_dec Maybe [DDec]
_) <- forall (q :: * -> *). DsMonad q => Name -> q (Maybe DInfo)
dsReify Name
ty_name
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DCon -> Name
get_con_name forall a b. (a -> b) -> a -> b
$ DDec -> [DCon]
get_cons DDec
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 [DTyVarBndrVis]
_ 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 = 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 NonEmpty (Lit, DExp -> DExp)
alts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (q :: * -> *).
DsMonad q =>
NonEmpty EquationInfo -> q (Lit, DExp -> DExp)
match_group NonEmpty (NonEmpty EquationInfo)
sub_groups
       forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> NonEmpty (Lit, DExp -> DExp) -> DExp -> DExp
mkCoPrimCaseMatchResult Name
var NonEmpty (Lit, DExp -> DExp)
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 (forall a. NonEmpty a -> a
NE.head NonEmpty EquationInfo
eqns) of
                       DLitP Lit
lit' -> Lit
lit'
                       DPat
_          -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Internal error in th-desugar "
                                          forall a. [a] -> [a] -> [a]
++ String
"(matchLiterals.match_group)"
           DExp -> DExp
match_result <- forall (q :: * -> *).
DsMonad q =>
[Name] -> [EquationInfo] -> q (DExp -> DExp)
simplCase [Name]
vars forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ NonEmpty EquationInfo -> NonEmpty EquationInfo
shiftEqns NonEmpty EquationInfo
eqns
           forall (m :: * -> *) a. Monad m => a -> m a
return (Lit
lit, DExp -> DExp
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 = forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 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 DExp -> DExp
match_result <- forall (q :: * -> *).
DsMonad q =>
[Name] -> [EquationInfo] -> q (DExp -> DExp)
simplCase (Name
varforall a. a -> [a] -> [a]
:[Name]
vars) forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> 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
       forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> (DExp -> DExp) -> DExp -> DExp
mkEvalMatchResult Name
var DExp -> DExp
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 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
_          = 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
  = 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 = forall (q :: * -> *).
DsMonad q =>
[Name] -> [EquationInfo] -> q (DExp -> DExp)
simplCase [Name]
vars forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList 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 = 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 (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
pforall a. a -> [a] -> NonEmpty a
:|[DPat]
ps
        [] -> 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 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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)  = forall (q :: * -> *). DsMonad q => DPat -> q Name
selectMatchVar DPat
pat
selectMatchVar (DTildeP DPat
pat) = forall (q :: * -> *). DsMonad q => DPat -> q Name
selectMatchVar DPat
pat
selectMatchVar (DVarP Name
var)   = forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName (Char
'_' forall a. a -> [a] -> [a]
: Name -> String
nameBase Name
var)
selectMatchVar DPat
_             = forall (q :: * -> *). Quasi q => String -> q Name
newUniqueName String
"_pat"