{-# LANGUAGE CPP             #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE TemplateHaskell #-}
module Free.Scoped.TH where

import           Control.Monad       (replicateM)
import           Free.Scoped
import           Language.Haskell.TH

mkConP :: Name -> [Pat] -> Pat
#if __GLASGOW_HASKELL__ >= 902
mkConP :: Name -> [Pat] -> Pat
mkConP Name
name [Pat]
pats = Name -> [Type] -> [Pat] -> Pat
ConP Name
name [] [Pat]
pats
#else
mkConP name pats = ConP name pats
#endif

makePatternsAll :: Name -> Q [Dec]
makePatternsAll :: Name -> Q [Dec]
makePatternsAll Name
ty = do
  TyConI tyCon <- Name -> Q Info
reify Name
ty
  case tyCon of
    DataD [Type]
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
cs [DerivClause]
_ -> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      xs <- (Con -> Q [Dec]) -> [Con] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Con -> Q [Dec]
makePatternFor [Con]
cs
      xs' <- makeCompletePragma cs
      ys <- mapM makePatternEFor cs
      ys' <- makeCompletePragmaE cs
      zs <- mapM makePatternTFor cs
      zs' <- makeCompletePragmaT cs
      ws <- mapM makePatternTEFor cs
      ws' <- makeCompletePragmaTE cs
      return (xs ++ [xs'] ++ ys ++ [ys'] ++ zs ++ [zs'] ++ ws ++ [ws'])

    Dec
_                  -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can only make patterns for data types."


makeCompletePragma :: [Con] -> Q [Dec]
makeCompletePragma :: [Con] -> Q [Dec]
makeCompletePragma [Con]
cs = do
  DataConI varName _ _ <- Name -> Q Info
reify 'Pure
  let names = [String -> Name
mkName (String -> String
forall {a}. [a] -> [a]
removeF (Name -> String
nameBase Name
name)) | NormalC Name
name [BangType]
_ <- [Con]
cs]
  return [PragmaD (CompleteP (varName : names) Nothing)]
  where
    removeF :: [a] -> [a]
removeF [a]
s = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
s

makeCompletePragmaE :: [Con] -> Q [Dec]
makeCompletePragmaE :: [Con] -> Q [Dec]
makeCompletePragmaE [Con]
cs = do
  DataConI varName _ _ <- Name -> Q Info
reify 'Pure
  PatSynI extName _ <- reify 'ExtE
  let names = [String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name)) | NormalC Name
name [BangType]
_ <- [Con]
cs]
  return [PragmaD (CompleteP (varName : extName : names) Nothing)]
  where
    removeF :: String -> String
removeF String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"E"

makeCompletePragmaT :: [Con] -> Q [Dec]
makeCompletePragmaT :: [Con] -> Q [Dec]
makeCompletePragmaT [Con]
cs = do
  DataConI varName _ _ <- Name -> Q Info
reify 'Pure
  let names = [String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name)) | NormalC Name
name [BangType]
_ <- [Con]
cs]
  return [PragmaD (CompleteP (varName : names) Nothing)]
  where
    removeF :: String -> String
removeF String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"T"

makeCompletePragmaTE :: [Con] -> Q [Dec]
makeCompletePragmaTE :: [Con] -> Q [Dec]
makeCompletePragmaTE [Con]
cs = do
  DataConI varName _ _ <- Name -> Q Info
reify 'Pure
  let names = [String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name)) | NormalC Name
name [BangType]
_ <- [Con]
cs]
  return [PragmaD (CompleteP (varName : names) Nothing)]
  where
    removeF :: String -> String
removeF String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"TE"

makePatternFor :: Con -> Q [Dec]
makePatternFor :: Con -> Q [Dec]
makePatternFor = \case
  NormalC Name
name [BangType]
xs -> do
    args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
xs) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
    let patName = String -> Name
mkName (String -> String
forall {a}. [a] -> [a]
removeF (Name -> String
nameBase Name
name))
        patArgs = [Name] -> PatSynArgs
PrefixPatSyn [Name]
args
        dir = PatSynDir
ImplBidir
    pat <- [p| Free $(pure (mkConP name (VarP <$> args))) |]
    return [PatSynD patName patArgs dir pat]
  Con
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can only make patterns for NormalC constructors"
  where
    removeF :: [a] -> [a]
removeF [a]
s = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
s

makePatternEFor :: Con -> Q [Dec]
makePatternEFor :: Con -> Q [Dec]
makePatternEFor = \case
  NormalC Name
name [BangType]
xs -> do
    args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
xs) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
    let patName = String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name))
        patArgs = [Name] -> PatSynArgs
PrefixPatSyn [Name]
args
        dir = PatSynDir
ImplBidir
    pat <- [p| Free (InL $(pure (mkConP name (VarP <$> args)))) |]
    return [PatSynD patName patArgs dir pat]
  Con
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can only make patterns for NormalC constructors"
  where
    removeF :: String -> String
removeF String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"E"

makePatternTFor :: Con -> Q [Dec]
makePatternTFor :: Con -> Q [Dec]
makePatternTFor = \case
  NormalC Name
name [BangType]
xs -> do
    t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"type_"
    args <- replicateM (length xs) (newName "x")
    let patName = String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name))
        patArgs = [Name] -> PatSynArgs
PrefixPatSyn (Name
t Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
args)
        dir = PatSynDir
ImplBidir
    pat <- [p| Free (AnnF $(pure (VarP t)) $(pure (mkConP name (VarP <$> args)))) |]
    return [PatSynD patName patArgs dir pat]
  Con
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can only make patterns for NormalC constructors"
  where
    removeF :: String -> String
removeF String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"T"

makePatternTEFor :: Con -> Q [Dec]
makePatternTEFor :: Con -> Q [Dec]
makePatternTEFor = \case
  NormalC Name
name [BangType]
xs -> do
    t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"type_"
    args <- replicateM (length xs) (newName "x")
    let patName = String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name))
        patArgs = [Name] -> PatSynArgs
PrefixPatSyn (Name
t Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
args)
        dir = PatSynDir
ImplBidir
    pat <- [p| Free (InL (AnnF $(pure (VarP t)) $(pure (mkConP name (VarP <$> args))))) |]
    return [PatSynD patName patArgs dir pat]
  Con
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can only make patterns for NormalC constructors"
  where
    removeF :: String -> String
removeF String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"TE"