{-# LANGUAGE CPP #-}
{-|
Module      : Parsley.Internal.Backend.Machine.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 1.7.0.0
-}
module Parsley.Internal.Backend.Machine.THUtils (eta, unsafeCodeCoerce, unTypeCode) where

import GHC.Types                     (TYPE)
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 1.7.0.0
-}
eta :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). Code (a -> b) -> Code (a -> b)
eta :: Code (a -> b) -> Code (a -> b)
eta = Q Exp -> Code (a -> b)
forall a. Q Exp -> Code a
unsafeCodeCoerce (Q Exp -> Code (a -> b))
-> (Code (a -> b) -> Q Exp) -> Code (a -> b) -> Code (a -> b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> Exp
checkEtaMulti (Q Exp -> Q Exp)
-> (Code (a -> b) -> Q Exp) -> Code (a -> b) -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Code (a -> b) -> Q Exp
forall a. Code a -> Q Exp
unTypeCode
  where
    --     \       x                  ->      f       x              = f
    checkEta :: Pat -> Exp -> (Maybe Pat, Exp)
checkEta (VarP Name
x)                  (AppE Exp
qf (VarE Name
x')) | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x' = (Maybe Pat
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x' = (Maybe Pat
forall a. Maybe a
Nothing, Exp
qf)
    --     \ (!           x)          ->      f       x              = f
    checkEta (BangP (VarP Name
x))          (AppE Exp
qf (VarE Name
x')) | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x' = (Maybe Pat
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x' = (Maybe Pat
forall a. Maybe a
Nothing, Exp
qf)
    --     \ x -> body                                               = \ x -> body
    checkEta Pat
qarg Exp
qbody                                              = (Pat -> Maybe Pat
forall a. a -> Maybe a
Just Pat
qarg, Exp
qbody)

    checkEtaMulti :: Exp -> Exp
checkEtaMulti (LamE [Pat]
args Exp
body)  = ([Pat] -> Exp -> Exp) -> ([Pat], Exp) -> Exp
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Pat] -> Exp -> Exp
LamE (([Pat], Exp) -> Exp) -> ([Pat], Exp) -> Exp
forall a b. (a -> b) -> a -> b
$
      (Pat -> ([Pat], Exp) -> ([Pat], Exp))
-> ([Pat], Exp) -> [Pat] -> ([Pat], Exp)
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Pat
arg ([Pat]
args, Exp
body) -> (Maybe Pat -> [Pat]) -> (Maybe Pat, Exp) -> ([Pat], Exp)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([Pat] -> (Pat -> [Pat]) -> Maybe Pat -> [Pat]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Pat]
args (Pat -> [Pat] -> [Pat]
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 :: Q Exp -> Code a
unsafeCodeCoerce = Q Exp -> Code a
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce

unTypeCode :: Code a -> Q Exp
unTypeCode :: Code a -> Q Exp
unTypeCode = Code a -> Q Exp
forall a. Q (TExp a) -> Q Exp
unTypeQ
#endif