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