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

{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE ViewPatterns      #-}

module Clash.Clocks.Deriving (deriveClocksInstances) where

import Control.Monad               (foldM)
import Clash.Signal.Internal
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' n :: Int
n = do
  -- (Clock d0, Clock d1, )
  Type
instType  <- (Type -> Int -> Q Type) -> Type -> [Int] -> Q Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\a :: Type
a n' :: Int
n' -> Type -> Type -> Type
AppT Type
a (Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) 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
+ 1) [1..Int
n]
  Type
instType' <- (Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName "Clocks") (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
instType) (Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type
lockType

  -- Function definition of 'clocks'
  let clk :: Name
clk = String -> Name
mkName "clk"
  let rst :: Name
rst = String -> Name
mkName "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 "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
TupE ([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 "clocks") [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
clk, Name -> Pat
VarP Name
rst] Body
funcBody []]

  Dec -> Q Dec
forall (m :: * -> *) 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
instType' [Dec
instFunc, Dec
noInline]

  where
    -- | Generate type @Clock dom@ with fresh @dom@ variable
    clkType :: a -> Q Type
clkType n' :: 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 ("c" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n') in
      [t| Clock $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 "pllLock" in
      [t| Signal $c Bool |]

    clkImpl :: Name -> Exp
clkImpl clk :: 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 n :: Int
n = (Int -> Q Dec) -> [Int] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> Q Dec
derive' [1..Int
n]