{-# LANGUAGE CPP #-}
#if MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Trans.TH
-- Copyright   :  (C) 2008-2013 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  MPTCs, fundeps
--
-- Automatic generation of free monadic actions.
--
----------------------------------------------------------------------------
module Control.Monad.Free.TH
  (
   -- * Free monadic actions
   makeFree,
   makeFree_,
   makeFreeCon,
   makeFreeCon_,

   -- * Documentation
   -- $doc

   -- * Examples
   -- $examples
  ) where

import Control.Arrow
import Control.Monad
import Data.Char (toLower)
import Data.List ((\\), nub)
import Language.Haskell.TH.Datatype.TyVarBndr
import Language.Haskell.TH.Ppr (pprint)
import Language.Haskell.TH.Syntax

data Arg
  = Captured Type Exp
  | Param    Type
  deriving (Int -> Arg -> ShowS
[Arg] -> ShowS
Arg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arg] -> ShowS
$cshowList :: [Arg] -> ShowS
show :: Arg -> String
$cshow :: Arg -> String
showsPrec :: Int -> Arg -> ShowS
$cshowsPrec :: Int -> Arg -> ShowS
Show)

params :: [Arg] -> [Type]
params :: [Arg] -> [Type]
params [] = []
params (Param Type
t : [Arg]
xs) = Type
t forall a. a -> [a] -> [a]
: [Arg] -> [Type]
params [Arg]
xs
params (Arg
_ : [Arg]
xs) = [Arg] -> [Type]
params [Arg]
xs

captured :: [Arg] -> [(Type, Exp)]
captured :: [Arg] -> [(Type, Exp)]
captured [] = []
captured (Captured Type
t Exp
e : [Arg]
xs) = (Type
t, Exp
e) forall a. a -> [a] -> [a]
: [Arg] -> [(Type, Exp)]
captured [Arg]
xs
captured (Arg
_ : [Arg]
xs) = [Arg] -> [(Type, Exp)]
captured [Arg]
xs

zipExprs :: [Exp] -> [Exp] -> [Arg] -> [Exp]
zipExprs :: [Exp] -> [Exp] -> [Arg] -> [Exp]
zipExprs (Exp
p:[Exp]
ps) [Exp]
cs (Param    Type
_   : [Arg]
as) = Exp
p forall a. a -> [a] -> [a]
: [Exp] -> [Exp] -> [Arg] -> [Exp]
zipExprs [Exp]
ps [Exp]
cs [Arg]
as
zipExprs [Exp]
ps (Exp
c:[Exp]
cs) (Captured Type
_ Exp
_ : [Arg]
as) = Exp
c forall a. a -> [a] -> [a]
: [Exp] -> [Exp] -> [Arg] -> [Exp]
zipExprs [Exp]
ps [Exp]
cs [Arg]
as
zipExprs [Exp]
_ [Exp]
_ [Arg]
_ = []

findTypeOrFail :: String -> Q Name
findTypeOrFail :: String -> Q Name
findTypeOrFail String
s = String -> Q (Maybe Name)
lookupTypeName String
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
s forall a. [a] -> [a] -> [a]
++ String
" is not in scope") forall (m :: * -> *) a. Monad m => a -> m a
return

findValueOrFail :: String -> Q Name
findValueOrFail :: String -> Q Name
findValueOrFail String
s = String -> Q (Maybe Name)
lookupValueName String
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
s forall a. [a] -> [a] -> [a]
++ String
"is not in scope") forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Pick a name for an operation.
-- For normal constructors it lowers first letter.
-- For infix ones it omits the first @:@.
mkOpName :: String -> Q String
mkOpName :: String -> Q String
mkOpName (Char
':':String
name) = forall (m :: * -> *) a. Monad m => a -> m a
return String
name
mkOpName ( Char
c :String
name) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
c forall a. a -> [a] -> [a]
: String
name
mkOpName String
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"impossible happened: empty (null) constructor name"

