{-|
Copyright  :  (C) 2024-2025, Felix Klein
License    :  MIT (see the file LICENSE)
Maintainer :  Felix Klein <felix@qbaylogic.com>
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_HADDOCK hide #-}

module Clash.Class.Finite.Internal.TH where

import Control.Monad (forM, replicateM)
#if !MIN_VERSION_base(4,20,0)
import Data.List (foldl')
#endif
import GHC.TypeNats (type (*))
import Language.Haskell.TH

#ifndef MAX_TUPLE_SIZE
#ifdef LARGE_TUPLES
#if MIN_VERSION_ghc(9,0,0)
import GHC.Settings.Constants (mAX_TUPLE_SIZE)
#else
import Constants (mAX_TUPLE_SIZE)
#endif
#define MAX_TUPLE_SIZE (fromIntegral mAX_TUPLE_SIZE)
#else
#define MAX_TUPLE_SIZE 12
#endif
#endif

maxTupleSize :: Num a => a
maxTupleSize :: forall a. Num a => a
maxTupleSize = MAX_TUPLE_SIZE

-- | Contruct all the tuple instances (starting at size 3) for
-- 'Clash.Class.Finite.Internal.Finite'.
deriveFiniteTuples ::
  -- | Finite
  Name ->
  -- | ElementCount
  Name ->
  -- | elements
  Name ->
  -- | lowest
  Name ->
  -- | lowestMaybe
  Name ->
  -- | highest
  Name ->
  -- | highestMaybe
  Name ->
  -- | predMaybe
  Name ->
  -- | succMaybe
  Name ->
  -- | ith
  Name ->
  -- | index
  Name ->
  DecsQ
deriveFiniteTuples :: Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> Name
-> DecsQ
deriveFiniteTuples Name
finiteName Name
elementCountName Name
elementsName Name
lowestName
  Name
lowestMaybeName Name
highestName Name
highestMaybeName Name
predMaybeName Name
succMaybeName
  Name
ithName Name
indexName
  = do
    let finite :: Type
finite = Name -> Type
ConT Name
finiteName
        elementCount :: Type
elementCount = Name -> Type
ConT Name
elementCountName
        times :: Type
times = Name -> Type
ConT ''(*)

    [Name]
allNames <- Int -> Q Name -> Q [Name]
forall (m :: Type -> Type) a. Applicative m => Int -> m a -> m [a]
replicateM Int
forall a. Num a => a
maxTupleSize (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"a"
    Name
t2N <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"t2N"
    Name
tN2 <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"tN2"
    Name
x <- String -> Q Name
forall (m :: Type -> Type). Quote m => String -> m Name
newName String
"x"

    [Int] -> (Int -> Q Dec) -> DecsQ
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
3..Int
forall a. Num a => a
maxTupleSize] ((Int -> Q Dec) -> DecsQ) -> (Int -> Q Dec) -> DecsQ
forall a b. (a -> b) -> a -> b
$ \Int
tupleNum -> do
      let names :: [Name]
names = Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
take Int
tupleNum [Name]
allNames
          (Type
v,[Type]
vs) = case (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
names of
                      (Type
z:[Type]
zs) -> (Type
z,[Type]
zs)
                      [Type]
_ -> String -> (Type, [Type])
forall a. HasCallStack => String -> a
error String
"maxTupleSize < 3"
          tuple :: t Type -> Type
tuple t Type
xs = (Type -> Type -> Type) -> Type -> t Type -> Type
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Int -> Type
TupleT (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ t Type -> Int
forall a. t a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length t Type
xs) t Type
xs
          withConvContext :: Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
b2N Bool
bN2 [Pat]
binds Exp
impl = Clause -> m Clause
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return
            (Clause -> m Clause) -> Clause -> m Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
binds (Exp -> Body
NormalB Exp
impl)
            ([Dec] -> Clause) -> [Dec] -> Clause
forall a b. (a -> b) -> a -> b
$ ( if Bool
b2N then
                  (:) (Dec -> [Dec] -> [Dec]) -> Dec -> [Dec] -> [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD Name
t2N ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Clause -> [Clause]
forall a. a -> [a]
forall (m :: Type -> Type) a. Monad m => a -> m a
return
                    (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
                        [ [Pat] -> Pat
TupP [ Pat
p, [Pat] -> Pat
TupP [Pat]
ps ]
                        | let (Pat
p,[Pat]
ps) = case (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names of
                                         (Pat
z:[Pat]
zs) -> (Pat
z,[Pat]
zs)
                                         [Pat]
_ -> String -> (Pat, [Pat])
forall a. HasCallStack => String -> a
error String
"maxTupleSize < 3"

                        ]
                        ( Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
mkTupE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
names )
                        []
                else [Dec] -> [Dec]
forall a. a -> a
id
              )
            ([Dec] -> [Dec]) -> [Dec] -> [Dec]
forall a b. (a -> b) -> a -> b
$ ( if Bool
bN2 then
                  (:) (Dec -> [Dec] -> [Dec]) -> Dec -> [Dec] -> [Dec]
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD Name
tN2 ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Clause -> [Clause]
forall a. a -> [a]
forall (m :: Type -> Type) a. Monad m => a -> m a
return
                    (Clause -> [Clause]) -> Clause -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
                        [ [Pat] -> Pat
TupP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
names ]
                        ( let (Exp
e,[Exp]
es) = case (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
names of
                                         (Exp
z:[Exp]
zs) -> (Exp
z,[Exp]
zs)
                                         [Exp]
_ -> String -> (Exp, [Exp])
forall a. HasCallStack => String -> a
error String
"maxTupleSize < 3"
                          in Exp -> Body
NormalB ([Exp] -> Exp
mkTupE [Exp
e,[Exp] -> Exp
mkTupE [Exp]
es])
                        )
                        []
                else [Dec] -> [Dec]
forall a. a -> a
id
              )
              []

          -- Instance declaration
          context :: [Type]
context =
            [ Type
finite Type -> Type -> Type
`AppT` Type
v
            , Type
finite Type -> Type -> Type
`AppT` [Type] -> Type
forall {t :: Type -> Type}. Foldable t => t Type -> Type
tuple [Type]
vs
            ]
          instTy :: Type
instTy = Type -> Type -> Type
AppT Type
finite (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
forall {t :: Type -> Type}. Foldable t => t Type -> Type
tuple (Type
vType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
vs)

          elementCountType :: Dec
elementCountType =
            Name -> [Type] -> Type -> Dec
mkTySynInstD Name
elementCountName [[Type] -> Type
forall {t :: Type -> Type}. Foldable t => t Type -> Type
tuple (Type
vType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
vs)]
              (Type -> Dec) -> Type -> Dec
forall a b. (a -> b) -> a -> b
$ Type
times Type -> Type -> Type
`AppT` (Type
elementCount Type -> Type -> Type
`AppT` Type
v) Type -> Type -> Type
`AppT`
                (Type
elementCount Type -> Type -> Type
`AppT` (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ Int
tupleNum Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Type]
vs)

          elements :: Dec
elements = Name -> [Clause] -> Dec
FunD Name
elementsName
            ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> [Pat] -> Exp -> [Clause]
forall {m :: Type -> Type}.
Monad m =>
Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
True Bool
False []
            (Exp -> [Clause]) -> Exp -> [Clause]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(<$>)) (Name -> Exp
VarE Name
t2N))
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
elementsName

          lowest :: Dec
lowest = Name -> [Clause] -> Dec
FunD Name
lowestName
            ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> [Pat] -> Exp -> [Clause]
forall {m :: Type -> Type}.
Monad m =>
Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
True Bool
False []
            (Exp -> [Clause]) -> Exp -> [Clause]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
t2N)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
lowestName

          lowestMaybe :: Dec
lowestMaybe = Name -> [Clause] -> Dec
FunD Name
lowestMaybeName
            ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> [Pat] -> Exp -> [Clause]
forall {m :: Type -> Type}.
Monad m =>
Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
True Bool
False []
            (Exp -> [Clause]) -> Exp -> [Clause]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(<$>)) (Name -> Exp
VarE Name
t2N))
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
lowestMaybeName

          highest :: Dec
highest = Name -> [Clause] -> Dec
FunD Name
highestName
            ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> [Pat] -> Exp -> [Clause]
forall {m :: Type -> Type}.
Monad m =>
Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
True Bool
False []
            (Exp -> [Clause]) -> Exp -> [Clause]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
t2N)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
highestName

          highestMaybe :: Dec
highestMaybe = Name -> [Clause] -> Dec
FunD Name
highestMaybeName
            ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> [Pat] -> Exp -> [Clause]
forall {m :: Type -> Type}.
Monad m =>
Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
True Bool
False []
            (Exp -> [Clause]) -> Exp -> [Clause]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(<$>)) (Name -> Exp
VarE Name
t2N))
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
highestMaybeName

          predMaybe :: Dec
