{-# LANGUAGE CPP #-}
{-|
Module      : Parsley.Internal.Common.THUtils
Description : Functions for low-level template haskell manipulation
License     : BSD-3-Clause
Maintainer  : Jamie Willis
Stability   : experimental

This module contains some Template Haskell related functions for manipulating
template haskell as a lower, combinator-based, level.

@since 2.3.0.0
-}
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)

{-|
Given a function (of arbitrarily many arguments, but it must at /least/ have 1), eta-reduces
it to remove redundant arguments.

@since 2.3.0.0
-}
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
    --     \       x                  ->              x                                    = id
    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)
    --     \       x                  ->      f       x                                    = f
    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)
    --     \       (x ::    t)        ->      f       x                                    = f
    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)
    --     \ (!           x)          ->      f       x                                    = f
    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)
    --     \ (!            x ::    t) ->      f       x                                    = f
    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)
    --     \ x -> body                                                                     = \ x -> body
    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