-- | Check if parameter is used in type.
usesTV :: Name -> Type -> Bool
usesTV :: Name -> Type -> Bool
usesTV Name
n (VarT Name
name)  = Name
n forall a. Eq a => a -> a -> Bool
== Name
name
usesTV Name
n (AppT Type
t1 Type
t2) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> Type -> Bool
usesTV Name
n) [Type
t1, Type
t2]
usesTV Name
n (SigT Type
t  Type
_ ) = Name -> Type -> Bool
usesTV Name
n Type
t
usesTV Name
n (ForallT [TyVarBndr Specificity]
bs [Type]
_ Type
t) = Name -> Type -> Bool
usesTV Name
n Type
t Bool -> Bool -> Bool
&& Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr Specificity]
bs
usesTV Name
_ Type
_ = Bool
False

-- | Analyze constructor argument.
mkArg :: Type -> Type -> Q Arg
mkArg :: Type -> Type -> Q Arg
mkArg (VarT Name
n) Type
t
  | Name -> Type -> Bool
usesTV Name
n Type
t =
      case Type
t of
        -- if parameter is used as is, the return type should be ()
        -- as well as the corresponding expression
        VarT Name
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Exp -> Arg
Captured (Int -> Type
TupleT Int
0) ([Maybe Exp] -> Exp
TupE [])
        -- if argument is of type (a1 -> ... -> aN -> param) then the
        -- return type is N-tuple (a1, ..., aN) and the corresponding
        -- expression is an N-tuple secion (,...,).
        AppT (AppT Type
ArrowT Type
_) Type
_ -> do
          ([Type]
ts, Name
name) <- forall {m :: * -> *}. MonadFail m => Type -> m ([Type], Name)
arrowsToTuple Type
t
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> Type -> Bool
usesTV Name
n) [Type]
ts) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"type variable " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Name
n forall a. [a] -> [a] -> [a]
++ String
" is forbidden"
            , String
"in a type like (a1 -> ... -> aN -> " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Name
n forall a. [a] -> [a] -> [a]
++ String
")"
            , String
"in a constructor's argument type: " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
t ]
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
name forall a. Eq a => a -> a -> Bool
/= Name
n) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [ String
"expected final return type `" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Name
n forall a. [a] -> [a] -> [a]
++ String
"'"
            , String
"but got `" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Name
name forall a. [a] -> [a] -> [a]
++ String
"'"
            , String
"in a constructor's argument type: `" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
t forall a. [a] -> [a] -> [a]
++ String
"'" ]
          let tup :: Type
tup = [Type] -> Type
nonUnaryTupleT [Type]
ts
          [Name]
xs <- 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 a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"x") [Type]
ts
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Exp -> Arg
Captured Type
tup ([Pat] -> Exp -> Exp
LamE (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
xs) ([Exp] -> Exp
nonUnaryTupE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
xs))
        Type
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
              [ String
"expected a type variable `" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Name
n forall a. [a] -> [a] -> [a]
++ String
"'"
              , String
"or a type like (a1 -> ... -> aN -> " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Name
n forall a. [a] -> [a] -> [a]
++ String
")"
              , String
"but got `" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
t forall a. [a] -> [a] -> [a]
++ String
"'"
              , String
"in a constructor's argument" ]
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Arg
Param Type
t
  where
    arrowsToTuple :: Type -> m ([Type], Name)
arrowsToTuple (AppT (AppT Type
ArrowT Type
t1) Type
t2) = do
      ([Type]
ts, Name
name) <- Type -> m ([Type], Name)
arrowsToTuple Type
t2
      forall (m :: * -> *) a. Monad m => a -> m a
return (Type
t1forall a. a -> [a] -> [a]
:[Type]
ts, Name
name)
    arrowsToTuple (VarT Name
name) = forall (m :: * -> *) a. Monad m => a -> m a
return ([], Name
name)
    arrowsToTuple Type
rt = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"expected final return type `" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Name
n forall a. [a] -> [a] -> [a]
++ String
"'"
      , String
"but got `" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
rt forall a. [a] -> [a] -> [a]
++ String
"'"
      , String
"in a constructor's argument type: `" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
t forall a. [a] -> [a] -> [a]
++ String
"'" ]

    nonUnaryTupleT :: [Type] -> Type
    nonUnaryTupleT :: [Type] -> Type
