{-# 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
      [[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 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
_ ->
      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]
++ 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 ((BangType -> Kind) -> [BangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Kind
forall a b. (a, b) -> b
snd [BangType]
tys)
    RecC Name
name [VarBangType]
tys -> Name -> Cxt -> Q [Dec]
go Name
name ((VarBangType -> Kind) -> [VarBangType] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_,Bang
_,Kind
ty) -> Kind
ty) [VarBangType]
tys)
    Con
_ -> 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
$ String
"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
    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 = (Kind -> Kind -> Kind) -> Kind -> Cxt -> Kind
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 ''(:-))
                            ((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
tName) ((TyVarBndr -> Kind) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Kind
VarT (Name -> Kind) -> (TyVarBndr -> Name) -> TyVarBndr -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
forall flag. TyVarBndr -> 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) |]
      [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Name -> Kind -> Dec
SigD Name
name'
                    ([TyVarBndr] -> Cxt -> Kind -> Kind
ForallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
plainTVSpecified ([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
forall flag. TyVarBndr -> 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          <- String -> Q Name
newName String
"x"
  Name
r          <- String -> Q Name
newName String
"r"
  [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Cxt -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
tys) (String -> Q 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 ((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
                    (\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 = 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])


-- 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' Char -> String -> String
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]
_ Cxt
_ Con
con' -> Con -> Name
conName Con
con'

conPCompat :: Name -> [Pat] -> Pat
conPCompat :: Name -> [Pat] -> Pat
conPCompat Name
n [Pat]
pats = Name -> [Pat] -> Pat
ConP Name
n
#if MIN_VERSION_template_haskell(2,18,0)
                           []
#endif
                           [Pat]
pats