{-# LANGUAGE CPP #-}

module Clash.Class.Counter.TH where

import Language.Haskell.TH

counterName, countMinName, countMaxName, countSuccName, countPredName :: Name
counterName :: Name
counterName = String -> Name
mkName String
"Counter"
countMinName :: Name
countMinName = String -> Name
mkName String
"countMin"
countMaxName :: Name
countMaxName = String -> Name
mkName String
"countMax"
countSuccName :: Name
countSuccName = String -> Name
mkName String
"countSuccOverflow"
countPredName :: Name
countPredName = String -> Name
mkName String
"countPredOverflow"

mkTupTy :: [Type] -> Type
mkTupTy :: [Type] -> Type
mkTupTy names :: [Type]
names@([Type] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length -> Int
n) = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Int -> Type
TupleT Int
n) [Type]
names

mkTup :: [Exp] -> Exp
#if MIN_VERSION_template_haskell(2,16,0)
mkTup :: [Exp] -> Exp
mkTup = [Maybe Exp] -> Exp
TupE ([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
#else
mkTup = TupE
#endif

genTupleInstances :: Int -> Q [Dec]
genTupleInstances :: Int -> Q [Dec]
genTupleInstances Int
maxTupleSize = (Int -> Q Dec) -> [Int] -> Q [Dec]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> Q Dec
genTupleInstance [Int
3..Int
maxTupleSize]

genTupleInstance :: Int -> Q Dec
genTupleInstance :: Int -> Q Dec
genTupleInstance Int
tupSize = do
  [Type]
typeVars <- (Int -> Q Type) -> [Int] -> Q [Type]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
n -> Name -> Type
VarT (Name -> Type) -> Q Name -> Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName (String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0..Int
tupSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

  Clause
succOverflowBody <- Name -> Int -> Q Clause
genCountOverflow Name
countSuccName Int
tupSize
  Clause
predOverflowBody <- Name -> Int -> Q Clause
genCountOverflow Name
countPredName Int
tupSize

  let
    minBody :: Clause
minBody = Name -> Int -> Clause
genCount Name
countMinName Int
tupSize
    maxBody :: Clause
maxBody = Name -> Int -> Clause
genCount Name
countMaxName Int
tupSize
    ctx :: [Type]
ctx = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
ConT Name
counterName Type -> Type -> Type
`AppT`) [Type]
typeVars
    typ :: Type
typ = Name -> Type
ConT Name
counterName Type -> Type -> Type
`AppT` [Type] -> Type
mkTupTy [Type]
typeVars
    decls :: [Dec]
decls =
      [ Name -> [Clause] -> Dec
FunD Name
countMinName [Clause
minBody]
      , Name -> [Clause] -> Dec
FunD Name
countMaxName [Clause
maxBody]
      , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"countSuccOverflow") [Clause
succOverflowBody]
      , Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"countPredOverflow") [Clause
predOverflowBody]
      ]

  Dec -> Q Dec
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type]
ctx Type
typ [Dec]
decls)

genCount :: Name -> Int -> Clause
genCount :: Name -> Int -> Clause
genCount Name
nm Int
n = [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB ([Exp] -> Exp
mkTup (Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
n (Name -> Exp
VarE Name
nm)))) []

genCountOverflow :: Name -> Int -> Q Clause
genCountOverflow :: Name -> Int -> Q Clause
genCountOverflow Name
nm Int
tupSize = do
  [Name]
varNms <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
n -> String -> Q Name
newName (String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0..Int
tupSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  let vars :: [Exp]
vars = (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
varNms

  Name
overflowLastNm <- String -> Q Name
newName String
"overflowLast"
  Name
lastNm <- String -> Q Name
newName String
"last"

  Name
overflowInitNm <- String -> Q Name
newName String
"overflowInit"
  [Name]
initNms <- (Int -> Q Name) -> [Int] -> Q [Name]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Int
n -> String -> Q Name
newName (String
"a" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n)) [Int
0..Int
tupSizeInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2]

  let
    body :: Exp
body =
      Exp -> Exp -> Exp -> Exp
CondE
        (Name -> Exp
VarE Name
overflowLastNm)
        ([Exp] -> Exp
mkTup [Name -> Exp
VarE Name
overflowInitNm, [Exp] -> Exp
mkTup ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE ([Name]
initNms [Name] -> [Name] -> [Name]
forall a. Semigroup a => a -> a -> a
<> [Name
lastNm]))])
        ([Exp] -> Exp
mkTup [Name -> Exp
VarE Name
overflowLastNm, [Exp] -> Exp
mkTup ([Exp] -> [Exp]
forall a. [a] -> [a]
init [Exp]
vars [Exp] -> [Exp] -> [Exp]
forall a. Semigroup a => a -> a -> a
<> [Name -> Exp
VarE Name
lastNm])])

    decs :: [Dec]
decs =
      [ Pat -> Body -> [Dec] -> Dec
ValD
          ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
overflowLastNm, Name -> Pat
VarP Name
lastNm])
          (Exp -> Body
NormalB (Name -> Exp
VarE Name
nm Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
forall a. [a] -> a
last [Exp]
vars))
          []

      , Pat -> Body -> [Dec] -> Dec
ValD
          ([Pat] -> Pat
TupP [Name -> Pat
VarP Name
overflowInitNm, [Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
initNms)])
          (Exp -> Body
NormalB (Name -> Exp
VarE Name
nm Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
mkTup ([Exp] -> [Exp]
forall a. [a] -> [a]
init [Exp]
vars)))
          []
      ]

  Clause -> Q Clause
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([Pat] -> Body -> [Dec] -> Clause
Clause [[Pat] -> Pat
TupP ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
varNms)] (Exp -> Body
NormalB Exp
body) [Dec]
decs)