predMaybe = Name -> [Clause] -> Dec
FunD Name
predMaybeName
            ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> [Pat] -> Exp -> [Clause]
forall {m :: Type -> Type}.
Monad m =>
Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
True Bool
True [ Name -> Pat
VarP Name
x ]
            (Exp -> [Clause]) -> Exp -> [Clause]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(<$>)) (Name -> Exp
VarE Name
t2N))
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
predMaybeName)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
tN2)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x

          succMaybe :: Dec
succMaybe = Name -> [Clause] -> Dec
FunD Name
succMaybeName
            ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> [Pat] -> Exp -> [Clause]
forall {m :: Type -> Type}.
Monad m =>
Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
True Bool
True [ Name -> Pat
VarP Name
x ]
            (Exp -> [Clause]) -> Exp -> [Clause]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(<$>)) (Name -> Exp
VarE Name
t2N))
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
succMaybeName)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
tN2)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x

          ith :: Dec
ith = Name -> [Clause] -> Dec
FunD Name
ithName
            ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> [Pat] -> Exp -> [Clause]
forall {m :: Type -> Type}.
Monad m =>
Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
True Bool
False [ Name -> Pat
VarP Name
x ]
            (Exp -> [Clause]) -> Exp -> [Clause]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
t2N)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
ithName)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x

          index :: Dec
