{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PatternGuards #-}
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
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative, pure, (<*>))
#endif
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
#if MIN_VERSION_template_haskell(2,11,0)
DataD Cxt
_ Name
_name [TyVarBndr]
vars Maybe Kind
_ [Con]
cons [DerivClause]
_ -> Name -> [TyVarBndr] -> [Con] -> DecsQ
makeBound' Name
name [TyVarBndr]
vars [Con]
cons
#else
DataD _ _name vars cons _ -> makeBound' name vars cons
#endif
Dec
_ -> String -> DecsQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> DecsQ) -> String -> DecsQ
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
name String -> String -> String
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 :: Kind
instanceHead = Name
name Name -> Cxt -> Kind
`conAppsT` (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT ([TyVarBndr] -> [Name]
forall flag. [TyVarBndr] -> [Name]
typeVars ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
vars))
var :: ExpQ
var :: ExpQ
var = Name -> Exp
ConE (Name -> Exp) -> Q Name -> ExpQ
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
#if __GLASGOW_HASKELL__ < 708
def :: Name -> DecQ -> [DecQ]
#if __GLASGOW_HASKELL__ < 706
def _theName dec = [dec]
#else
def theName dec = [pragInlD theName Inline FunLike AllPhases, dec]
#endif
pureBody :: Name -> [DecQ]
pureBody pure'or'return =
def pure'or'return
(valD (varP pure'or'return) (normalB var) [])
bindBody :: [DecQ]
bindBody =
def '(>>=)
(valD (varP '(>>=)) (normalB bind) [])
apBody <- do
ff <- newName "ff"
fy <- newName "fy"
f <- newName "f"
y <- newName "y"
let ap :: ExpQ
ap = lamE [varP ff, varP fy] (doE
[bindS (varP f) (varE ff),
bindS (varP y) (varE fy),
noBindS (varE 'pure `appE` (varE f `appE` varE y))])
pure (def '(<*>) (valD (varP '(<*>)) (normalB ap) []))
applicative <-
instanceD (cxt []) (appT (conT ''Applicative) (pure instanceHead))
(pureBody 'pure ++ apBody)
monad <-
instanceD (cxt []) (appT (conT ''Monad) (pure instanceHead))
(pureBody 'return ++ bindBody)
pure [applicative, monad]
#else
[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
# if __GLASGOW_HASKELL__ < 710
return = $var
{-# INLINE return #-}
# endif
(>>=) = $bind
{-# INLINE (>>=) #-}
|]
#endif
data Prop
= Bound
| Konst
| Funktor Int
| Exp
deriving Int -> Prop -> String -> String
[Prop] -> String -> String
Prop -> String
(Int -> Prop -> String -> String)
-> (Prop -> String) -> ([Prop] -> String -> String) -> Show Prop
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Prop] -> String -> String
$cshowList :: [Prop] -> String -> String
show :: Prop -> String
$cshow :: Prop -> String
showsPrec :: Int -> Prop -> String -> String
$cshowsPrec :: Int -> Prop -> String -> String
Show
data Components
= Component Name [(Name, Prop)]
| Variable Name
deriving Int -> Components -> String -> String
[Components] -> String -> String
Components -> String
(Int -> Components -> String -> String)
-> (Components -> String)
-> ([Components] -> String -> String)
-> Show Components
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Components] -> String -> String
$cshowList :: [Components] -> String -> String
show :: Components -> String
$cshow :: Components -> String
showsPrec :: Int -> Components -> String -> String
$cshowsPrec :: Int -> Components -> String -> String
Show
constructBind :: Name -> [TyVarBndrUnit] -> [Con] -> ExpQ
constructBind :: Name -> [TyVarBndr] -> [Con] -> ExpQ
constructBind Name
name [TyVarBndr]
vars [Con]
cons = do
[Components] -> ExpQ
interpret ([Components] -> ExpQ) -> Q [Components] -> ExpQ
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
[Con] -> (Con -> Q Components) -> Q [Components]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Con]
constructors ((Con -> Q Components) -> Q [Components])
-> (Con -> Q Components) -> Q [Components]
forall a b. (a -> b) -> a -> b
$ \Con
con -> do
case Con
con of
NormalC Name
conName [(Bang
_, Kind
_)]
| Name
conName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
var
-> Components -> Q Components
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 ([(Name, Prop)] -> Components) -> Q [(Name, Prop)] -> Q Components
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Kind -> Q (Name, Prop)) -> Cxt -> Q [(Name, Prop)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> Q (Name, Prop)
typeToBnd [ Kind
ty | (Bang
_, Kind
ty) <- [BangType]
types ]
RecC Name
conName [VarBangType]
types
-> Name -> [(Name, Prop)] -> Components
Component Name
conName ([(Name, Prop)] -> Components) -> Q [(Name, Prop)] -> Q Components
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Kind -> Q (Name, Prop)) -> Cxt -> Q [(Name, Prop)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> Q (Name, Prop)
typeToBnd [ Kind
ty | (Name
_, Bang
_, Kind
ty) <- [VarBangType]
types ]
InfixC (Bang
_, Kind
a) Name
conName (Bang
_, Kind
b)
-> do
(Name, Prop)
bndA <- Kind -> Q (Name, Prop)
typeToBnd Kind
a
(Name, Prop)
bndB <- Kind -> Q (Name, Prop)
typeToBnd Kind
b
Components -> Q Components
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [(Name, Prop)] -> Components
Component Name
conName [(Name, Prop)
bndA, (Name, Prop)
bndB])
Con
_ -> String -> Q Components
forall a. HasCallStack => String -> a
error String
"Not implemented."
where
expa :: Type
expa :: Kind
expa = Name
name Name -> Cxt -> Kind
`conAppsT` (Name -> Kind) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Kind
VarT ([TyVarBndr] -> [Name]
forall flag. [TyVarBndr] -> [Name]
typeVars [TyVarBndr]
vars)
typeToBnd :: Type -> Q (Name, Prop)
typeToBnd :: Kind -> Q (Name, Prop)
typeToBnd Kind
ty = do
Bool
boundInstance <- Kind -> Q Bool
isBound Kind
ty
Maybe Int
functorApp <- Kind -> Q (Maybe Int)
isFunctorApp Kind
ty
Name
var <- String -> Q Name
newName String
"var"
(Name, Prop) -> Q (Name, Prop)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Name, Prop) -> Q (Name, Prop)) -> (Name, Prop) -> Q (Name, Prop)
forall a b. (a -> b) -> a -> b
$ case () of
()
_ | Kind
ty Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
expa -> (Name
var, Prop
Exp)
| Bool
boundInstance -> (Name
var, Prop
Bound)
| Kind -> Bool
isKonst Kind
ty -> (Name
var, Prop
Konst)
| Just Int
n <- Maybe Int
functorApp -> (Name
var, Int -> Prop
Funktor Int
n)
| Bool
otherwise -> String -> (Name, Prop)
forall a. HasCallStack => String -> a
error (String -> (Name, Prop)) -> String -> (Name, Prop)
forall a b. (a -> b) -> a -> b
$ String
"This is bad: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ty
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String
forall a. Show a => a -> String
show Bool
boundInstance
isBound :: Type -> Q Bool
isBound :: Kind -> Q Bool
isBound Kind
ty
| Just Kind
a <- Kind -> Maybe Kind
stripLast2 Kind
ty = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False Q Bool -> Q Bool -> Q Bool
forall a. Q a -> Q a -> Q a
`recover` Name -> Cxt -> Q Bool
isInstance ''Bound [Kind
a]
| Bool
otherwise = Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isKonst :: Type -> Bool
isKonst :: Kind -> Bool
isKonst ConT {} = Bool
True
isKonst (VarT Name
n) = Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= TyVarBndr -> Name
forall flag. TyVarBndr -> Name
tvName ([TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
vars)
isKonst (AppT Kind
a Kind
b) = Kind -> Bool
isKonst Kind
a Bool -> Bool -> Bool
&& Kind -> Bool
isKonst Kind
b
isKonst Kind
_ = Bool
False
isFunctorApp :: Type -> Q (Maybe Int)
isFunctorApp :: Kind -> Q (Maybe Int)
isFunctorApp = MaybeT Q Int -> Q (Maybe Int)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Q Int -> Q (Maybe Int))
-> (Kind -> MaybeT Q Int) -> Kind -> Q (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> MaybeT Q Int
forall (t :: (* -> *) -> * -> *) a.
(Num a, MonadTrans t, MonadPlus (t Q)) =>
Kind -> t Q a
go
where
go :: Kind -> t Q a
go Kind
x | Kind
x Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
expa = a -> t Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
0
go (Kind
f `AppT` Kind
x) = do
Bool
isFunctor <- Q Bool -> t Q Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Bool -> t Q Bool) -> Q Bool -> t Q Bool
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> Q Bool
isInstance ''Functor [Kind
f]
Bool -> t Q ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isFunctor
a
n <- Kind -> t Q a
go Kind
x
a -> t Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> t Q a) -> a -> t Q a
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1
go Kind
_ = t Q a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
interpret :: [Components] -> ExpQ
interpret :: [Components] -> ExpQ
interpret [Components]
bnds = do
Name
x <- String -> Q Name
newName String
"x"
Name
f <- String -> Q Name
newName String
"f"
let
bind :: Components -> MatchQ
bind :: Components -> MatchQ
bind (Variable Name
name) = do
Name
a <- String -> Q Name
newName String
"a"
PatQ -> BodyQ -> [DecQ] -> MatchQ
match
(Name -> [PatQ] -> PatQ
conP Name
name [Name -> PatQ
varP Name
a])
(ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
f ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
a))
[]
bind (Component Name
name [(Name, Prop)]
bounds) = do
Exp
exprs <- (Exp -> (Name, Prop) -> ExpQ) -> Exp -> [(Name, Prop)] -> ExpQ
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
Match -> MatchQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> MatchQ) -> Match -> MatchQ
forall a b. (a -> b) -> a -> b
$
Pat -> Body -> [Dec] -> Match
Match
(Name -> [Pat] -> Pat
ConP Name
name [ 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 ->
Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE '(>>>=) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
name ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
f)
Prop
Konst ->
Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
name
Prop
Exp ->
Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE '(>>=) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
name ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
f)
Funktor Int
n ->
Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
expr ExpQ -> ExpQ -> ExpQ
`appE` (Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Exp
fmapN Int
n) ExpQ -> ExpQ -> ExpQ
`appE` (Name -> ExpQ
varE '(>>=) ExpQ -> ExpQ -> ExpQ
`sectionR` Name -> ExpQ
varE Name
f) ExpQ -> ExpQ -> ExpQ
`appE` Name -> ExpQ
varE Name
name)
fmapN :: Int -> Exp
fmapN :: Int -> Exp
fmapN Int
n = (Exp -> Exp -> Exp) -> [Exp] -> Exp
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) ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
n (Name -> Exp
VarE 'fmap)
[Match]
matches <- [Components] -> (Components -> MatchQ) -> Q [Match]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Components]
bnds Components -> MatchQ
bind
Exp -> ExpQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> ExpQ) -> Exp -> ExpQ
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 :: Kind -> Maybe Kind
stripLast2 (Kind
a `AppT` Kind
b `AppT` Kind
_ `AppT` Kind
d)
| AppT{} <- Kind
d = Maybe Kind
forall a. Maybe a
Nothing
| Bool
otherwise = Kind -> Maybe Kind
forall a. a -> Maybe a
Just (Kind
a Kind -> Kind -> Kind
`AppT` Kind
b)
stripLast2 Kind
_ = Maybe Kind
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 :: Kind -> [(Name, Cxt)] -> Name
findReturn Kind
ty [(Name, Cxt)]
constrs =
case [ Name
constr | (Name
constr, [Kind
ty']) <- [(Name, Cxt)]
constrs, Kind
ty' Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
ty ] of
[] -> String -> Name
forall a. HasCallStack => String -> a
error String
"Too few candidates for a variable constructor."
[Name
x] -> Name
x
[Name]
xs -> String -> Name
forall a. HasCallStack => String -> a
error (String
"Too many candidates: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name -> String
forall a. Ppr a => a -> String
pprint [Name]
xs))
lastTyVar :: Type
lastTyVar :: Kind
lastTyVar = Name -> Kind
VarT ([Name] -> Name
forall a. [a] -> a
last ([TyVarBndr] -> [Name]
forall flag. [TyVarBndr] -> [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, [ Kind
ty | (Bang
_, Kind
ty) <- [BangType]
tys ])
RecC Name
conName [VarBangType]
tys ->
(Name
conName, [ Kind
ty | (Name
_, Bang
_, Kind
ty) <- [VarBangType]
tys ])
InfixC (Bang
_, Kind
t1) Name
conName (Bang
_, Kind
t2) ->
(Name
conName, [ Kind
t1, Kind
t2 ])
ForallC [TyVarBndr]
_ Cxt
_ Con
conName ->
Con -> (Name, Cxt)
allTypeArgs Con
conName
#if MIN_VERSION_template_haskell(2,11,0)
Con
_ -> String -> (Name, Cxt)
forall a. HasCallStack => String -> a
error String
"Not implemented"
#endif
Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> [(Name, Cxt)] -> Name
findReturn Kind
lastTyVar (Con -> (Name, Cxt)
allTypeArgs (Con -> (Name, Cxt)) -> [Con] -> [(Name, Cxt)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Con]
cons))
#else
#endif
typeVars :: [TyVarBndr_ flag] -> [Name]
typeVars :: [TyVarBndr] -> [Name]
typeVars = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
forall flag. TyVarBndr -> Name
tvName
conAppsT :: Name -> [Type] -> Type
conAppsT :: Name -> Cxt -> Kind
conAppsT Name
conName = (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
conName)