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

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

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

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

makeCompletePragmaTE :: [Con] -> Q [Dec]
makeCompletePragmaTE :: [Con] -> Q [Dec]
makeCompletePragmaTE [Con]
cs = do
  DataConI Name
varName Type
_ Name
_ <- Name -> Q Info
reify 'Pure
  let names :: [Name]
names = [String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name)) | NormalC Name
name [BangType]
_ <- [Con]
cs]
  forall (m :: * -> *) a. Monad m => a -> m a
return [Pragma -> Dec
PragmaD ([Name] -> Maybe Name -> Pragma
CompleteP (Name
varName forall a. a -> [a] -> [a]
: [Name]
names) forall a. Maybe a
Nothing)]
  where
    removeF :: String -> String
removeF String
s = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Num a => a -> a -> a
- Int
1) String
s 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
    [Name]
args <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
xs) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
    let patName :: Name
patName = String -> Name
mkName (forall {a}. [a] -> [a]
removeF (Name -> String
nameBase Name
name))
        patArgs :: PatSynArgs
patArgs = [Name] -> PatSynArgs
PrefixPatSyn [Name]
args
        dir :: PatSynDir
dir = PatSynDir
ImplBidir
    Pat
pat <- [p| Free $(pure (mkConP name (VarP <$> args))) |]
    forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
patName PatSynArgs
patArgs PatSynDir
dir Pat
pat]
  Con
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can only make patterns for NormalC constructors"
  where
    removeF :: [a] -> [a]
removeF [a]
s = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s 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
    [Name]
args <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
xs) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
    let patName :: Name
patName = String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name))
        patArgs :: PatSynArgs
patArgs = [Name] -> PatSynArgs
PrefixPatSyn [Name]
args
        dir :: PatSynDir
dir = PatSynDir
ImplBidir
    Pat
pat <- [p| Free (InL $(pure (mkConP name (VarP <$> args)))) |]
    forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
patName PatSynArgs
patArgs PatSynDir
dir Pat
pat]
  Con
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can only make patterns for NormalC constructors"
  where
    removeF :: String -> String
removeF String
s = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Num a => a -> a -> a
- Int
1) String
s 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
    Name
t <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"type_"
    [Name]
args <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
xs) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
    let patName :: Name
patName = String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name))
        patArgs :: PatSynArgs
patArgs = [Name] -> PatSynArgs
PrefixPatSyn (Name
t forall a. a -> [a] -> [a]
: [Name]
args)
        dir :: PatSynDir
dir = PatSynDir
ImplBidir
    Pat
pat <- [p| Free (AnnF $(pure (VarP t)) $(pure (mkConP name (VarP <$> args)))) |]
    forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
patName PatSynArgs
patArgs PatSynDir
dir Pat
pat]
  Con
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can only make patterns for NormalC constructors"
  where
    removeF :: String -> String
removeF String
s = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Num a => a -> a -> a
- Int
1) String
s 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
    Name
t <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"type_"
    [Name]
args <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
xs) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
    let patName :: Name
patName = String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name))
        patArgs :: PatSynArgs
patArgs = [Name] -> PatSynArgs
PrefixPatSyn (Name
t forall a. a -> [a] -> [a]
: [Name]
args)
        dir :: PatSynDir
dir = PatSynDir
ImplBidir
    Pat
pat <- [p| Free (InL (AnnF $(pure (VarP t)) $(pure (mkConP name (VarP <$> args))))) |]
    forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
patName PatSynArgs
patArgs PatSynDir
dir Pat
pat]
  Con
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can only make patterns for NormalC constructors"
  where
    removeF :: String -> String
removeF String
s = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s forall a. Num a => a -> a -> a
- Int
1) String
s forall a. Semigroup a => a -> a -> a
<> String
"TE"