HasSingleDomain.hs

{-# LANGUAGE CPP                  #-}
{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ < 806
{-# LANGUAGE TypeInType #-}
#endif

{-# OPTIONS_GHC -Wno-missing-methods #-}

module Clash.Class.HasDomain.HasSingleDomain
  ( HasSingleDomain(..) ) where

import           Clash.Class.HasDomain.Common

import           Clash.Sized.Vector               (Vec)
import           Clash.Sized.RTree                (RTree)
import           Clash.Signal.Internal
  (Signal, Domain, Clock, Reset, Enable)
import           Clash.Signal.Delayed.Internal    (DSignal)

import           Data.Proxy                       (Proxy)
import           Data.Type.Bool                   (type If, type (&&))
import           Data.Type.Equality               (type (==))
import           Type.Errors                      (TypeError, ErrorMessage(Text))

data TryDomainResult
  = NotFound
  | Ambiguous
  | Found Domain

-- | Type family to resolve type conflicts (if any)
type family MergeTryDomainResults (n :: TryDomainResult) (m :: TryDomainResult) :: TryDomainResult where
  MergeTryDomainResults n m =
    If (n == 'NotFound && m == 'NotFound)
      'NotFound
      (If (n == m)
        (n)
        (If (n == 'NotFound)
          (m)
          (If (m == 'NotFound)
            n
            'Ambiguous)))

type family ErrOnConflict (n :: TryDomainResult) :: Domain where
  ErrOnConflict 'NotFound = TypeError ('Text "foo!")
  ErrOnConflict 'Ambiguous = TypeError ('Text "bar!")
  ErrOnConflict ('Found dom) = dom

type family TryDomain n :: TryDomainResult where
  TryDomain (DSignal dom delay a) = 'Found dom
  TryDomain (Signal dom a)        = 'Found dom
  TryDomain (Clock dom)           = 'Found dom
  TryDomain (Reset dom)           = 'Found dom
  TryDomain (Enable dom)          = 'Found dom
  TryDomain (a -> b)              = MergeTryDomainResults (TryDomain a) (TryDomain b)
  TryDomain (Vec n a)             = TryDomain a
  TryDomain (a, b)                = MergeTryDomainResults (TryDomain a) (TryDomain b)
  TryDomain a                     = 'NotFound

class HasSingleDomain r where
  type GetDomain r :: Domain

instance {-# OVERLAPPABLE #-} TypeError NoHasDomainInstance => HasSingleDomain a

instance HasSingleDomain (DSignal dom delay a) where
  type GetDomain (DSignal dom delay a) = dom

instance HasSingleDomain (Signal dom a) where
  type GetDomain (Signal dom a) = dom

instance HasSingleDomain (a -> b) where
  type GetDomain (a -> b) =
    ErrOnConflict (MergeTryDomainResults (TryDomain a) (TryDomain b))

instance HasSingleDomain (Vec n a) where
  type GetDomain (Vec n a) = ErrOnConflict (TryDomain a)

instance HasSingleDomain (RTree d a) where
  type GetDomain (RTree d a) = ErrOnConflict (TryDomain a)

instance HasSingleDomain (a, b) where
  type GetDomain (a, b) =
    ErrOnConflict (MergeTryDomainResults (TryDomain a) (TryDomain b))

instance HasSingleDomain (Proxy (dom :: Domain)) where
  type GetDomain (Proxy dom) = dom

instance HasSingleDomain (Clock dom) where
  type GetDomain (Clock dom) = dom

instance HasSingleDomain (Reset dom) where
  type GetDomain (Reset dom) = dom

instance HasSingleDomain (Enable dom) where
  type GetDomain (Enable dom) = dom