{-# LANGUAGE CPP #-}
module Parsley.Internal.Common.THUtils (eta, unsafeCodeCoerce, unTypeCode) where
import Data.Generics (everything, mkQ)
import Control.Arrow (first)
import Language.Haskell.TH.Syntax ( Exp(AppE, LamE, VarE), Pat(VarP, BangP, SigP)
#if __GLASGOW_HASKELL__ < 900
, Q, unTypeQ, unsafeTExpCoerce
#else
, unTypeCode, unsafeCodeCoerce
#endif
)
import Parsley.Internal.Common.Utils (Code)
eta :: Code a -> Code a
eta :: forall a. Code a -> Code a
eta = forall a (m :: Type -> Type). Quote m => m Exp -> Code m a
unsafeCodeCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Exp
checkEtaMulti forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: Type -> Type). Quote m => Code m a -> m Exp
unTypeCode
where
checkEta :: Pat -> Exp -> (Maybe Pat, Exp)
checkEta (VarP Name
x) (VarE Name
x') | Name
x forall a. Eq a => a -> a -> Bool
== Name
x' = (forall a. Maybe a
Nothing, Name -> Exp
VarE 'id)
checkEta (VarP Name
x) (AppE Exp
qf (VarE Name
x')) | Name
x forall a. Eq a => a -> a -> Bool
== Name
x', forall {a} {p}. (Data a, Typeable p, Eq p) => p -> a -> Bool
checkOccurrence Name
x Exp
qf = (forall a. Maybe a
Nothing, Exp
qf)
checkEta (SigP (VarP Name
x) Type
_) (AppE Exp
qf (VarE Name
x')) | Name
x forall a. Eq a => a -> a -> Bool
== Name
x', forall {a} {p}. (Data a, Typeable p, Eq p) => p -> a -> Bool
checkOccurrence Name
x Exp
qf = (forall a. Maybe a
Nothing, Exp
qf)
checkEta (BangP (VarP Name
x)) (AppE Exp
qf (VarE Name
x')) | Name
x forall a. Eq a => a -> a -> Bool
== Name
x', forall {a} {p}. (Data a, Typeable p, Eq p) => p -> a -> Bool
checkOccurrence Name
x Exp
qf = (forall a. Maybe a
Nothing, Exp
qf)
checkEta (BangP (SigP (VarP Name
x) Type
_)) (AppE Exp
qf (VarE Name
x')) | Name
x forall a. Eq a => a -> a -> Bool
== Name
x', forall {a} {p}. (Data a, Typeable p, Eq p) => p -> a -> Bool
checkOccurrence Name
x Exp
qf = (forall a. Maybe a
Nothing, Exp
qf)
checkEta Pat
qarg Exp
qbody = (forall a. a -> Maybe a
Just Pat
qarg, Exp
qbody)
checkOccurrence :: p -> a -> Bool
checkOccurrence p
x a
body = 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 (forall a. Eq a => a -> a -> Bool
/= p
x)) a
body
checkEtaMulti :: Exp -> Exp
checkEtaMulti (LamE [Pat]
args Exp
body) = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Pat] -> Exp -> Exp
LamE forall a b. (a -> b) -> a -> b
$
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Pat
arg ([Pat]
args, Exp
body) -> forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Pat]
args (forall a. a -> [a] -> [a]
: [Pat]
args)) (Pat -> Exp -> (Maybe Pat, Exp)
checkEta Pat
arg Exp
body))
([], Exp
body)
[Pat]
args
checkEtaMulti Exp
qf = Exp
qf
#if __GLASGOW_HASKELL__ < 900
unsafeCodeCoerce :: Q Exp -> Code a
unsafeCodeCoerce = unsafeTExpCoerce
unTypeCode :: Code a -> Q Exp
unTypeCode = unTypeQ
#endif