{-# 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 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
      [[Dec]]
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
      [Dec]
xs' <- [Con] -> Q [Dec]
makeCompletePragma [Con]
cs
      [[Dec]]
ys <- (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]
makePatternEFor [Con]
cs
      [Dec]
ys' <- [Con] -> Q [Dec]
makeCompletePragmaE [Con]
cs
      [[Dec]]
zs <- (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]
makePatternTFor [Con]
cs
      [Dec]
zs' <- [Con] -> Q [Dec]
makeCompletePragmaT [Con]
cs
      [[Dec]]
ws <- (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]
makePatternTEFor [Con]
cs
      [Dec]
ws' <- [Con] -> Q [Dec]
makeCompletePragmaTE [Con]
cs
      [[Dec]] -> Q [[Dec]]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]]
xs [[Dec]] -> [[Dec]] -> [[Dec]]
forall a. [a] -> [a] -> [a]
++ [[Dec]
xs'] [[Dec]] -> [[Dec]] -> [[Dec]]
forall a. [a] -> [a] -> [a]
++ [[Dec]]
ys [[Dec]] -> [[Dec]] -> [[Dec]]
forall a. [a] -> [a] -> [a]
++ [[Dec]
ys'] [[Dec]] -> [[Dec]] -> [[Dec]]
forall a. [a] -> [a] -> [a]
++ [[Dec]]
zs [[Dec]] -> [[Dec]] -> [[Dec]]
forall a. [a] -> [a] -> [a]
++ [[Dec]
zs'] [[Dec]] -> [[Dec]] -> [[Dec]]
forall a. [a] -> [a] -> [a]
++ [[Dec]]
ws [[Dec]] -> [[Dec]] -> [[Dec]]
forall a. [a] -> [a] -> [a]
++ [[Dec]
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 Name
varName Type
_ Name
_ <- Name -> Q Info
reify 'Pure
  let names :: [Name]
names = [String -> Name
mkName (String -> String
forall {a}. [a] -> [a]
removeF (Name -> String
nameBase Name
name)) | NormalC Name
name [BangType]
_ <- [Con]
cs]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Pragma -> Dec
PragmaD ([Name] -> Maybe Name -> Pragma
CompleteP (Name
varName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
names) Maybe Name
forall a. Maybe a
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 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]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Pragma -> Dec
PragmaD ([Name] -> Maybe Name -> Pragma
CompleteP (Name
varName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: Name
extName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
names) Maybe Name
forall a. Maybe a
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 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]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Pragma -> Dec
PragmaD ([Name] -> Maybe Name -> Pragma
CompleteP (Name
varName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
names) Maybe Name
forall a. Maybe a
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 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]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Pragma -> Dec
PragmaD ([Name] -> Maybe Name -> Pragma
CompleteP (Name
varName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
names) Maybe Name
forall a. Maybe a
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
    [Name]
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 :: Name
patName = String -> Name
mkName (String -> String
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 $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
mkConP Name
name (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args))) |]
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
patName PatSynArgs
patArgs PatSynDir
dir Pat
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
    [Name]
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 :: 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 $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
mkConP Name
name (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)))) |]
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
patName PatSynArgs
patArgs PatSynDir
dir Pat
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
    Name
t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"type_"
    [Name]
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 :: Name
patName = String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name))
        patArgs :: PatSynArgs
patArgs = [Name] -> PatSynArgs
PrefixPatSyn (Name
t Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
args)
        dir :: PatSynDir
dir = PatSynDir
ImplBidir
    Pat
pat <- [p| Free (AnnF $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Pat
VarP Name
t)) $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
mkConP Name
name (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args)))) |]
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
patName PatSynArgs
patArgs PatSynDir
dir Pat
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
    Name
t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"type_"
    [Name]
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 :: Name
patName = String -> Name
mkName (String -> String
removeF (Name -> String
nameBase Name
name))
        patArgs :: PatSynArgs
patArgs = [Name] -> PatSynArgs
PrefixPatSyn (Name
t Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
args)
        dir :: PatSynDir
dir = PatSynDir
ImplBidir
    Pat
pat <- [p| Free (InL (AnnF $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Pat
VarP Name
t)) $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> [Pat] -> Pat
mkConP Name
name (Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
args))))) |]
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name -> PatSynArgs -> PatSynDir -> Pat -> Dec
PatSynD Name
patName PatSynArgs
patArgs PatSynDir
dir Pat
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"