{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.DeriveLiftedInstances.Internal
-- Copyright   :  (c) Sjoerd Visscher 2020
--
-- Maintainer  :  sjoerd@w3future.com
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Data.DeriveLiftedInstances.Internal where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift)
import Data.Char (isAlpha)
import Data.Data (Data, gmapQl, cast)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Traversable (for)


-- | To write your own `Derivator` you need to show how each part of a method gets lifted.
-- For example, when deriving an instance for type @a@ of the following methods:
--
-- @
-- meth0 :: a
-- meth1 :: Int -> a
-- meth2 :: a -> Either Bool a -> Sum Int
-- meth3 :: Maybe [a] -> IO a
-- @
--
-- the resulting template haskell declarations are (pseudo code):
--
-- @
-- meth0 = $res ($op "meth0" meth0)
-- meth1 a = $res (($op "meth1" meth1) `$ap` ($arg Int a))
-- meth2 ($inp v0) ($inp v1) = $cst (($op "meth2" meth2) `$ap` ($var (`iterate` 0) v0)) `$ap` ($var (`iterate` 1) v1)
-- meth3 ($inp v2) = $eff (($op "meth2" meth2) `$ap` ($var (`iterate` 2) v2))
-- @
data Derivator = Derivator {
  Derivator -> Q Exp -> Q Exp
res :: Q Exp -> Q Exp, -- ^ Convert the result of the method
  Derivator -> Q Exp -> Q Exp
cst :: Q Exp -> Q Exp, -- ^ Convert the result of the method if it is a constant
  Derivator -> Q Exp -> Q Exp
eff :: Q Exp -> Q Exp, -- ^ Convert the result of the method if it has an effect
  Derivator -> Name -> Q Exp -> Q Exp
op  :: Name -> Q Exp -> Q Exp, -- ^ Convert the method (still unapplied to any arguments)
  Derivator -> Type -> Q Exp -> Q Exp
arg :: Type -> Q Exp -> Q Exp, -- ^ Convert an argument
  Derivator -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp, -- ^ Convert a variable
  Derivator -> Q Pat -> Q Pat
inp :: Q Pat -> Q Pat, -- ^ Generate an input pattern for a variable
  Derivator -> Q Exp -> Q Exp -> Q Exp
ap  :: Q Exp -> Q Exp -> Q Exp -- ^ Apply an argument or variable to the method
}

