    {-# 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 a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length -> Int
    n) = (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
    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)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM Int -> Q Dec
    genTupleInstance [Int
    3..Int
    maxTupleSize]

    genTupleInstance :: Int -> Q Dec
    genTupleInstance :: Int -> Q Dec
    genTupleInstance Int
    tupSize = do
      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)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [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
    forall (m :: Type -> Type). Quote m => String -> m 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]

      succOverflowBody <- genCountOverflow countSuccName tupSize
      predOverflowBody <- genCountOverflow countPredName tupSize

      let
        minBody = Name -> Int -> Clause
    genCount Name
    countMinName Int
    tupSize
        maxBody = Name -> Int -> Clause
    genCount Name
    countMaxName Int
    tupSize
        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 = Name -> Type
    ConT Name
    counterName Type -> Type -> Type
    `AppT` [Type] -> Type
    mkTupTy [Type]
    typeVars
        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]
          ]

      pure (InstanceD Nothing ctx typ 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
      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)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM (\Int
    n -> String -> Q Name
    forall (m :: Type -> Type). Quote m => String -> m 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 = (Name -> Exp) -> [Name] -> [Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Exp
    VarE [Name]
    varNms

      overflowLastNm <- newName "overflowLast"
      lastNm <- newName "last"

      overflowInitNm <- newName "overflowInit"
      initNms <- mapM (\Int
    n -> String -> Q Name
    forall (m :: Type -> Type). Quote m => String -> m 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)) [0..tupSize-2]

      let
        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. HasCallStack => [a] -> [a]
    init [Exp]
    vars [Exp] -> [Exp] -> [Exp]
    forall a. Semigroup a => a -> a -> a
    <> [Name -> Exp
    VarE Name
    lastNm])])

        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. HasCallStack => [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. HasCallStack => [a] -> [a]
    init [Exp]
    vars)))
              []
          ]

      pure (Clause [TupP (map VarP varNms)] (NormalB body) decs)