{-# LANGUAGE CPP, TemplateHaskell, TypeOperators #-}
module Text.Boomerang.TH
    ( makeBoomerangs
    -- * Backwards-compatibility
    , 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)

-- | Make a 'Boomerang' router for each constructor in a datatype. For
-- example:
--
--   @$(makeBoomerangs \'\'Sitemap)@
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."

-- | Old name for 'makeBoomerangs', since renamed to reflect the fact
-- that it's not actually deriving instances for any type class, but rather
-- generates top-level definitions for routers of type 'Boomerang'.
derivePrinterParsers :: Name -> Q [Dec]
derivePrinterParsers :: Name -> Q [Dec]
derivePrinterParsers = Name -> Q [Dec]
makeBoomerangs
{-# DEPRECATED derivePrinterParsers "Use makeBoomerangs instead" #-}

-- Derive a router for a single constructor.
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')
      -- runIO $ putStrLn $ "Introducing router " ++ nameBase name' ++ "."
      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) []]
             ]


-- Derive the contructor part of a router.
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)) |]


-- Derive the destructor part of a router.
deriveDestructor :: Name -> [Type] -> Q Exp
deriveDestructor :: Name -> Cxt -> Q Exp
deriveDestructor Name
name Cxt
tys = do
  -- Introduce some names
  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")

  -- Figure out the names of some constructors
  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])


-- Derive the name of a router based on the name of the constructor in question.
mkBoomerangName :: Name -> Name
mkBoomerangName :: Name -> Name
mkBoomerangName Name
name = String -> Name
mkName (Char
'r' forall a. a -> [a] -> [a]
: Name -> String
nameBase Name
name)


-- Retrieve the name of a constructor.
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