nonUnaryTupleT [Type
t'] = Type
t'
    nonUnaryTupleT [Type]
ts   = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts) [Type]
ts

    nonUnaryTupE :: [Exp] -> Exp
    nonUnaryTupE :: [Exp] -> Exp
nonUnaryTupE [Exp
e] = Exp
e
    nonUnaryTupE [Exp]
es  = [Maybe Exp] -> Exp
TupE forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_template_haskell(2,16,0)
                              forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#endif
                              [Exp]
es

mkArg Type
n Type
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
  [ String
"expected a type variable"
  , String
"but got `" forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Type
n forall a. [a] -> [a] -> [a]
++ String
"'"
  , String
"as the last parameter of the type constructor" ]

-- | Apply transformation to the return value independently of how many
-- parameters does @e@ have.
-- E.g. @mapRet Just (\x y z -> x + y * z)@ goes to
-- @\x y z -> Just (x + y * z)@
mapRet :: (Exp -> Exp) -> Exp -> Exp
mapRet :: (Exp -> Exp) -> Exp -> Exp
mapRet Exp -> Exp
f (LamE [Pat]
ps Exp
e) = [Pat] -> Exp -> Exp
LamE [Pat]
ps forall a b. (a -> b) -> a -> b
$ (Exp -> Exp) -> Exp -> Exp
mapRet Exp -> Exp
f Exp
e
mapRet Exp -> Exp
f Exp
e = Exp -> Exp
f Exp
e

-- | Unification of two types.
-- @next@ with @a -> next@ gives @Maybe a@ return type
-- @a -> next@ with @b -> next@ gives @Either a b@ return type
unifyT :: (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp])
unifyT :: (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp])
unifyT (TupleT Int
0, Exp
_) (TupleT Int
0, Exp
_) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"can't accept 2 mere parameters"
unifyT (TupleT Int
0, Exp
_) (Type
t, Exp
e) = do
  Type
maybe'   <- Name -> Type
ConT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
findTypeOrFail  String
"Maybe"
  Exp
nothing' <- Name -> Exp
ConE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
findValueOrFail String
"Nothing"
  Exp
just'    <- Name -> Exp
ConE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
findValueOrFail String
"Just"
  forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
AppT Type
maybe' Type
t, [Exp
nothing', (Exp -> Exp) -> Exp -> Exp
mapRet (Exp -> Exp -> Exp
AppE Exp
just') Exp
e])
unifyT (Type, Exp)
x y :: (Type, Exp)
y@(TupleT Int
0, Exp
_) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp])
unifyT (Type, Exp)
y (Type, Exp)
x
unifyT (Type
t1, Exp
e1) (Type
t2, Exp
e2) = do
  Type
either' <- Name -> Type
ConT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
findTypeOrFail  String
"Either"
  Exp
left'   <- Name -> Exp
ConE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
findValueOrFail String
"Left"
  Exp
right'  <- Name -> Exp
ConE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
findValueOrFail String
"Right"
  forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
either' Type
t1) Type
t2, [(Exp -> Exp) -> Exp -> Exp
mapRet (Exp -> Exp -> Exp
AppE Exp
left') Exp
e1, (Exp -> Exp) -> Exp -> Exp
mapRet (Exp -> Exp -> Exp
AppE Exp
right') Exp
e2])

-- | Unifying a list of types (possibly refining expressions).
-- Name is used when the return type is supposed to be arbitrary.
unifyCaptured :: Name -> [(Type, Exp)] -> Q (Type, [Exp])
unifyCaptured :: Name -> [(Type, Exp)] -> Q (Type, [Exp])
unifyCaptured Name
a []       = forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT Name
a, [])
unifyCaptured Name
_ [(Type
t, Exp
e)] = forall (m :: * -> *) a. Monad m => a -> m a
return (Type
t, [Exp
e])
unifyCaptured Name
_ [(Type, Exp)
x, (Type, Exp)
y]   = (Type, Exp) -> (Type, Exp) -> Q (Type, [Exp])
unifyT (Type, Exp)
x (Type, Exp)
y
unifyCaptured Name
_ [(Type, Exp)]
xs = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
  [ String
"can't unify more than 2 return types"
  , String
"that use type parameter"
  , String
"when unifying return types: "
  , [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ppr a => a -> String
pprint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Type, Exp)]
xs) ]

