    {-# OPTIONS_HADDOCK hide #-}

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE TemplateHaskellQuotes #-}

    module Clash.Sized.Vector.ToTuple.TH (vecToTupleInstance, vecToTupleInstances) where

    import Clash.Sized.Vector (Vec((:>)))
    import Language.Haskell.TH

    appTs :: Q Type -> [Q Type] -> Q Type
    appTs :: Q Type -> [Q Type] -> Q Type
    appTs = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q 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 Q Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    appT

    appPsInfix :: Name -> [Q Pat] -> Q Pat
    appPsInfix :: Name -> [Q Pat] -> Q Pat
    appPsInfix Name
    f = (Q Pat -> Q Pat -> Q Pat) -> [Q Pat] -> Q Pat
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: Type -> Type) a.
    Foldable t =>
    (a -> a -> a) -> t a -> a
    foldl1 (\Q Pat
    l Q Pat
    r -> Q Pat -> Name -> Q Pat -> Q Pat
    forall (m :: Type -> Type).
    Quote m =>
    m Pat -> Name -> m Pat -> m Pat
    uInfixP Q Pat
    l Name
    f Q Pat
    r)

    tupT :: [Q Type] -> Q Type
    tupT :: [Q Type] -> Q Type
    tupT [Q Type]
    tyArgs = Int -> Q Type
    forall (m :: Type -> Type). Quote m => Int -> m Type
    tupleT ([Q Type] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Q Type]
    tyArgs) Q Type -> [Q Type] -> Q Type
    `appTs` [Q Type]
    tyArgs

    vecToTupleInstances :: Integer -> Q [Dec]
    vecToTupleInstances :: Integer -> Q [Dec]
    vecToTupleInstances Integer
    n = (Integer -> Q Dec) -> [Integer] -> 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 Integer -> Q Dec
    vecToTupleInstance [Integer
    3..Integer
    n]

    vecToTupleInstance :: Integer -> Q Dec
    vecToTupleInstance :: Integer -> Q Dec
    vecToTupleInstance Integer
    n =
      Q Cxt -> Q Type -> [Q Dec] -> Q Dec
    forall (m :: Type -> Type).
    Quote m =>
    m Cxt -> m Type -> [m Dec] -> m Dec
    instanceD
        -- No superclasses
        (Cxt -> Q Cxt
    forall a. a -> Q a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure [])

        -- Head
        (Q Type
    vecToTupleCon Q Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    `appT` Q Type
    vecType)

        -- Implementation
        [ Q TySynEqn -> Q Dec
    forall (m :: Type -> Type). Quote m => m TySynEqn -> m Dec
    tySynInstD
    #if !MIN_VERSION_template_haskell(2,15,0)
            (mkName "TupType")
    #endif
            ( Maybe [TyVarBndr ()] -> Q Type -> Q Type -> Q TySynEqn
    forall (m :: Type -> Type).
    Quote m =>
    Maybe [TyVarBndr ()] -> m Type -> m Type -> m TySynEqn
    tySynEqn
    #if MIN_VERSION_template_haskell(2,15,0)
                Maybe [TyVarBndr ()]
    forall a. Maybe a
    Nothing Q Type
    aTypeLhs
    #else
                [vecType]
    #endif
                Q Type
    aTypeRhs )
        , Name -> [Q Clause] -> Q Dec
    forall (m :: Type -> Type). Quote m => Name -> [m Clause] -> m Dec
    funD Name
    vecToTupleFunName [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
    forall (m :: Type -> Type).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [Q Pat
    vecToTuplePat] (Q Exp -> Q Body
    forall (m :: Type -> Type). Quote m => m Exp -> m Body
    normalB Q Exp
    vecToTupleImpl) []]
        ]

     where
      vecToTupleCon :: Q Type
    vecToTupleCon = Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    conT (String -> Name
    mkName String
    "VecToTuple")
      vecType :: Q Type
    vecType = Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    conT ''Vec Q Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    `appT` Q TyLit -> Q Type
    forall (m :: Type -> Type). Quote m => m TyLit -> m Type
    litT (Integer -> Q TyLit
    forall (m :: Type -> Type). Quote m => Integer -> m TyLit
    numTyLit Integer
    n) Q Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    `appT` Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    varT (String -> Name
    mkName String
    "a")

      -- associated type
    #if MIN_VERSION_template_haskell(2,15,0)
      tupTypeCon :: Q Type
    tupTypeCon = Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    conT (String -> Name
    mkName String
    "TupType")
      aTypeLhs :: Q Type
    aTypeLhs = Q Type
    tupTypeCon Q Type -> Q Type -> Q Type
    forall (m :: Type -> Type). Quote m => m Type -> m Type -> m Type
    `appT` Q Type
    vecType
    #endif
      aTypeRhs :: Q Type
    aTypeRhs = [Q Type] -> Q Type
    tupT [Name -> Q Type
    forall (m :: Type -> Type). Quote m => Name -> m Type
    varT (String -> Name
    mkName String
    "a") | Integer
    _ <- [Integer
    1..Integer
    n]]

      -- vecToTuple
      vecToTupleFunName :: Name
    vecToTupleFunName = String -> Name
    mkName String
    "vecToTuple"
      vecToTuplePat :: Q Pat
    vecToTuplePat = Name -> [Q Pat] -> Q Pat
    appPsInfix '(:>) ((Name -> Q Pat) -> [Name] -> [Q Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Pat
    forall (m :: Type -> Type). Quote m => Name -> m Pat
    varP [Name]
    varNames [Q Pat] -> [Q Pat] -> [Q Pat]
    forall a. [a] -> [a] -> [a]
    ++ [Q Pat
    forall (m :: Type -> Type). Quote m => m Pat
    wildP])
      vecToTupleImpl :: Q Exp
    vecToTupleImpl = [Q Exp] -> Q Exp
    forall (m :: Type -> Type). Quote m => [m Exp] -> m Exp
    tupE ((Name -> Q Exp) -> [Name] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Exp
    forall (m :: Type -> Type). Quote m => Name -> m Exp
    varE [Name]
    varNames)

      varNames :: [Name]
    varNames = (Integer -> Name) -> [Integer] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> Name
    mkName (String -> Name) -> (Integer -> String) -> Integer -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char
    'a'Char -> String -> String
    forall a. a -> [a] -> [a]
    :) (String -> String) -> (Integer -> String) -> Integer -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Integer -> String
    forall a. Show a => a -> String
    show) [Integer
    1..Integer
    n]