{-# LANGUAGE CPP, TemplateHaskell, TypeOperators #-}
module Text.Boomerang.TH
    ( makeBoomerangs
    -- * Backwards-compatibility
    , derivePrinterParsers
    ) where

import Control.Monad       (liftM, replicateM)
import Language.Haskell.TH
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
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."

-- | 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, [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')
      -- 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 -> 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) []]
             ]


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


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

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


-- Derive the name of a router based on the name of the constructor in question.
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)


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