extractVars :: Type -> [Name]
extractVars :: Type -> [Name]
extractVars (ForallT [TyVarBndr Specificity]
bs [Type]
_ Type
t) = Type -> [Name]
extractVars Type
t forall a. Eq a => [a] -> [a] -> [a]
\\ forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr Specificity]
bs
extractVars (VarT Name
n) = [Name
n]
extractVars (AppT Type
x Type
y) = Type -> [Name]
extractVars Type
x forall a. [a] -> [a] -> [a]
++ Type -> [Name]
extractVars Type
y
extractVars (SigT Type
x Type
k) = Type -> [Name]
extractVars Type
x forall a. [a] -> [a] -> [a]
++ Type -> [Name]
extractVars Type
k
extractVars (InfixT Type
x Name
_ Type
y) = Type -> [Name]
extractVars Type
x forall a. [a] -> [a] -> [a]
++ Type -> [Name]
extractVars Type
y
extractVars (UInfixT Type
x Name
_ Type
y) = Type -> [Name]
extractVars Type
x forall a. [a] -> [a] -> [a]
++ Type -> [Name]
extractVars Type
y
extractVars (ParensT Type
x) = Type -> [Name]
extractVars Type
x
extractVars Type
_ = []

liftCon' :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Name -> [Type] -> Q [Dec]
liftCon' :: Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Type
-> [Type]
-> Name
-> [Type]
-> Q [Dec]
liftCon' Bool
typeSig [TyVarBndr Specificity]
tvbs [Type]
cx Type
f Type
n [Type]
ns Name
cn [Type]
ts = do
  -- prepare some names
  Name
opName <- String -> Name
mkName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q String
mkOpName (Name -> String
nameBase Name
cn)
  Name
m      <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"m"
  Name
a      <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
  Name
monadFree <- String -> Q Name
findTypeOrFail  String
"MonadFree"
  Name
liftF     <- String -> Q Name
findValueOrFail String
"liftF"
  -- look at the constructor parameters
  [Arg]
args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> Type -> Q Arg
mkArg Type
n) [Type]
ts
  let ps :: [Type]
ps = [Arg] -> [Type]
params [Arg]
args    -- these are not using type parameter
      cs :: [(Type, Exp)]
cs = [Arg] -> [(Type, Exp)]
captured [Arg]
args  -- these capture it somehow
  -- based on cs we get return type and refined expressions
  -- (e.g. with Nothing/Just or Left/Right tags)
  (Type
retType, [Exp]
es) <- Name -> [(Type, Exp)] -> Q (Type, [Exp])
unifyCaptured Name
a [(Type, Exp)]
cs
  -- operation type is (a1 -> a2 -> ... -> aN -> m r)
  let opType :: Type
opType  = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
ArrowT) (Type -> Type -> Type
AppT (Name -> Type
VarT Name
m) Type
retType) [Type]
ps
  -- picking names for the implementation
  [Name]
xs  <- 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 a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => String -> m Name
newName String
"p") [Type]
ps
  let pat :: [Pat]
pat  = forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
xs                      -- this is LHS
      exprs :: [Exp]
exprs = [Exp] -> [Exp] -> [Arg] -> [Exp]
zipExprs (forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
xs) [Exp]
es [Arg]
args  -- this is what ctor would be applied to
      fval :: Exp
fval = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
cn) [Exp]
exprs       -- this is RHS without liftF
      ns' :: [Name]
ns' = forall a. Eq a => [a] -> [a]
nub (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [Name]
extractVars [Type]
ns)
      q :: [TyVarBndr Specificity]