index = Name -> [Clause] -> Dec
FunD Name
indexName
            ([Clause] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> [Pat] -> Exp -> [Clause]
forall {m :: Type -> Type}.
Monad m =>
Bool -> Bool -> [Pat] -> Exp -> m Clause
withConvContext Bool
False Bool
True [ Name -> Pat
VarP Name
x ]
            (Exp -> [Clause]) -> Exp -> [Clause]
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
indexName)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
tN2)
            (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
x

      Dec -> Q Dec
forall a. a -> Q a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
context Type
instTy
        [ Dec
elementCountType
        , Dec
elements
        , Dec
lowest
        , Dec
lowestMaybe
        , Dec
highest
        , Dec
highestMaybe
        , Dec
predMaybe
        , Dec
succMaybe
        , Dec
ith
        , Dec
index
        ]
 where
  mkTupE :: [Exp] -> Exp
mkTupE = [Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
         ([Maybe Exp] -> Exp) -> ([Exp] -> [Maybe Exp]) -> [Exp] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Maybe Exp) -> [Exp] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Maybe Exp
forall a. a -> Maybe a
Just
#endif


-- | Compatibility helper to create TySynInstD (stolen from Clash
-- Prelude, as it is not exported by the library)
mkTySynInstD :: Name -> [Type] -> Type -> Dec
mkTySynInstD :: Name -> [Type] -> Type -> Dec
mkTySynInstD Name
tyConNm [Type]
tyArgs Type
rhs =
#if MIN_VERSION_template_haskell(2,15,0)
        TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr ()]
forall a. Maybe a
Nothing
                     ((Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
tyConNm) [Type]
tyArgs)
                     Type
rhs)
#else
        TySynInstD tyConNm
                   (TySynEqn tyArgs
                             rhs)
#endif