varExp :: Name -> Q Exp
varExp :: Name -> Q Exp
varExp = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> (Name -> Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE

-- | The identity `Derivator`. Not useful on its own, but often used as input for other `Derivator`s.
idDeriv :: Derivator
idDeriv :: Derivator
idDeriv = Derivator :: (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> (Name -> Q Exp -> Q Exp)
-> (Type -> Q Exp -> Q Exp)
-> ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp)
-> (Q Pat -> Q Pat)
-> (Q Exp -> Q Exp -> Q Exp)
-> Derivator
Derivator {
  res :: Q Exp -> Q Exp
res = Q Exp -> Q Exp
forall a. a -> a
id,
  cst :: Q Exp -> Q Exp
cst = Q Exp -> Q Exp
forall a. a -> a
id,
  eff :: Q Exp -> Q Exp
eff = Q Exp -> Q Exp
forall a. a -> a
id,
  op :: Name -> Q Exp -> Q Exp
op  = (Q Exp -> Q Exp) -> Name -> Q Exp -> Q Exp
forall a b. a -> b -> a
const Q Exp -> Q Exp
forall a. a -> a
id,
  arg :: Type -> Q Exp -> Q Exp
arg = (Q Exp -> Q Exp) -> Type -> Q Exp -> Q Exp
forall a b. a -> b -> a
const Q Exp -> Q Exp
forall a. a -> a
id,
  var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = (Q Exp -> Q Exp) -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. a -> b -> a
const Q Exp -> Q Exp
forall a. a -> a
id,
  inp :: Q Pat -> Q Pat
inp = Q Pat -> Q Pat
forall a. a -> a
id,
  ap :: Q Exp -> Q Exp -> Q Exp
ap  = \Q Exp
f Q Exp
a -> [| $f $a |]
}

-- | Derive the instance with the given `Derivator` and the given instance head.
--
-- The instance head can be passed as a template haskell type quotation, for example:
--
-- @
-- {-\# LANGUAGE TemplateHaskell #-}
-- [t| `Num` `ShowsPrec` |]
-- [t| forall a. `Num` a => `Num` [a] |]
-- [t| forall a b. (`Num` a, `Num` b) => `Num` (a, b) |]
-- @
deriveInstance :: Derivator -> Q Type -> Q [Dec]
deriveInstance :: Derivator -> Q Type -> Q [Dec]
deriveInstance Derivator
deriv Q Type
qtyp = do
  Type
typ <- Q Type
qtyp
  case Type
typ of
    ForallT [TyVarBndr]
_ Cxt
ctx (AppT Type
ty Type
typeName) ->
      Derivator -> Cxt -> Name -> Type -> Q [Dec]
deriveInstance' Derivator
deriv Cxt
ctx (Type -> Name
className Type
ty) (Type -> Type -> Type
AppT Type
ty Type
typeName)
    AppT Type
ty Type
typeName ->
      Derivator -> Cxt -> Name -> Type -> Q [Dec]
deriveInstance' Derivator
deriv [] (Type -> Name
className Type
ty) (Type -> Type -> Type
AppT Type
ty Type
typeName)
    Type
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"No support for type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
typ

deriveInstance' :: Derivator -> Cxt -> Name -> Type -> Q [Dec]
deriveInstance' :: Derivator -> Cxt -> Name -> Type -> Q [Dec]
deriveInstance' Derivator
deriv Cxt
ctx Name
clsName Type
typ = do
  ClassI (ClassD Cxt
_ Name
_ [TyVarBndr]
tvs [FunDep]
_ [Dec]
decs) [Dec]
_ <- Name -> Q Info
reify Name
clsName
  let KindedTV Name
tvn Type
_ = [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
tvs
  [Maybe Dec]
impl <- [Dec] -> (Dec -> Q (Maybe Dec)) -> Q [Maybe Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Dec]
decs ((Dec -> Q (Maybe Dec)) -> Q [Maybe Dec])
-> (Dec -> Q (Maybe Dec)) -> Q [Maybe Dec]
forall a b. (a -> b) -> a -> b
$ \case
    SigD Name
nm Type
tp -> do
      Info
dec <- Name -> Q Info
reify Name
nm
      case Info
dec of
        ClassOpI{} -> do
          ([Name]
argNames, Exp
body) <- Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
deriv Name
tvn Type
tp (Derivator -> Name -> Q Exp -> Q Exp
op Derivator
deriv Name
nm (Name -> Q Exp
varExp Name
nm))
          [Pat]
args <- (Name -> Q Pat) -> [Name] -> Q [Pat]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\Name
argName -> if Name -> Exp -> Bool
forall d. Data d => Name -> d -> Bool
contains Name
argName Exp
body then (if Name -> String
nameBase Name
argName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"var" then Derivator -> Q Pat -> Q Pat
inp Derivator
deriv else Q Pat -> Q Pat
forall a. a -> a
id) (Q Pat -> Q Pat) -> (Name -> Q Pat) -> Name -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> (Name -> Pat) -> Name -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Pat
VarP (Name -> Q Pat) -> Name -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name
argName else Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pat
WildP) [Name]
argNames
          Maybe Dec -> Q (Maybe Dec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Dec -> Q (Maybe Dec)) -> Maybe Dec -> Q (Maybe Dec)
forall a b. (a -> b) -> a -> b
$ Dec -> Maybe Dec
forall a. a -> Maybe a
Just (Dec -> Maybe Dec) -> Dec -> Maybe Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD Name
nm [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
args (Exp -> Body
NormalB Exp
body) []]
        Info
_ -> String -> Q (Maybe Dec)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Maybe Dec)) -> String -> Q (Maybe Dec)
forall a b. (a -> b) -> a -> b
$ String
"No support for declaration: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
dec
    Dec
_ -> Maybe Dec -> Q (Maybe Dec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Dec
forall a. Maybe a
Nothing
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
ctx Type
typ ([Dec] -> Dec) -> [Dec] -> Dec
forall a b. (a -> b) -> a -> b
$ [Maybe Dec] -> [Dec]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Dec]
impl]

buildOperation :: Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation :: Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
d Name
nm (AppT (AppT Type
ArrowT Type
h) Type
t) Q Exp
e | Name -> Type -> Bool
hasVar Name
nm Type
h = do
  Name