q = forall a. (a -> Bool) -> [a] -> [a]
filter forall {flag}. TyVarBndr_ flag -> Bool
nonNext [TyVarBndr Specificity]
tvbs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr Specificity
plainTVSpecified ([Name]
qa forall a. [a] -> [a] -> [a]
++ Name
m forall a. a -> [a] -> [a]
: [Name]
ns')
      qa :: [Name]
qa = case Type
retType of VarT Name
b | Name
a forall a. Eq a => a -> a -> Bool
== Name
b -> [Name
a]; Type
_ -> []
      f' :: Type
f' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT Type
f [Type]
ns
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ if Bool
typeSig
        then [ Name -> Type -> Dec
SigD Name
opName ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [TyVarBndr Specificity]
q ([Type]
cx forall a. [a] -> [a] -> [a]
++ [Name -> Type
ConT Name
monadFree Type -> Type -> Type
`AppT` Type
f' Type -> Type -> Type
`AppT` Name -> Type
VarT Name
m]) Type
opType) ]
        else []
    , [ Name -> [Clause] -> Dec
FunD Name
opName [ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
pat (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
liftF) Exp
fval) [] ] ] ]
  where
    nonNext :: TyVarBndr_ flag -> Bool
nonNext TyVarBndr_ flag
tv = Name -> Type
VarT (forall flag. TyVarBndr_ flag -> Name
tvName TyVarBndr_ flag
tv) forall a. Eq a => a -> a -> Bool
/= Type
n

-- | Provide free monadic actions for a single value constructor.
liftCon :: Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Type -> [Type] -> Maybe [Name] -> Con -> Q [Dec]
liftCon :: Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Type
-> [Type]
-> Maybe [Name]
-> Con
-> Q [Dec]
liftCon Bool
typeSig [TyVarBndr Specificity]
ts [Type]
cx Type
f Type
n [Type]
ns Maybe [Name]
onlyCons Con
con
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> Maybe [a] -> Bool
`melem` Maybe [Name]
onlyCons) (Con -> [Name]
constructorNames Con
con)) = forall (m :: * -> *) a. Monad m => a -> m a
return []
  | Bool
otherwise = case Con
con of
      NormalC Name
cName [BangType]
fields -> Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Type
-> [Type]
-> Name
-> [Type]
-> Q [Dec]
liftCon' Bool
typeSig [TyVarBndr Specificity]
ts [Type]
cx Type
f Type
n [Type]
ns Name
cName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [BangType]
fields
      RecC    Name
cName [VarBangType]
fields -> Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Type
-> [Type]
-> Name
-> [Type]
-> Q [Dec]
liftCon' Bool
typeSig [TyVarBndr Specificity]
ts [Type]
cx Type
f Type
n [Type]
ns Name
cName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
_, Type
ty) -> Type
ty) [VarBangType]
fields
      InfixC  (Bang
_,Type
t1) Name
cName (Bang
_,Type
t2) -> Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Type
-> [Type]
-> Name
-> [Type]
-> Q [Dec]
liftCon' Bool
typeSig [TyVarBndr Specificity]
ts [Type]
cx Type
f Type
n [Type]
ns Name
cName [Type
t1, Type
t2]
      ForallC [TyVarBndr Specificity]
ts' [Type]
cx' Con
con' -> Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Type
-> [Type]
-> Maybe [Name]
-> Con
-> Q [Dec]
liftCon Bool
typeSig ([TyVarBndr Specificity]
ts forall a. [a] -> [a] -> [a]
++ [TyVarBndr Specificity]
ts') ([Type]
cx forall a. [a] -> [a] -> [a]
++ [Type]
cx') Type
f Type
n [Type]
ns Maybe [Name]
onlyCons Con
con'
      GadtC [Name]
cNames [BangType]
fields Type
resType -> do
        [[Dec]]
decs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> Maybe [a] -> Bool
`melem` Maybe [Name]
onlyCons) [Name]
cNames) forall a b. (a -> b) -> a -> b
$ \Name
cName ->
                  Name
-> [BangType]
-> Type
-> Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Q [Dec]
liftGadtC Name
cName [BangType]
fields Type
resType Bool
typeSig [TyVarBndr Specificity]
ts [Type]
cx Type
f
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decs)
      RecGadtC [Name]
cNames [VarBangType]
fields Type
resType -> do
        let fields' :: [BangType]
