{-# LANGUAGE CPP, TemplateHaskell, TypeOperators #-}
module Text.Boomerang.TH
( makeBoomerangs
, derivePrinterParsers
) where
import Control.Monad (liftM, replicateM)
import Language.Haskell.TH
import Language.Haskell.TH.Datatype.TyVarBndr
import Text.Boomerang.HStack ((:-)(..), arg)
import Text.Boomerang.Prim (xpure, Boomerang)
makeBoomerangs :: Name -> Q [Dec]
makeBoomerangs :: Name -> Q [Dec]
makeBoomerangs Name
name = do
Info
info <- Name -> Q Info
reify Name
name
case Info
info of
#if MIN_VERSION_template_haskell(2,11,0)
TyConI (DataD Cxt
_ Name
tName [TyVarBndr ()]
tBinds Maybe Kind
_ [Con]
cons [DerivClause]
_) ->
#else
TyConI (DataD _ tName tBinds cons _) ->
#endif
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name, [TyVarBndr ()]) -> Con -> Q [Dec]
deriveBoomerang (Name
tName, [TyVarBndr ()]
tBinds)) [Con]
cons
#if MIN_VERSION_template_haskell(2,11,0)
TyConI (NewtypeD Cxt
_ Name
tName [TyVarBndr ()]
tBinds Maybe Kind
_ Con
con [DerivClause]
_) ->
#else
TyConI (NewtypeD _ tName tBinds con _) ->
#endif
(Name, [TyVarBndr ()]) -> Con -> Q [Dec]
deriveBoomerang (Name
tName, [TyVarBndr ()]
tBinds) Con
con
Info
_ ->
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
" is not a datatype."
derivePrinterParsers :: Name -> Q [Dec]
derivePrinterParsers :: Name -> Q [Dec]
derivePrinterParsers = Name -> Q [Dec]
makeBoomerangs
{-# DEPRECATED derivePrinterParsers "Use makeBoomerangs instead" #-}
deriveBoomerang :: (Name, [TyVarBndrUnit]) -> Con -> Q [Dec]
deriveBoomerang :: (Name, [TyVarBndr ()]) -> Con -> Q [Dec]
deriveBoomerang (Name
tName, [TyVarBndr ()]
tParams) Con
con =
case Con
con of
NormalC Name
name [BangType]
tys -> Name -> Cxt -> Q [Dec]
go Name
name (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [BangType]
tys)
RecC Name
name [VarBangType]
tys -> Name -> Cxt -> Q [Dec]
go Name
name (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_,Bang
_,Kind
ty) -> Kind
ty) [VarBangType]
tys)
Con
_ -> do
forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Skipping unsupported constructor " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Con -> Name
conName Con
con)
forall (m :: * -> *) a. Monad m => a -> m a
return []
where
go :: Name -> Cxt -> Q [Dec]
go Name
name Cxt
tys = do
let name' :: Name
name' = Name -> Name
mkBoomerangName Name
name
let tok' :: Name
tok' = String -> Name
mkName String
"tok"
let e' :: Name
e' = String -> Name
mkName String
"e"
let ppType :: Kind
ppType = Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''Boomerang) (Name -> Kind
VarT Name
e')) (Name -> Kind
VarT Name
tok')
let r' :: Name
r' = String -> Name
mkName String
"r"
let inT :: Kind
inT = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Kind
a Kind
b -> Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''(:-)) Kind
a) Kind
b) (Name -> Kind
VarT Name
r') Cxt
tys
let outT :: Kind
outT = Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''(:-))
(forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
tName) (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Kind
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall flag. TyVarBndr_ flag -> Name
tvName) [TyVarBndr ()]
tParams)))
(Name -> Kind
VarT Name
r')
Exp
expr <- [| xpure $(deriveConstructor name (length tys))
$(deriveDestructor name tys) |]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Kind -> Dec
SigD Name
name'
([TyVarBndr Specificity] -> Cxt -> Kind -> Kind
ForallT (forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr Specificity
plainTVSpecified ([Name
tok', Name
e', Name
r'] forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> b) -> [a] -> [b]
map forall flag. TyVarBndr_ flag -> Name
tvName [TyVarBndr ()]
tParams)))
[]
(Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
ppType Kind
inT) Kind
outT))
, Name -> [Clause] -> Dec
FunD Name
name' [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expr) []]
]
deriveConstructor :: Name -> Int -> Q Exp
deriveConstructor :: Name -> Int -> Q Exp
deriveConstructor Name
name Int
arity = [| $(mk arity) $(conE name) |]
where
mk :: Int -> ExpQ
mk :: Int -> Q Exp
mk Int
0 = [| (:-) |]
mk Int
n = [| arg $(mk (n - 1)) |]
deriveDestructor :: Name -> [Type] -> Q Exp
deriveDestructor :: Name -> Cxt -> Q Exp
deriveDestructor Name
name Cxt
tys = do
Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"r"
[Name]
fieldNames <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tys) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"a")
Exp
nothing <- [| Nothing |]
ConE Name
just <- [| Just |]
ConE Name
left <- [| Left |]
ConE Name
right <- [| Right |]
ConE Name
cons <- [| (:-) |]
let conPat :: Pat
conPat = Name -> [Pat] -> Pat
conPCompat Name
name (forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
fieldNames)
let okBody :: Exp
okBody = Name -> Exp
ConE Name
just Exp -> Exp -> Exp
`AppE`
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\Name
h Exp
t -> Name -> Exp
ConE Name
cons Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
h Exp -> Exp -> Exp
`AppE` Exp
t)
(Name -> Exp
VarE Name
r)
[Name]
fieldNames
let okCase :: Match
okCase = Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
conPCompat Name
cons [Pat
conPat, Name -> Pat
VarP Name
r]) (Exp -> Body
NormalB Exp
okBody) []
let nStr :: String
nStr = forall a. Show a => a -> String
show Name
name
let failCase :: Match
failCase = Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
nothing) []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
x] (Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
x) [Match
okCase, Match
failCase])
mkBoomerangName :: Name -> Name
mkBoomerangName :: Name -> Name
mkBoomerangName Name
name = String -> Name
mkName (Char
'r' forall a. a -> [a] -> [a]
: Name -> String
nameBase Name
name)
conName :: Con -> Name
conName :: Con -> Name
conName Con
con =
case Con
con of
NormalC Name
name [BangType]
_ -> Name
name
RecC Name
name [VarBangType]
_ -> Name
name
InfixC BangType
_ Name
name BangType
_ -> Name
name
ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
con' -> Con -> Name
conName Con
con'
conPCompat :: Name -> [Pat] -> Pat
conPCompat :: Name -> [Pat] -> Pat
conPCompat Name
n [Pat]
pats = Name -> Cxt -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
[]
#endif
[Pat]
pats