{-|
Copyright  :  (C) 2018, Google Inc
                  2019, Myrtle Software Ltd
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.Clocks.Deriving (deriveClocksInstances) where

import Control.Monad               (foldM)
import Clash.Signal.Internal
import Language.Haskell.TH.Compat
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Lib
import Unsafe.Coerce               (unsafeCoerce)

-- Derive instance for /n/ clocks
derive' :: Int -> Q Dec
derive' :: Int -> Q Dec
derive' Int
n = do
  -- (Clock d0, Clock d1, )
  Type
instType0 <- (Type -> Int -> Q Type) -> Type -> [Int] -> Q Type
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Type
a Int
n' -> Type -> Type -> Type
AppT Type
a (Type -> Type) -> Q Type -> Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Q Type
forall a. Show a => a -> Q Type
clkType Int
n') (Int -> Type
TupleT (Int -> Type) -> Int -> Type
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Int
1..Int
n]
  Type
instType1 <- Type -> Type -> Type
AppT Type
instType0 (Type -> Type) -> Q Type -> Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type
lockType
  let instHead :: Type
instHead = Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Clocks") Type
instType1

  Type
cxtRHS <- (Type -> Int -> Q Type) -> Type -> [Int] -> Q Type
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Type
a Int
n' -> Type -> Type -> Type
AppT Type
a (Type -> Type) -> Q Type -> Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Q Type
forall a. Show a => a -> Q Type
knownDomainCxt Int
n') (Int -> Type
TupleT Int
n) [Int
1..Int
n]
#if MIN_VERSION_template_haskell(2,15,0)
  let cxtLHS :: Type
cxtLHS = Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ClocksCxt") Type
instType1
  let cxtTy :: Dec
cxtTy  = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing Type
cxtLHS Type
cxtRHS)
#else
  let cxtTy  = TySynInstD (mkName "ClocksCxt") (TySynEqn [instType1] cxtRHS)
#endif

  -- Function definition of 'clocks'
  let clk :: Name
clk = String -> Name
mkName String
"clk"
  let rst :: Name
rst = String -> Name
mkName String
"rst"

  -- Implementation of 'clocks'
  let noInline :: Dec
noInline  = Pragma -> Dec
PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP (String -> Name
mkName String
"clocks") Inline
NoInline RuleMatch
FunLike Phases
AllPhases
  let clkImpls :: [Exp]
clkImpls  = Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
n (Name -> Exp
clkImpl Name
clk)
  let instTuple :: Exp
instTuple = [Exp] -> Exp
mkTupE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ [Exp]
clkImpls [Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++ [Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'unsafeCoerce) (Name -> Exp
VarE Name
rst)]
  let funcBody :: Body
funcBody  = Exp -> Body
NormalB Exp
instTuple
  let instFunc :: Dec
instFunc  = Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"clocks") [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
clk, Name -> Pat
VarP Name
rst] Body
funcBody []]

  Dec -> Q Dec
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 -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
instHead [Dec
cxtTy, Dec
instFunc, Dec
noInline]

  where
    -- | Generate type @Clock dom@ with fresh @dom@ variable
    clkType :: a -> Q Type
clkType a
n' =
      let c :: Q Type
c = Name -> Q Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
"c" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n') in
      [t| Clock $c |]

    knownDomainCxt :: a -> Q Type
knownDomainCxt a
n' =
      let c :: Q Type
c = Name -> Q Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String
"c" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n') in
      [t| KnownDomain $c |]

    -- | Generate type @Signal dom 'Bool@ with fresh @dom@ variable
    lockType :: Q Type
lockType =
      let c :: Q Type
c = Name -> Q Type
varT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"pllLock" in
      [t| Signal $c Bool |]

    clkImpl :: Name -> Exp
clkImpl Name
clk = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'unsafeCoerce) (Name -> Exp
VarE Name
clk)

-- Derive instances for up to and including to /n/ clocks
deriveClocksInstances :: Int -> Q [Dec]
deriveClocksInstances :: Int -> Q [Dec]
deriveClocksInstances Int
n = (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
derive' [Int
1..Int
n]