fields' = forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_, Bang
x, Type
y) -> (Bang
x, Type
y)) [VarBangType]
fields
        [[Dec]]
decs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> Maybe [a] -> Bool
`melem` Maybe [Name]
onlyCons) [Name]
cNames) forall a b. (a -> b) -> a -> b
$ \Name
cName ->
                  Name
-> [BangType]
-> Type
-> Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Q [Dec]
liftGadtC Name
cName [BangType]
fields' Type
resType Bool
typeSig [TyVarBndr Specificity]
ts [Type]
cx Type
f
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
decs)

splitAppT :: Type -> (Type, [Type])
splitAppT :: Type -> (Type, [Type])
splitAppT Type
ty = Type -> Type -> [Type] -> (Type, [Type])
go Type
ty Type
ty []
  where
    go :: Type -> Type -> [Type] -> (Type, [Type])
    go :: Type -> Type -> [Type] -> (Type, [Type])
go Type
_      (AppT Type
ty1 Type
ty2)     [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
go Type
ty1 Type
ty1 (Type
ty2forall a. a -> [a] -> [a]
:[Type]
args)
    go Type
origTy (SigT Type
ty' Type
_)       [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
go Type
origTy Type
ty' [Type]
args
    go Type
origTy (InfixT Type
ty1 Name
n Type
ty2) [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
go Type
origTy (Name -> Type
ConT Name
n Type -> Type -> Type
`AppT` Type
ty1 Type -> Type -> Type
`AppT` Type
ty2) [Type]
args
    go Type
origTy (ParensT Type
ty')      [Type]
args = Type -> Type -> [Type] -> (Type, [Type])
go Type
origTy Type
ty' [Type]
args
    go Type
origTy Type
_                  [Type]
args = (Type
origTy, [Type]
args)

liftGadtC :: Name -> [BangType] -> Type -> Bool -> [TyVarBndrSpec] -> Cxt -> Type -> Q [Dec]
liftGadtC :: Name
-> [BangType]
-> Type
-> Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Q [Dec]
liftGadtC Name
cName [BangType]
fields Type
resType Bool
typeSig [TyVarBndr Specificity]
ts [Type]
cx Type
f =
  Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Type
-> [Type]
-> Maybe [Name]
-> Con
-> Q [Dec]
liftCon Bool
typeSig [TyVarBndr Specificity]
ts [Type]
cx Type
f Type
nextTy (forall a. [a] -> [a]
init [Type]
tys) forall a. Maybe a
Nothing (Name -> [BangType] -> Con
NormalC Name
cName [BangType]
fields)
  where
    (Type
_f, [Type]
tys) = Type -> (Type, [Type])
splitAppT Type
resType
    nextTy :: Type
nextTy = forall a. [a] -> a
last [Type]
tys

melem :: Eq a => a -> Maybe [a] -> Bool
melem :: forall a. Eq a => a -> Maybe [a] -> Bool
melem a
_ Maybe [a]
Nothing   = Bool
True
melem a
x (Just [a]
xs) = a
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
xs

-- | Get construstor name(s).
constructorNames :: Con -> [Name]
constructorNames :: Con -> [Name]
constructorNames (NormalC  Name
name [BangType]
_)    = [Name
name]
constructorNames (RecC     Name
name [VarBangType]
_)    = [Name
name]
constructorNames (InfixC   BangType
_ Name
name BangType
_)  = [Name
name]
constructorNames (ForallC  [TyVarBndr Specificity]
_ [Type]
_ Con
c)     = Con -> [Name]
constructorNames Con
c
constructorNames (GadtC [Name]
names [BangType]
_ Type
_)    = [Name]
names
constructorNames (RecGadtC [Name]
names [VarBangType]
_ Type
_) = [Name]
names

-- | Provide free monadic actions for a type declaration.
liftDec :: Bool             -- ^ Include type signature?
        -> Maybe [Name]     -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@.
        -> Dec              -- ^ Data type declaration.
        -> Q [Dec]
liftDec :: Bool -> Maybe [Name] -> Dec -> Q [Dec]
liftDec Bool
typeSig Maybe [Name]
onlyCons (DataD [Type]
_ Name
tyName [TyVarBndr ()]
tyVarBndrs Maybe Type
_ [Con]
cons [DerivClause]
_)
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr ()]
tyVarBndrs = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Type constructor " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Name
tyName forall a. [a] -> [a] -> [a]
++ String
" needs at least one type parameter"
  | Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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 (Bool
-> [TyVarBndr Specificity]
-> [Type]
-> Type
-> Type
-> [Type]
-> Maybe [Name]
-> Con
-> Q [Dec]
liftCon Bool
typeSig [] [] Type
con Type
nextTy (forall a. [a] -> [a]
init [Type]
tys) Maybe [Name]
onlyCons) [Con]
cons
    where
      tys :: [Type]
tys     = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndr ()]
tyVarBndrs
      nextTy :: Type
nextTy  = forall a. [a] -> a
last [Type]
tys
      con :: Type
con        = Name -> Type
ConT Name
tyName
liftDec Bool
_ Maybe [Name]
_ Dec
dec = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
  [ String
"failed to derive makeFree operations:"
  , String
"expected a data type constructor"
  , String
"but got " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Dec
dec ]

-- | Generate monadic actions for a data type.
genFree :: Bool         -- ^ Include type signature?
        -> Maybe [Name] -- ^ Include only mentioned constructor names. Use all constructors when @Nothing@.
        -> Name         -- ^ Type name.
        -> Q [Dec]      -- ^ Generated declarations.
genFree :: Bool -> Maybe [Name] -> Name -> Q [Dec]
genFree Bool
typeSig Maybe [Name]
cnames Name
tyCon = do
  Info
info <- Name -> Q Info
reify Name
tyCon
  case Info
info of
    TyConI Dec
dec -> Bool -> Maybe [Name] -> Dec -> Q [Dec]
liftDec Bool
typeSig Maybe [Name]
cnames Dec
dec
    Info
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeFree expects a type constructor"

-- | Generate monadic action for a single constructor of a data type.
genFreeCon :: Bool         -- ^ Include type signature?
           -> Name         -- ^ Constructor name.
           -> Q [Dec]      -- ^ Generated declarations.
genFreeCon :: Bool -> Name -> Q [Dec]
genFreeCon Bool
typeSig Name
cname = do
  Info
info <- Name -> Q Info
reify Name
cname
  case Info
info of
    DataConI Name
_ Type
_ Name
tname -> Bool -> Maybe [Name] -> Name -> Q [Dec]
genFree Bool
typeSig (forall a. a -> Maybe a
Just [Name
cname]) Name
tname
    Info
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
          [ String
"expected a data constructor"
          , String
"but got " forall a. [a] -> [a] -> [a]
++ forall a. Ppr a => a -> String
pprint Info
info ]

-- | @$('makeFree' ''T)@ provides free monadic actions for the
-- constructors of the given data type @T@.
makeFree :: Name -> Q [Dec]
makeFree :: Name -> Q [Dec]
makeFree = Bool -> Maybe [Name] -> Name -> Q [Dec]
genFree Bool
True forall a. Maybe a
Nothing

-- | Like 'makeFree', but does not provide type signatures.
-- This can be used to attach Haddock comments to individual arguments
-- for each generated function.
--
-- @
-- data LangF x = Output String x
--
-- makeFree_ 'LangF
--
-- -- | Output a string.
-- output :: MonadFree LangF m =>
--           String   -- ^ String to output.
--        -> m ()     -- ^ No result.
-- @
--
-- 'makeFree_' must be called *before* the explicit type signatures.
makeFree_ :: Name -> Q [Dec]
makeFree_ :: Name -> Q [Dec]
makeFree_ = Bool -> Maybe [Name] -> Name -> Q [Dec]
genFree Bool
False forall a. Maybe a
Nothing

-- | @$('makeFreeCon' 'Con)@ provides free monadic action for a data
-- constructor @Con@. Note that you can attach Haddock comment to the
-- generated function by placing it before the top-level invocation of
-- 'makeFreeCon':
--
-- @
-- -- | Output a string.
-- makeFreeCon 'Output
-- @
makeFreeCon :: Name -> Q [Dec]
makeFreeCon :: Name -> Q [Dec]
makeFreeCon = Bool -> Name -> Q [Dec]
genFreeCon Bool
True

-- | Like 'makeFreeCon', but does not provide a type signature.
-- This can be used to attach Haddock comments to individual arguments.
--
-- @
-- data LangF x = Output String x
--
-- makeFreeCon_ 'Output
--
-- -- | Output a string.
-- output :: MonadFree LangF m =>
--           String   -- ^ String to output.
--        -> m ()     -- ^ No result.
-- @
--
-- 'makeFreeCon_' must be called *before* the explicit type signature.
makeFreeCon_ :: Name -> Q [Dec]
makeFreeCon_ :: Name -> Q [Dec]
makeFreeCon_ = Bool -> Name -> Q [Dec]
genFreeCon Bool
False

{- $doc
 To generate free monadic actions from a @Type@, it must be a @data@
 declaration (maybe GADT) with at least one free variable. For each constructor of the type, a
 new function will be declared.

 Consider the following generalized definitions:

 > data Type a1 a2 … aN param = …
 >                            | FooBar t1 t2 t3 … tJ
 >                            | (:+) t1 t2 t3 … tJ
 >                            | t1 :* t2
 >                            | t1 `Bar` t2
 >                            | Baz { x :: t1, y :: t2, …, z :: tJ }
 >                            | forall b1 b2 … bN. cxt => Qux t1 t2 … tJ
 >                            | …

 where each of the constructor arguments @t1, …, tJ@ is either:

 1. A type, perhaps depending on some of the @a1, …, aN@.

 2. A type dependent on @param@, of the form @s1 -> … -> sM -> param@, M ≥ 0.
      At most 2 of the @t1, …, tJ@ may be of this form. And, out of these two,
      at most 1 of them may have @M == 0@; that is, be of the form @param@.

 For each constructor, a function will be generated. First, the name
 of the function is derived from the name of the constructor:

 * For prefix constructors, the name of the constructor with the first
   letter in lowercase (e.g. @FooBar@ turns into @fooBar@).

 * For infix constructors, the name of the constructor with the first
   character (a colon @:@), removed (e.g. @:+@ turns into @+@).

 Then, the type of the function is derived from the arguments to the constructor:

 > …
 > fooBar :: (MonadFree Type m) => t1' -> … -> tK' -> m ret
 > (+)    :: (MonadFree Type m) => t1' -> … -> tK' -> m ret
 > bar    :: (MonadFree Type m) => t1  -> … -> tK' -> m ret
 > baz    :: (MonadFree Type m) => t1' -> … -> tK' -> m ret
 > qux    :: (MonadFree Type m, cxt) => t1' -> … -> tK' -> m ret
 > …

 The @t1', …, tK'@ are those @t1@ … @tJ@ that only depend on the
 @a1, …, aN@.

 The type @ret@ depends on those constructor arguments that reference the
 @param@ type variable:

     1. If no arguments to the constructor depend on @param@, @ret ≡ a@, where
       @a@ is a fresh type variable.

     2. If only one argument in the constructor depends on @param@, then
       @ret ≡ (s1, …, sM)@. In particular, if @M == 0@, then @ret ≡ ()@; if @M == 1@, @ret ≡ s1@.

     3. If two arguments depend on @param@, (e.g. @u1 -> … -> uL -> param@ and
       @v1 -> … -> vM -> param@, then @ret ≡ Either (u1, …, uL) (v1, …, vM)@.

 Note that @Either a ()@ and @Either () a@ are both isomorphic to @Maybe a@.
 Because of this, when @L == 0@ or @M == 0@ in case 3., the type of
 @ret@ is simplified:

     * @ret ≡ Either (u1, …, uL) ()@ is rewritten to @ret ≡ Maybe (u1, …, uL)@.

     * @ret ≡ Either () (v1, …, vM)@ is rewritten to @ret ≡ Maybe (v1, …, vM)@.

-}

{- $examples

<examples/Teletype.lhs Teletype> (regular data type declaration)

<examples/RetryTH.hs Retry> (GADT declaration)

-}