{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
#if __GLASGOW_HASKELL__ >= 900
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#endif
module Bound.TH
(
#ifdef MIN_VERSION_template_haskell
makeBound
#endif
) where
#ifdef MIN_VERSION_template_haskell
import Data.List (intercalate)
import Data.Traversable (for)
import Control.Monad (foldM, mzero, guard)
import Bound.Class (Bound((>>>=)))
import Language.Haskell.TH
import Language.Haskell.TH.Datatype.TyVarBndr
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
makeBound :: Name -> DecsQ
makeBound :: Name -> DecsQ
makeBound Name
name = do
TyConI Dec
dec <- Name -> Q Info
reify Name
name
case Dec
dec of
DataD Cxt
_ Name
_name [TyVarBndr ()]
vars Maybe Type
_ [Con]
cons [DerivClause]
_ -> Name -> [TyVarBndr ()] -> [Con] -> DecsQ
makeBound' Name
name [TyVarBndr ()]
vars [Con]
cons
Dec
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
name forall a. [a] -> [a] -> [a]
++ String
" Must be a data type."
makeBound' :: Name -> [TyVarBndrUnit] -> [Con] -> DecsQ
makeBound' :: Name -> [TyVarBndr ()] -> [Con] -> DecsQ
makeBound' Name
name [TyVarBndr ()]
vars [Con]
cons = do
let instanceHead :: Type
instanceHead :: Type
instanceHead = Name
name Name -> Cxt -> Type
`conAppsT` forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (forall flag. [TyVarBndr_ flag] -> [Name]
typeVars (forall a. [a] -> [a]
init [TyVarBndr ()]
vars))
var :: ExpQ
var :: ExpQ
var = Name -> Exp
ConE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> [TyVarBndr ()] -> [Con] -> Q Name
getPure Name
name [TyVarBndr ()]
vars [Con]
cons
bind :: ExpQ
bind :: ExpQ
bind = Name -> [TyVarBndr ()] -> [Con] -> ExpQ
constructBind Name
name [TyVarBndr ()]
vars [Con]
cons
[d| instance Applicative $(pure instanceHead) where
pure = $var
{-# INLINE pure #-}
ff <*> fy = do
f <- ff
y <- fy
pure (f y)
{-# INLINE (<*>) #-}
instance Monad $(pure instanceHead) where
(>>=) = $bind
{-# INLINE (>>=) #-}
|]
data Prop
= Bound
| Konst
| Funktor Int
| Exp
deriving Int -> Prop -> ShowS
[Prop] -> ShowS
Prop -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prop] -> ShowS
$cshowList :: [Prop] -> ShowS
show :: Prop -> String
$cshow :: Prop -> String
showsPrec :: Int -> Prop -> ShowS
$cshowsPrec :: Int -> Prop -> ShowS
Show
data Components
= Component Name [(Name, Prop)]
| Variable Name
deriving Int -> Components -> ShowS
[Components] -> ShowS
Components -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Components] -> ShowS
$cshowList :: [Components] -> ShowS
show :: Components -> String
$cshow :: Components -> String
showsPrec :: Int -> Components -> ShowS
$cshowsPrec :: Int -> Components -> ShowS
Show
constructBind :: Name -> [TyVarBndrUnit] -> [Con] -> ExpQ
constructBind :: Name -> [TyVarBndr ()] -> [Con] -> ExpQ
constructBind Name
name [TyVarBndr ()]
vars [Con]
cons = do
[Components] -> ExpQ
interpret forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> [TyVarBndr ()] -> [Con] -> Q [Components]
construct Name
name [TyVarBndr ()]
vars [Con]
cons
construct :: Name -> [TyVarBndrUnit] -> [Con] -> Q [Components]
construct :: Name -> [TyVarBndr ()] -> [Con] -> Q [Components]
construct Name
name [TyVarBndr ()]
vars [Con]
constructors = do
Name
var <- Name -> [TyVarBndr ()] -> [Con] -> Q Name
getPure Name
name [TyVarBndr ()]
vars [Con]
constructors
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
constructors forall a b. (a -> b) -> a -> b
$ \Con
con -> do
case Con
con of
NormalC Name
conName [(Bang
_, Type
_)]
| Name
conName forall a. Eq a => a -> a -> Bool
== Name
var
-> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Components
Variable Name
conName)
NormalC Name
conName [BangType]
types
-> Name -> [(Name, Prop)] -> Components
Component Name
conName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Name, Prop)
typeToBnd [ Type
ty | (Bang
_, Type
ty) <- [BangType]
types ]
RecC Name
conName [VarBangType]
types
-> Name -> [(Name, Prop)] -> Components
Component Name
conName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q (Name, Prop)
typeToBnd [ Type
ty | (Name
_, Bang
_, Type
ty) <- [VarBangType]
types ]
InfixC (Bang
_, Type
a) Name
conName (Bang
_, Type
b)
-> do
(Name, Prop)
bndA <- Type -> Q (Name, Prop)
typeToBnd Type
a
(Name, Prop)
bndB <- Type -> Q (Name, Prop)
typeToBnd Type
b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [(Name, Prop)] -> Components
Component Name
conName [(Name, Prop)
bndA, (Name, Prop)
bndB])
Con
_ -> forall a. HasCallStack => String -> a
error String
"Not implemented."
where
expa :: Type
expa :: Type
expa = Name
name Name -> Cxt -> Type
`conAppsT` forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT (forall flag. [TyVarBndr_ flag] -> [Name]
typeVars [TyVarBndr ()]
vars)
typeToBnd :: Type -> Q (Name, Prop)
typeToBnd :: Type -> Q (Name, Prop)
typeToBnd Type
ty = do
Bool
boundInstance <- Type -> Q Bool
isBound Type
ty
Maybe Int
functorApp <- Type -> Q (Maybe Int)
isFunctorApp Type
ty
Name
var <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"var"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case () of
()
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Type
expa -> (Name
var, Prop
Exp)
| Bool
boundInstance -> (Name
var, Prop
Bound)
| Type -> Bool
isKonst Type
ty -> (Name
var, Prop
Konst)
| Just Int
n <- Maybe Int
functorApp -> (Name
var, Int -> Prop
Funktor Int
n)
| Bool
otherwise -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"This is bad: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Type
ty
forall a. [a] -> [a] -> [a]
++ String
" "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Bool
boundInstance
isBound :: Type -> Q Bool
isBound :: Type -> Q Bool
isBound Type
ty
| Just Type
a <- Type -> Maybe Type
stripLast2 Type
ty = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False forall a. Q a -> Q a -> Q a
`recover` Name -> Cxt -> Q Bool
isInstance ''Bound [Type
a]
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isKonst :: Type -> Bool
isKonst :: Type -> Bool
isKonst ConT {} = Bool
True
isKonst (VarT Name
n) = Name
n forall a. Eq a => a -> a -> Bool
/= forall flag. TyVarBndr_ flag -> Name
tvName (forall a. [a] -> a
last [TyVarBndr ()]
vars)
isKonst (AppT Type
a Type
b) = Type -> Bool
isKonst Type
a Bool -> Bool -> Bool
&& Type -> Bool
isKonst Type
b
isKonst Type
_ = Bool
False
isFunctorApp :: Type -> Q (Maybe Int)
isFunctorApp :: Type -> Q (Maybe Int)
isFunctorApp = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t :: (* -> *) -> * -> *} {a}.
(Num a, MonadTrans t, MonadPlus (t Q)) =>
Type -> t Q a
go
where
go :: Type -> t Q a
go Type
x | Type
x forall a. Eq a => a -> a -> Bool
== Type
expa = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0
go (Type
f `AppT` Type
x) = do
Bool
isFunctor <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Q Bool
isInstance ''Functor [Type
f]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isFunctor
a
n <- Type -> t Q a
go Type
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a
n forall a. Num a => a -> a -> a
+ a
1
go Type
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero
interpret :: [Components] -> ExpQ
interpret :: [Components] -> ExpQ
interpret [Components]
bnds = do
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
Name
f <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
let
bind :: Components -> MatchQ
bind :: Components -> MatchQ
bind (Variable Name
name) = do
Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Match
match
(forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a])
(forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
a))
[]
bind (Component Name
name [(Name, Prop)]
bounds) = do
Exp
exprs <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Exp -> (Name, Prop) -> ExpQ
bindOne (Name -> Exp
ConE Name
name) [(Name, Prop)]
bounds
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Pat -> Body -> [Dec] -> Match
Match
(Name -> Cxt -> [Pat] -> Pat
ConP Name
name
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
[ Name -> Pat
VarP Name
arg | (Name
arg, Prop
_) <- [(Name, Prop)]
bounds ])
(Exp -> Body
NormalB
Exp
exprs)
[]
bindOne :: Exp -> (Name, Prop) -> Q Exp
bindOne :: Exp -> (Name, Prop) -> ExpQ
bindOne Exp
expr (Name
name, Prop
bnd) = case Prop
bnd of
Prop
Bound ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(>>>=) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f)
Prop
Konst ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name
Prop
Exp ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(>>=) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f)
Funktor Int
n ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Exp
fmapN Int
n) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(>>=) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`sectionR` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
name)
fmapN :: Int -> Exp
fmapN :: Int -> Exp
fmapN Int
n = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\Exp
a Exp
b -> Name -> Exp
VarE '(.) Exp -> Exp -> Exp
`AppE` Exp
a Exp -> Exp -> Exp
`AppE` Exp
b) forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
n (Name -> Exp
VarE 'fmap)
[Match]
matches <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Components]
bnds Components -> MatchQ
bind
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x, Name -> Pat
VarP Name
f] (Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
x) [Match]
matches)
stripLast2 :: Type -> Maybe Type
stripLast2 :: Type -> Maybe Type
stripLast2 (Type
a `AppT` Type
b `AppT` Type
_ `AppT` Type
d)
| AppT{} <- Type
d = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (Type
a Type -> Type -> Type
`AppT` Type
b)
stripLast2 Type
_ = forall a. Maybe a
Nothing
getPure :: Name -> [TyVarBndrUnit] -> [Con] -> Q Name
getPure :: Name -> [TyVarBndr ()] -> [Con] -> Q Name
getPure Name
_name [TyVarBndr ()]
tyvr [Con]
cons= do
let
findReturn :: Type -> [(Name, [Type])] -> Name
findReturn :: Type -> [(Name, Cxt)] -> Name
findReturn Type
ty [(Name, Cxt)]
constrs =
case [ Name
constr | (Name
constr, [Type
ty']) <- [(Name, Cxt)]
constrs, Type
ty' forall a. Eq a => a -> a -> Bool
== Type
ty ] of
[] -> forall a. HasCallStack => String -> a
error String
"Too few candidates for a variable constructor."
[Name
x] -> Name
x
[Name]
xs -> forall a. HasCallStack => String -> a
error (String
"Too many candidates: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Ppr a => a -> String
pprint [Name]
xs))
lastTyVar :: Type
lastTyVar :: Type
lastTyVar = Name -> Type
VarT (forall a. [a] -> a
last (forall flag. [TyVarBndr_ flag] -> [Name]
typeVars [TyVarBndr ()]
tyvr))
allTypeArgs :: Con -> (Name, [Type])
allTypeArgs :: Con -> (Name, Cxt)
allTypeArgs Con
con = case Con
con of
NormalC Name
conName [BangType]
tys ->
(Name
conName, [ Type
ty | (Bang
_, Type
ty) <- [BangType]
tys ])
RecC Name
conName [VarBangType]
tys ->
(Name
conName, [ Type
ty | (Name
_, Bang
_, Type
ty) <- [VarBangType]
tys ])
InfixC (Bang
_, Type
t1) Name
conName (Bang
_, Type
t2) ->
(Name
conName, [ Type
t1, Type
t2 ])
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
conName ->
Con -> (Name, Cxt)
allTypeArgs Con
conName
Con
_ -> forall a. HasCallStack => String -> a
error String
"Not implemented"
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> [(Name, Cxt)] -> Name
findReturn Type
lastTyVar (Con -> (Name, Cxt)
allTypeArgs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Con]
cons))
typeVars :: [TyVarBndr_ flag] -> [Name]
typeVars :: forall flag. [TyVarBndr_ flag] -> [Name]
typeVars = forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName
conAppsT :: Name -> [Type] -> Type
conAppsT :: Name -> Cxt -> Type
conAppsT Name
conName = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
conName)
#else
#endif