{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ < 806
{-# OPTIONS_GHC -Wwarn=unused-pattern-binds #-}
#endif
module Clash.Class.AutoReg.Internal
( AutoReg (..)
, deriveAutoReg
, deriveAutoRegTuples
)
where
import Data.List (nub,zipWith4)
import Data.Maybe (fromMaybe,isJust)
import GHC.Stack (HasCallStack)
import GHC.TypeNats (KnownNat,Nat,type (+))
import Clash.Explicit.Signal
import Clash.Promoted.Nat
import Clash.Magic
import Clash.XException (NFDataX, deepErrorX)
import Clash.Sized.BitVector
import Clash.Sized.Fixed
import Clash.Sized.Index
import Clash.Sized.RTree
import Clash.Sized.Signed
import Clash.Sized.Unsigned
import Clash.Sized.Vector (Vec, lazyV, smap)
import Data.Int
import Data.Word
import Foreign.C.Types (CUShort)
import Numeric.Half (Half)
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Control.Lens.Internal.TH (conAppsT)
#if MIN_VERSION_base(4,15,0)
bndrName :: TyVarBndr a -> Name
bndrName (PlainTV n _) = n
bndrName (KindedTV n _ _) = n
#else
bndrName :: TyVarBndr -> Name
bndrName :: TyVarBndr -> Name
bndrName (PlainTV Name
n) = Name
n
bndrName (KindedTV Name
n Kind
_) = Name
n
#endif
class NFDataX a => AutoReg a where
autoReg
:: (HasCallStack, KnownDomain dom)
=> Clock dom -> Reset dom -> Enable dom
-> a
-> Signal dom a
-> Signal dom a
autoReg = Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall (dom :: Domain) a.
(KnownDomain dom, NFDataX a) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
register
{-# INLINE autoReg #-}
instance AutoReg ()
instance AutoReg Bool
instance AutoReg Double
instance AutoReg Float
instance AutoReg CUShort
instance AutoReg Half
instance AutoReg Char
instance AutoReg Integer
instance AutoReg Int
instance AutoReg Int8
instance AutoReg Int16
instance AutoReg Int32
instance AutoReg Int64
instance AutoReg Word
instance AutoReg Word8
instance AutoReg Word16
instance AutoReg Word32
instance AutoReg Word64
instance AutoReg Bit
instance KnownNat n => AutoReg (BitVector n)
instance AutoReg (Signed n)
instance AutoReg (Unsigned n)
instance AutoReg (Index n)
instance NFDataX (rep (int + frac)) => AutoReg (Fixed rep int frac)
instance AutoReg a => AutoReg (Maybe a) where
autoReg :: Clock dom
-> Reset dom
-> Enable dom
-> Maybe a
-> Signal dom (Maybe a)
-> Signal dom (Maybe a)
autoReg Clock dom
clk Reset dom
rst Enable dom
en Maybe a
initVal Signal dom (Maybe a)
input =
Bool -> a -> Maybe a
forall a. Bool -> a -> Maybe a
createMaybe (Bool -> a -> Maybe a)
-> Signal dom Bool -> Signal dom (a -> Maybe a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom Bool
tagR Signal dom (a -> Maybe a) -> Signal dom a -> Signal dom (Maybe a)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Signal dom a
valR
where
tag :: Signal dom Bool
tag = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> Signal dom (Maybe a) -> Signal dom Bool
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (Maybe a)
input
tagInit :: Bool
tagInit = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
initVal
tagR :: Signal dom Bool
tagR = Clock dom
-> Reset dom
-> Enable dom
-> Bool
-> Signal dom Bool
-> Signal dom Bool
forall (dom :: Domain) a.
(KnownDomain dom, NFDataX a) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
register Clock dom
clk Reset dom
rst Enable dom
en Bool
tagInit Signal dom Bool
tag
val :: Signal dom a
val = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX String
"autoReg'.val") (Maybe a -> a) -> Signal dom (Maybe a) -> Signal dom a
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Signal dom (Maybe a)
input
valInit :: a
valInit = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. (NFDataX a, HasCallStack) => String -> a
deepErrorX String
"autoReg'.valInit") Maybe a
initVal
valR :: Signal dom a
valR = Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall a (dom :: Domain).
(AutoReg a, HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
autoReg Clock dom
clk Reset dom
rst (Enable dom -> Signal dom Bool -> Enable dom
forall (dom :: Domain). Enable dom -> Signal dom Bool -> Enable dom
enable Enable dom
en Signal dom Bool
tag) a
valInit Signal dom a
val
createMaybe :: Bool -> a -> Maybe a
createMaybe Bool
t a
v = case Bool
t of
Bool
True -> a -> Maybe a
forall a. a -> Maybe a
Just a
v
Bool
False -> Maybe a
forall a. Maybe a
Nothing
{-# INLINE autoReg #-}
instance (KnownNat n, AutoReg a) => AutoReg (Vec n a) where
autoReg
:: forall dom. (HasCallStack, KnownDomain dom)
=> Clock dom -> Reset dom -> Enable dom
-> Vec n a
-> Signal dom (Vec n a)
-> Signal dom (Vec n a)
autoReg :: Clock dom
-> Reset dom
-> Enable dom
-> Vec n a
-> Signal dom (Vec n a)
-> Signal dom (Vec n a)
autoReg Clock dom
clk Reset dom
rst Enable dom
en Vec n a
initVal Signal dom (Vec n a)
xs =
Unbundled dom (Vec n a) -> Signal dom (Vec n a)
forall a (dom :: Domain).
Bundle a =>
Unbundled dom a -> Signal dom a
bundle (Unbundled dom (Vec n a) -> Signal dom (Vec n a))
-> Unbundled dom (Vec n a) -> Signal dom (Vec n a)
forall a b. (a -> b) -> a -> b
$ (forall (l :: Nat). SNat l -> a -> Signal dom a -> Signal dom a)
-> Vec n a -> Vec n (Signal dom a -> Signal dom a)
forall (k :: Nat) a b.
KnownNat k =>
(forall (l :: Nat). SNat l -> a -> b) -> Vec k a -> Vec k b
smap forall (l :: Nat). SNat l -> a -> Signal dom a -> Signal dom a
go (Vec n a -> Vec n a
forall (n :: Nat) a. KnownNat n => Vec n a -> Vec n a
lazyV Vec n a
initVal) Vec n (Signal dom a -> Signal dom a)
-> Vec n (Signal dom a) -> Vec n (Signal dom a)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Signal dom (Vec n a) -> Unbundled dom (Vec n a)
forall a (dom :: Domain).
Bundle a =>
Signal dom a -> Unbundled dom a
unbundle Signal dom (Vec n a)
xs
where
go :: forall (i :: Nat). SNat i -> a -> Signal dom a -> Signal dom a
go :: SNat i -> a -> Signal dom a -> Signal dom a
go SNat i
SNat = forall a. a -> a
forall (name :: Nat) a. a -> a
suffixNameFromNatP @i ((Signal dom a -> Signal dom a) -> Signal dom a -> Signal dom a)
-> (a -> Signal dom a -> Signal dom a)
-> a
-> Signal dom a
-> Signal dom a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall a (dom :: Domain).
(AutoReg a, HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
autoReg Clock dom
clk Reset dom
rst Enable dom
en
{-# INLINE autoReg #-}
instance (KnownNat d, AutoReg a) => AutoReg (RTree d a) where
autoReg :: Clock dom
-> Reset dom
-> Enable dom
-> RTree d a
-> Signal dom (RTree d a)
-> Signal dom (RTree d a)
autoReg Clock dom
clk Reset dom
rst Enable dom
en RTree d a
initVal Signal dom (RTree d a)
xs =
Unbundled dom (RTree d a) -> Signal dom (RTree d a)
forall a (dom :: Domain).
Bundle a =>
Unbundled dom a -> Signal dom a
bundle (Unbundled dom (RTree d a) -> Signal dom (RTree d a))
-> Unbundled dom (RTree d a) -> Signal dom (RTree d a)
forall a b. (a -> b) -> a -> b
$ (Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
forall a (dom :: Domain).
(AutoReg a, HasCallStack, KnownDomain dom) =>
Clock dom
-> Reset dom -> Enable dom -> a -> Signal dom a -> Signal dom a
autoReg Clock dom
clk Reset dom
rst Enable dom
en) (a -> Signal dom a -> Signal dom a)
-> RTree d a -> RTree d (Signal dom a -> Signal dom a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> RTree d a -> RTree d a
forall (d :: Nat) a. KnownNat d => RTree d a -> RTree d a
lazyT RTree d a
initVal RTree d (Signal dom a -> Signal dom a)
-> RTree d (Signal dom a) -> RTree d (Signal dom a)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Signal dom (RTree d a) -> Unbundled dom (RTree d a)
forall a (dom :: Domain).
Bundle a =>
Signal dom a -> Unbundled dom a
unbundle Signal dom (RTree d a)
xs
{-# INLINE autoReg #-}
unfoldType :: Type -> (Type, [Type])
unfoldType :: Kind -> (Kind, [Kind])
unfoldType = [Kind] -> Kind -> (Kind, [Kind])
go []
where
go :: [Type] -> Type -> (Type, [Type])
go :: [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc (ForallT [TyVarBndr]
_ [Kind]
_ Kind
ty) = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
go [Kind]
acc (AppT Kind
ty1 Kind
ty2) = [Kind] -> Kind -> (Kind, [Kind])
go (Kind
ty2Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:[Kind]
acc) Kind
ty1
go [Kind]
acc (SigT Kind
ty Kind
_) = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
#if MIN_VERSION_template_haskell(2,11,0)
go [Kind]
acc (ParensT Kind
ty) = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
#endif
#if MIN_VERSION_template_haskell(2,15,0)
go [Kind]
acc (AppKindT Kind
ty Kind
_) = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
#endif
go [Kind]
acc Kind
ty = (Kind
ty, [Kind]
acc)
deriveAutoReg :: Name -> DecsQ
deriveAutoReg :: Name -> DecsQ
deriveAutoReg Name
tyNm = do
DatatypeInfo
tyInfo <- Name -> Q DatatypeInfo
reifyDatatype Name
tyNm
case DatatypeInfo -> [ConstructorInfo]
datatypeCons DatatypeInfo
tyInfo of
[] -> String -> DecsQ
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Can't deriveAutoReg for empty types"
[ConstructorInfo
conInfo] -> DatatypeInfo -> ConstructorInfo -> DecsQ
deriveAutoRegProduct DatatypeInfo
tyInfo ConstructorInfo
conInfo
[ConstructorInfo]
_ -> String -> DecsQ
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Can't deriveAutoReg for sum types"
deriveAutoRegProduct :: DatatypeInfo -> ConstructorInfo -> DecsQ
deriveAutoRegProduct :: DatatypeInfo -> ConstructorInfo -> DecsQ
deriveAutoRegProduct DatatypeInfo
tyInfo ConstructorInfo
conInfo = Name -> [(Maybe Name, Kind)] -> DecsQ
go (ConstructorInfo -> Name
constructorName ConstructorInfo
conInfo) [(Maybe Name, Kind)]
fieldInfos
where
tyNm :: Name
tyNm = DatatypeInfo -> Name
datatypeName DatatypeInfo
tyInfo
tyVarBndrs :: [TyVarBndr]
tyVarBndrs = DatatypeInfo -> [TyVarBndr]
datatypeVars DatatypeInfo
tyInfo
#if MIN_VERSION_th_abstraction(0,3,0)
toTyVar :: TyVarBndr -> Kind
toTyVar = Name -> Kind
VarT (Name -> Kind) -> (TyVarBndr -> Name) -> TyVarBndr -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
bndrName
#else
toTyVar t = case t of
VarT _ -> t
SigT t' _ -> toTyVar t'
_ -> error "deriveAutoRegProduct.toTv"
#endif
tyVars :: [Kind]
tyVars = (TyVarBndr -> Kind) -> [TyVarBndr] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Kind
toTyVar [TyVarBndr]
tyVarBndrs
ty :: Kind
ty = Name -> [Kind] -> Kind
conAppsT Name
tyNm [Kind]
tyVars
fieldInfos :: [(Maybe Name, Kind)]
fieldInfos =
[Maybe Name] -> [Kind] -> [(Maybe Name, Kind)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe Name]
fieldNames (ConstructorInfo -> [Kind]
constructorFields ConstructorInfo
conInfo)
where
fieldNames :: [Maybe Name]
fieldNames =
case ConstructorInfo -> ConstructorVariant
constructorVariant ConstructorInfo
conInfo of
RecordConstructor [Name]
nms -> (Name -> Maybe Name) -> [Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Maybe Name
forall a. a -> Maybe a
Just [Name]
nms
ConstructorVariant
_ -> Maybe Name -> [Maybe Name]
forall a. a -> [a]
repeat Maybe Name
forall a. Maybe a
Nothing
go :: Name -> [(Maybe Name,Type)] -> Q [Dec]
go :: Name -> [(Maybe Name, Kind)] -> DecsQ
go Name
dcNm [(Maybe Name, Kind)]
fields = do
[Name]
args <- (String -> Q Name) -> [String] -> Q [Name]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> Q Name
newName [String
"clk", String
"rst", String
"en", String
"initVal", String
"input"]
let
[ExpQ
clkE, ExpQ
rstE, ExpQ
enE, ExpQ
initValE, ExpQ
inputE] = (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
args
argsP :: [PatQ]
argsP = (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
args
fieldNames :: [Maybe Name]
fieldNames = ((Maybe Name, Kind) -> Maybe Name)
-> [(Maybe Name, Kind)] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Name, Kind) -> Maybe Name
forall a b. (a, b) -> a
fst [(Maybe Name, Kind)]
fields
field :: Name -> Int -> DecQ
field :: Name -> Int -> DecQ
field Name
nm Int
nr =
PatQ -> BodyQ -> [DecQ] -> DecQ
valD (Name -> PatQ
varP Name
nm) (ExpQ -> BodyQ
normalB [| $fieldSel <$> $inputE |]) []
where
fieldSel :: ExpQ
fieldSel = do
Name
xNm <- String -> Q Name
newName String
"x"
let fieldP :: [PatQ]
fieldP = [ if Int
nr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n then Name -> PatQ
varP Name
xNm else PatQ
wildP
| (Int
n,(Maybe Name, Kind)
_) <- [Int] -> [(Maybe Name, Kind)] -> [(Int, (Maybe Name, Kind))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Maybe Name, Kind)]
fields]
[PatQ] -> ExpQ -> ExpQ
lamE [Name -> [PatQ] -> PatQ
conP Name
dcNm [PatQ]
fieldP] (Name -> ExpQ
varE Name
xNm)
[Name]
parts <- String -> [(Maybe Name, Kind)] -> Q [Name]
forall a. String -> [a] -> Q [Name]
generateNames String
"field" [(Maybe Name, Kind)]
fields
[Dec]
fieldDecls <- [DecQ] -> DecsQ
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([DecQ] -> DecsQ) -> [DecQ] -> DecsQ
forall a b. (a -> b) -> a -> b
$ (Name -> Int -> DecQ) -> [Name] -> [Int] -> [DecQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> Int -> DecQ
field [Name]
parts [Int
0..]
[Name]
sigs <- String -> [(Maybe Name, Kind)] -> Q [Name]
forall a. String -> [a] -> Q [Name]
generateNames String
"sig" [(Maybe Name, Kind)]
fields
[Name]
initVals <- String -> [(Maybe Name, Kind)] -> Q [Name]
forall a. String -> [a] -> Q [Name]
generateNames String
"initVal" [(Maybe Name, Kind)]
fields
let initPat :: PatQ
initPat = Name -> [PatQ] -> PatQ
conP Name
dcNm ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
initVals)
Dec
initDecl <- PatQ -> BodyQ -> [DecQ] -> DecQ
valD PatQ
initPat (ExpQ -> BodyQ
normalB ExpQ
initValE) []
let
genAutoRegDecl :: PatQ -> ExpQ -> ExpQ -> Maybe Name -> DecsQ
genAutoRegDecl :: PatQ -> ExpQ -> ExpQ -> Maybe Name -> DecsQ
genAutoRegDecl PatQ
s ExpQ
v ExpQ
i Maybe Name
nameM =
[d| $s = $nameMe autoReg $clkE $rstE $enE $i $v |]
where
nameMe :: ExpQ
nameMe = case Maybe Name
nameM of
Maybe Name
Nothing -> [| id |]
Just Name
nm -> let nmSym :: TypeQ
nmSym = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> TyLitQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> TyLitQ
strTyLit (Name -> String
nameBase Name
nm)
in [| suffixNameP @($nmSym) |]
[Dec]
partDecls <- [[Dec]] -> [Dec]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ([DecsQ] -> Q [[Dec]]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([DecsQ] -> Q [[Dec]]) -> [DecsQ] -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ (PatQ -> ExpQ -> ExpQ -> Maybe Name -> DecsQ)
-> [PatQ] -> [ExpQ] -> [ExpQ] -> [Maybe Name] -> [DecsQ]
forall a b c d e.
(a -> b -> c -> d -> e) -> [a] -> [b] -> [c] -> [d] -> [e]
zipWith4 PatQ -> ExpQ -> ExpQ -> Maybe Name -> DecsQ
genAutoRegDecl
(Name -> PatQ
varP (Name -> PatQ) -> [Name] -> [PatQ]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
sigs)
(Name -> ExpQ
varE (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
parts)
(Name -> ExpQ
varE (Name -> ExpQ) -> [Name] -> [ExpQ]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
initVals)
([Maybe Name]
fieldNames)
)
let
decls :: [DecQ]
decls :: [DecQ]
decls = (Dec -> DecQ) -> [Dec] -> [DecQ]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> DecQ
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Dec
initDecl Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
fieldDecls [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
partDecls)
tyConE :: ExpQ
tyConE = Name -> ExpQ
conE Name
dcNm
body :: ExpQ
body =
case (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
sigs of
(ExpQ
sig0:[ExpQ]
rest) -> (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
(\ExpQ
acc ExpQ
sigN -> [| $acc <*> $sigN |])
[| $tyConE <$> $sig0 |]
[ExpQ]
rest
[] -> [| $tyConE |]
Dec
autoRegDec <- Name -> [ClauseQ] -> DecQ
funD 'autoReg [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
argsP (ExpQ -> BodyQ
normalB ExpQ
body) [DecQ]
decls]
[Kind]
ctx <- ConstructorInfo -> Q [Kind]
calculateRequiredContext ConstructorInfo
conInfo
[Dec] -> DecsQ
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Maybe Overlap -> [Kind] -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Kind]
ctx (Kind -> Kind -> Kind
AppT (Name -> Kind
ConT ''AutoReg) Kind
ty)
[ Dec
autoRegDec
, Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP 'autoReg Inline
Inline RuleMatch
FunLike Phases
AllPhases) ]]
calculateRequiredContext :: ConstructorInfo -> Q Cxt
calculateRequiredContext :: ConstructorInfo -> Q [Kind]
calculateRequiredContext ConstructorInfo
conInfo = do
let fieldTys :: [Kind]
fieldTys = ConstructorInfo -> [Kind]
constructorFields ConstructorInfo
conInfo
[[Kind]]
wantedInstances <- (Kind -> Q [Kind]) -> [Kind] -> Q [[Kind]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Kind
ty -> Name -> [Kind] -> Q [Kind]
constraintsWantedFor ''AutoReg [Kind
ty]) ([Kind] -> [Kind]
forall a. Eq a => [a] -> [a]
nub [Kind]
fieldTys)
[Kind] -> Q [Kind]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Kind] -> Q [Kind]) -> [Kind] -> Q [Kind]
forall a b. (a -> b) -> a -> b
$ [Kind] -> [Kind]
forall a. Eq a => [a] -> [a]
nub ([[Kind]] -> [Kind]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Kind]]
wantedInstances)
constraintsWantedFor :: Name -> [Type] -> Q Cxt
constraintsWantedFor :: Name -> [Kind] -> Q [Kind]
constraintsWantedFor Name
clsNm [Kind]
tys
| Name -> String
forall a. Show a => a -> String
show Name
clsNm String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.TypeNats.KnownNat" = do
[Kind] -> Q [Kind]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Name -> [Kind] -> Kind
conAppsT Name
clsNm [Kind]
tys]
constraintsWantedFor Name
clsNm [Kind
ty] = case Kind
ty of
VarT Name
_ -> [Kind] -> Q [Kind]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
clsNm) Kind
ty]
ConT Name
_ -> [Kind] -> Q [Kind]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []
Kind
_ -> do
[Dec]
insts <- Name -> [Kind] -> DecsQ
reifyInstances Name
clsNm [Kind
ty]
case [Dec]
insts of
[InstanceD Maybe Overlap
_ [Kind]
cxtInst (AppT Kind
autoRegCls Kind
instTy) [Dec]
_]
| Kind
autoRegCls Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Kind
ConT Name
clsNm -> do
let substs :: [(Name, Kind)]
substs = Kind -> Kind -> [(Name, Kind)]
findTyVarSubsts Kind
instTy Kind
ty
cxt2 :: [Kind]
cxt2 = (Kind -> Kind) -> [Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, Kind)] -> Kind -> Kind
applyTyVarSubsts [(Name, Kind)]
substs) [Kind]
cxtInst
okCxt :: [Kind]
okCxt = (Kind -> Bool) -> [Kind] -> [Kind]
forall a. (a -> Bool) -> [a] -> [a]
filter Kind -> Bool
isOk [Kind]
cxt2
recurseCxt :: [Kind]
recurseCxt = (Kind -> Bool) -> [Kind] -> [Kind]
forall a. (a -> Bool) -> [a] -> [a]
filter Kind -> Bool
needRecurse [Kind]
cxt2
[[Kind]]
recursed <- (Kind -> Q [Kind]) -> [Kind] -> Q [[Kind]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Kind -> Q [Kind]
recurse [Kind]
recurseCxt
[Kind] -> Q [Kind]
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([Kind]
okCxt [Kind] -> [Kind] -> [Kind]
forall a. [a] -> [a] -> [a]
++ [[Kind]] -> [Kind]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[Kind]]
recursed)
[] -> String -> Q [Kind]
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q [Kind]) -> String -> Q [Kind]
forall a b. (a -> b) -> a -> b
$ String
"Missing instance " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
clsNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Ppr a => a -> String
pprint Kind
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
(Dec
_:Dec
_:[Dec]
_) -> String -> Q [Kind]
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q [Kind]) -> String -> Q [Kind]
forall a b. (a -> b) -> a -> b
$ String
"There are multiple " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
clsNm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" instances for "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Ppr a => a -> String
pprint Kind
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Dec] -> String
forall a. Ppr a => a -> String
pprint [Dec]
insts
[Dec]
_ -> String -> Q [Kind]
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q [Kind]) -> String -> Q [Kind]
forall a b. (a -> b) -> a -> b
$ String
"Got unexpected instance: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Dec] -> String
forall a. Ppr a => a -> String
pprint [Dec]
insts
where
isOk :: Type -> Bool
isOk :: Kind -> Bool
isOk (Kind -> (Kind, [Kind])
unfoldType -> (Kind
_cls,[Kind]
tys)) =
case [Kind]
tys of
[VarT Name
_] -> Bool
True
[Kind
_] -> Bool
False
[Kind]
_ -> Bool
True
needRecurse :: Type -> Bool
needRecurse :: Kind -> Bool
needRecurse (Kind -> (Kind, [Kind])
unfoldType -> (Kind
cls,[Kind]
tys)) =
case [Kind]
tys of
[AppT Kind
_ Kind
_] -> Bool
True
[VarT Name
_] -> Bool
False
[ConT Name
_] -> Bool
False
[LitT TyLit
_] -> Bool
False
[Kind
_] -> String -> Bool
forall a. HasCallStack => String -> a
error ( String
"Error while deriveAutoReg: don't know how to handle: "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Ppr a => a -> String
pprint Kind
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Kind] -> String
forall a. Ppr a => a -> String
pprint [Kind]
tys String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" )
[Kind]
_ -> Bool
False
recurse :: Type -> Q Cxt
recurse :: Kind -> Q [Kind]
recurse (Kind -> (Kind, [Kind])
unfoldType -> (ConT Name
cls,[Kind]
tys)) = Name -> [Kind] -> Q [Kind]
constraintsWantedFor Name
cls [Kind]
tys
recurse Kind
t =
String -> Q [Kind]
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String
"Expected a class applied to some arguments but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Ppr a => a -> String
pprint Kind
t)
constraintsWantedFor Name
clsNm [Kind]
tys =
[Kind] -> Q [Kind]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [Name -> [Kind] -> Kind
conAppsT Name
clsNm [Kind]
tys]
findTyVarSubsts :: Type -> Type -> [(Name,Type)]
findTyVarSubsts :: Kind -> Kind -> [(Name, Kind)]
findTyVarSubsts = Kind -> Kind -> [(Name, Kind)]
go
where
go :: Kind -> Kind -> [(Name, Kind)]
go Kind
ty1 Kind
ty2 = case (Kind
ty1,Kind
ty2) of
(VarT Name
nm1 , VarT Name
nm2) | Name
nm1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm2 -> []
(VarT Name
nm , Kind
t) -> [(Name
nm,Kind
t)]
(ConT Name
_ , ConT Name
_) -> []
(AppT Kind
x1 Kind
y1 , AppT Kind
x2 Kind
y2) -> Kind -> Kind -> [(Name, Kind)]
go Kind
x1 Kind
x2 [(Name, Kind)] -> [(Name, Kind)] -> [(Name, Kind)]
forall a. [a] -> [a] -> [a]
++ Kind -> Kind -> [(Name, Kind)]
go Kind
y1 Kind
y2
(SigT Kind
t1 Kind
k1 , SigT Kind
t2 Kind
k2) -> Kind -> Kind -> [(Name, Kind)]
go Kind
t1 Kind
t2 [(Name, Kind)] -> [(Name, Kind)] -> [(Name, Kind)]
forall a. [a] -> [a] -> [a]
++ Kind -> Kind -> [(Name, Kind)]
go Kind
k1 Kind
k2
(InfixT Kind
x1 Name
_ Kind
y1 , InfixT Kind
x2 Name
_ Kind
y2) -> Kind -> Kind -> [(Name, Kind)]
go Kind
x1 Kind
x2 [(Name, Kind)] -> [(Name, Kind)] -> [(Name, Kind)]
forall a. [a] -> [a] -> [a]
++ Kind -> Kind -> [(Name, Kind)]
go Kind
y1 Kind
y2
(UInfixT Kind
x1 Name
_ Kind
y1, UInfixT Kind
x2 Name
_ Kind
y2) -> Kind -> Kind -> [(Name, Kind)]
go Kind
x1 Kind
x2 [(Name, Kind)] -> [(Name, Kind)] -> [(Name, Kind)]
forall a. [a] -> [a] -> [a]
++ Kind -> Kind -> [(Name, Kind)]
go Kind
y1 Kind
y2
(ParensT Kind
x1 , ParensT Kind
x2) -> Kind -> Kind -> [(Name, Kind)]
go Kind
x1 Kind
x2
#if __GLASGOW_HASKELL__ >= 808
(AppKindT Kind
t1 Kind
k1 , AppKindT Kind
t2 Kind
k2) -> Kind -> Kind -> [(Name, Kind)]
go Kind
t1 Kind
t2 [(Name, Kind)] -> [(Name, Kind)] -> [(Name, Kind)]
forall a. [a] -> [a] -> [a]
++ Kind -> Kind -> [(Name, Kind)]
go Kind
k1 Kind
k2
(ImplicitParamT String
_ Kind
x1, ImplicitParamT String
_ Kind
x2) -> Kind -> Kind -> [(Name, Kind)]
go Kind
x1 Kind
x2
#endif
(PromotedT Name
_ , PromotedT Name
_ ) -> []
(TupleT Int
_ , TupleT Int
_ ) -> []
(UnboxedTupleT Int
_ , UnboxedTupleT Int
_ ) -> []
(UnboxedSumT Int
_ , UnboxedSumT Int
_ ) -> []
(Kind
ArrowT , Kind
ArrowT ) -> []
(Kind
EqualityT , Kind
EqualityT ) -> []
(Kind
ListT , Kind
ListT ) -> []
(PromotedTupleT Int
_ , PromotedTupleT Int
_ ) -> []
(Kind
PromotedNilT , Kind
PromotedNilT ) -> []
(Kind
PromotedConsT , Kind
PromotedConsT ) -> []
(Kind
StarT , Kind
StarT ) -> []
(Kind
ConstraintT , Kind
ConstraintT ) -> []
(LitT TyLit
_ , LitT TyLit
_ ) -> []
(Kind
WildCardT , Kind
WildCardT ) -> []
(Kind, Kind)
_ -> String -> [(Name, Kind)]
forall a. HasCallStack => String -> a
error (String -> [(Name, Kind)]) -> String -> [(Name, Kind)]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [ String
"findTyVarSubsts: Unexpected types"
, String
"ty1:", Kind -> String
forall a. Ppr a => a -> String
pprint Kind
ty1,String
"ty2:", Kind -> String
forall a. Ppr a => a -> String
pprint Kind
ty2]
applyTyVarSubsts :: [(Name,Type)] -> Type -> Type
applyTyVarSubsts :: [(Name, Kind)] -> Kind -> Kind
applyTyVarSubsts [(Name, Kind)]
substs Kind
ty = Kind -> Kind
go Kind
ty
where
go :: Kind -> Kind
go Kind
ty' = case Kind
ty' of
VarT Name
n -> case Name -> [(Name, Kind)] -> Maybe Kind
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n [(Name, Kind)]
substs of
Maybe Kind
Nothing -> Kind
ty'
Just Kind
m -> Kind
m
ConT Name
_ -> Kind
ty'
AppT Kind
ty1 Kind
ty2 -> Kind -> Kind -> Kind
AppT (Kind -> Kind
go Kind
ty1) (Kind -> Kind
go Kind
ty2)
Kind
_ -> String -> Kind
forall a. HasCallStack => String -> a
error (String -> Kind) -> String -> Kind
forall a b. (a -> b) -> a -> b
$ String
"TODO applyTyVarSubsts: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Kind -> String
forall a. Show a => a -> String
show Kind
ty'
generateNames :: String -> [a] -> Q [Name]
generateNames :: String -> [a] -> Q [Name]
generateNames String
prefix [a]
xs =
[Q Name] -> Q [Name]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ((Int -> a -> Q Name) -> [Int] -> [a] -> [Q Name]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n a
_ -> String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show @Int Int
n) [Int
0..] [a]
xs)
deriveAutoRegTuples :: [Int] -> DecsQ
deriveAutoRegTuples :: [Int] -> DecsQ
deriveAutoRegTuples [Int]
xs = [[Dec]] -> [Dec]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> DecsQ) -> [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 -> DecsQ
deriveAutoRegTuple [Int]
xs
deriveAutoRegTuple :: Int -> DecsQ
deriveAutoRegTuple :: Int -> DecsQ
deriveAutoRegTuple Int
n
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = String -> DecsQ
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> DecsQ) -> String -> DecsQ
forall a b. (a -> b) -> a -> b
$ String
"deriveAutoRegTuple doesn't work for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-tuples"
| Bool
otherwise = Name -> DecsQ
deriveAutoReg Name
tupN
where
tupN :: Name
tupN = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
',' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"