{-# 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
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
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
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
simplCase :: DsMonad q
=> [Name]
-> [EquationInfo]
-> 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
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
-> DPat
-> q (DExp -> DExp, DPat)
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
DVarP Name
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> a
id, DPat -> DPat
DBangP DPat
pat)
DConP{} -> forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v DPat
pat
DTildeP DPat
p -> forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v (DPat -> DPat
DBangP DPat
p)
DBangP DPat
p -> forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v (DPat -> DPat
DBangP DPat
p)
DSigP DPat
p DType
_ -> forall (q :: * -> *).
DsMonad q =>
Name -> DPat -> q (DExp -> DExp, DPat)
tidy1 Name
v (DPat -> DPat
DBangP DPat
p)
DPat
DWildP -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> a
id, DPat -> DPat
DBangP DPat
pat)
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
| 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)]
mkSelectorDecs :: DsMonad q
=> DPat
-> Name
-> 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
-> Int
-> 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
-> Int
-> [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
| PgCon Name
| PgLit Lit
| PgBang
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
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
, CaseAlt -> [Name]
_alt_args :: [Name]
, CaseAlt -> DExp -> DExp
_alt_rhs :: MatchResult
}
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
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
-> 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
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
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"