varNm <- String -> Q Name
newName String
"var"
  ([Name]
args, Exp
rhs) <- Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
d Name
nm Type
t (Derivator -> Q Exp -> Q Exp -> Q Exp
ap Derivator
d Q Exp
e (Derivator -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var Derivator
d (Name -> Type -> Q Exp -> Q Exp -> Q Exp
buildArgument Name
nm Type
h) (Name -> Q Exp
varExp Name
varNm)))
  ([Name], Exp) -> Q ([Name], Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
varNm Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
args, Exp
rhs)
buildOperation Derivator
d Name
nm (AppT (AppT Type
ArrowT Type
h) Type
t) Q Exp
e = do
  Name
varNm <- String -> Q Name
newName String
"arg"
  ([Name]
args, Exp
rhs) <- Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
d Name
nm Type
t (Derivator -> Q Exp -> Q Exp -> Q Exp
ap Derivator
d Q Exp
e (Derivator -> Type -> Q Exp -> Q Exp
arg Derivator
d Type
h (Name -> Q Exp
varExp Name
varNm)))
  ([Name], Exp) -> Q ([Name], Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
varNm Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
args, Exp
rhs)
buildOperation Derivator
d Name
nm (ForallT [TyVarBndr]
_ Cxt
_ Type
t) Q Exp
e = Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
d Name
nm Type
t Q Exp
e
buildOperation Derivator
d Name
nm (AppT Type
_ Type
t) Q Exp
e | Name -> Type -> Bool
isVar Name
nm Type
t = ([],) (Exp -> ([Name], Exp)) -> Q Exp -> Q ([Name], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derivator -> Q Exp -> Q Exp
eff Derivator
d Q Exp
e
buildOperation Derivator
d Name
nm Type
t Q Exp
e | Name -> Type -> Bool
isVar Name
nm Type
t = ([],) (Exp -> ([Name], Exp)) -> Q Exp -> Q ([Name], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derivator -> Q Exp -> Q Exp
res Derivator
d Q Exp
e
                        | Bool
otherwise = ([],) (Exp -> ([Name], Exp)) -> Q Exp -> Q ([Name], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derivator -> Q Exp -> Q Exp
cst Derivator
d Q Exp
e

buildArgument :: Name -> Type -> Q Exp -> Q Exp -> Q Exp
buildArgument :: Name -> Type -> Q Exp -> Q Exp -> Q Exp
buildArgument Name
nm (AppT Type
h Type
_) Q Exp
_ Q Exp
var | Name -> Type -> Bool
isVar Name
nm Type
h = Q Exp
var
buildArgument Name
nm (AppT Type
_ Type
h) Q Exp
over Q Exp
var = [| $over $(buildArgument nm h over var) |]
buildArgument Name
_ Type
_ Q Exp
_ Q Exp
var = Q Exp
var

isVar :: Name -> Type -> Bool
isVar :: Name -> Type -> Bool
isVar Name
nm (VarT Name
nm') = Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm'
isVar Name
nm (AppT Type
h Type
_) = Name -> Type -> Bool
isVar Name
nm Type
h
isVar Name
_ Type
_ = Bool
False

hasVar :: Name -> Type -> Bool
hasVar :: Name -> Type -> Bool
hasVar Name
nm (VarT Name
nm') = Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm'
hasVar Name
nm (AppT Type
f Type
a) = Name -> Type -> Bool
isVar Name
nm Type
f Bool -> Bool -> Bool
|| Name -> Type -> Bool
hasVar Name
nm Type
a
hasVar Name
_ Type
_ = Bool
False

className :: Type -> Name
className :: Type -> Name
className (ConT Name
nm) = Name
nm
className (AppT Type
h Type
_) = Type -> Name
className Type
h
className Type
t = String -> Name
forall a. HasCallStack => String -> a
error (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"No support for class: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
t

contains :: Data d => Name -> d -> Bool
contains :: Name -> d -> Bool
contains Name
nm = (Bool -> Bool -> Bool)
-> Bool -> (forall d. Data d => d -> Bool) -> d -> Bool
forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
gmapQl Bool -> Bool -> Bool
(||) Bool
False (\d
d -> Bool -> (Name -> Bool) -> Maybe Name -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> d -> Bool
forall d. Data d => Name -> d -> Bool
contains Name
nm d
d) (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm) (Maybe Name -> Bool) -> Maybe Name -> Bool
forall a b. (a -> b) -> a -> b
$ d -> Maybe Name
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast d
d)


deriving instance Lift Fixity
deriving instance Lift FixityDirection

-- | Helper for showing infix expressions
data ShowsPrec = ShowsPrec (Int -> String -> String) | ShowOp2 Fixity (Int -> String -> String) | ShowOp1 Fixity (Int -> String -> String)
instance Show ShowsPrec where
  showsPrec :: Int -> ShowsPrec -> String -> String
showsPrec Int
d (ShowsPrec Int -> String -> String
f) = Int -> String -> String
f Int
d
  showsPrec Int
d (ShowOp2 (Fixity Int
p FixityDirection
_) Int -> String -> String
f) = Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
f Int
0
  showsPrec Int
_ (ShowOp1 Fixity
_ Int -> String -> String
f) = Bool -> (String -> String) -> String -> String
showParen Bool
True ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
f Int
0

showAp :: ShowsPrec -> ShowsPrec -> ShowsPrec
showAp :: ShowsPrec -> ShowsPrec -> ShowsPrec
showAp (ShowsPrec Int -> String -> String
f) (ShowsPrec Int -> String -> String
g) = (Int -> String -> String) -> ShowsPrec
ShowsPrec ((Int -> String -> String) -> ShowsPrec)
-> (Int -> String -> String) -> ShowsPrec
forall a b. (a -> b) -> a -> b
$ \Int
d -> Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
f Int
10 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
g Int
11
showAp (ShowOp2 fx :: Fixity
fx@(Fixity Int
p FixityDirection
i) Int -> String -> String
f) (ShowsPrec Int -> String -> String
g) = Fixity -> (Int -> String -> String) -> ShowsPrec
ShowOp1 Fixity
fx ((Int -> String -> String) -> ShowsPrec)
-> (Int -> String -> String) -> ShowsPrec
forall a b. (a -> b) -> a -> b
$ \Int
_ -> Int -> String -> String
g (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (FixityDirection
i FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
/= FixityDirection
InfixL)) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
f Int
0
showAp (ShowOp1 (Fixity Int
p FixityDirection
i) Int -> String -> String
f) (ShowsPrec Int -> String -> String
g) = (Int -> String -> String) -> ShowsPrec
ShowsPrec ((Int -> String -> String) -> ShowsPrec)
-> (Int -> String -> String) -> ShowsPrec
forall a b. (a -> b) -> a -> b
$ \Int
d -> Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p) (Int -> String -> String
f Int
0 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
g (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (FixityDirection
i FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
/= FixityDirection
InfixR)))
showAp ShowsPrec
_ ShowsPrec
_ = String -> ShowsPrec
forall a. HasCallStack => String -> a
error String
"Unexpected use of showAp"

-- | Derive instances for `ShowsPrec`. Example:
--
-- @
-- `deriveInstance` `showDeriv` [t| `Num` `ShowsPrec` |]
--
-- > `show` ((6 `*` 7) `^` 2 :: `ShowsPrec`)
-- "fromInteger 6 * fromInteger 7 * (fromInteger 6 * fromInteger 7)"
-- @
showDeriv :: Derivator
showDeriv :: Derivator
showDeriv = Derivator
idDeriv {
  op :: Name -> Q Exp -> Q Exp
op = \Name
nm Q Exp
_ -> let name :: String
name = Name -> String
nameBase Name
nm in if String -> Bool
isOperator String
name
    then do
      Fixity
fx <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q (Maybe Fixity)
reifyFixity Name
nm
      [| ShowOp2 fx $ const $ showString $(pure . LitE . StringL $ name) |]
    else
      [| ShowsPrec  $ const $ showString $(pure . LitE . StringL $ name) |],
  arg :: Type -> Q Exp -> Q Exp
arg = \case
    (VarT Name
_) -> Q Exp -> Q Exp -> Q Exp
forall a b. a -> b -> a
const [| ShowsPrec $ const (showString "#Unshowable#") |]
    Type
_ -> \Q Exp
v -> [| ShowsPrec $ flip showsPrec $v |],
  var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = \Q Exp -> Q Exp -> Q Exp
_ Q Exp
v ->  [| ShowsPrec $ flip showsPrec $v |],
  ap :: Q Exp -> Q Exp -> Q Exp
ap  = \Q Exp
f Q Exp
a -> [| showAp $f $a |]
}

isOperator :: String -> Bool
isOperator :: String -> Bool
isOperator (Char
c:String
_) = Bool -> Bool
not (Char -> Bool
isAlpha Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_'
isOperator String
_ = Bool
False