{-|
Copyright : (C) 2019, Myrtle Software Ltd
License : BSD2 (see the file LICENSE)
Maintainer : Christiaan Baaij
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ < 806
{-# LANGUAGE TypeInType #-}
#endif
{-# OPTIONS_GHC -Wno-missing-methods #-}
module Clash.Class.HasDomain.HasSingleDomain where
import Clash.Class.HasDomain.Common
import Clash.Class.HasDomain.CodeGen (mkTryDomainTuples)
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.Kind (Type)
import Data.Proxy (Proxy)
import Type.Errors
(DelayError, TypeError, IfStuck, Pure)
type MissingInstance =
"This might happen if an instance for TryDomain is missing. Try to determine"
:$$$: "which of the types miss an instance, and add them. Example implementations:"
:$$$: ""
:$$$: " * type instance TryDomain t (MyVector n a) = TryDomain t a"
:$$$: " * type instance TryDomain t (MyCircuit dom a) = Found dom"
:$$$: " * type instance TryDomain t Terminal = NotFound"
:$$$: ""
:$$$: "Alternatively, use one of the withSpecific* functions."
type Outro =
""
:$$$: "------"
:$$$: ""
:$$$: "You tried to apply an explicitly routed clock, reset, or enable line"
:$$$: "to a construct with, possibly, an implicitly routed one. Clash failed to"
:$$$: "unambigously determine a single domain and could therefore not route it."
:$$$: "You possibly used one of these sets of functions:"
:$$$: ""
:$$$: " * with{ClockResetEnable,Clock,Reset,Enable}"
:$$$: " * expose{ClockResetEnable,Clock,Reset,Enable}"
:$$$: ""
:$$$: "These functions are suitable for components defined over a single domain"
:$$$: "only. If you want to use multiple domains, use the following instead:"
:$$$: ""
:$$$: " * withSpecific{ClockResetEnable,Clock,Reset,Enable}"
:$$$: " * exposeSpecific{ClockResetEnable,Clock,Reset,Enable}"
:$$$: ""
type NotFoundError (t :: Type) =
"Could not find a non-ambiguous domain in the following type:"
:$$$: ""
:$$$: " " :<<>>: t
:$$$: ""
:$$$: MissingInstance
:$$$: Outro
type AmbiguousError (t :: Type) (dom1 :: Domain) (dom2 :: Domain) =
"Could not determine that the domain '" :<<>>: dom1 :<<>>: "'"
:$$$: "was equal to the domain '" :<<>>: dom2 :<<>>: "' in the type:"
:$$$: ""
:$$$: " " :<<>>: t
:$$$: ""
:$$$: "This is usually resolved by adding explicit type signatures."
:$$$: Outro
type StuckErrorMsg (orig :: Type) (n :: Type) =
"Could not determine whether the following type contained a non-ambiguous domain:"
:$$$: ""
:$$$: " " :<<>>: n
:$$$: ""
:$$$: "In the full type:"
:$$$: ""
:$$$: " " :<<>>: orig
:$$$: ""
:$$$: "Does it contain one?"
:$$$: ""
:$$$: "------"
:$$$: ""
:$$$: MissingInstance
:$$$: Outro
-- | Type that forces /dom/ to be the same in all subtypes of /r/ that might
-- contain a domain. If given a polymorphic domain not tied to /r/, GHC will
-- be allowed to infer that that domain is equal to the one in /r/ on the
-- condition that /r/ contains just a single domain.
type WithSingleDomain dom r =
(HasSingleDomain r, dom ~ GetDomain r)
data TryDomainResult
= NotFound
| Ambiguous Domain Domain
| Found Domain
-- | Type family to resolve type conflicts (if any)
type family Merge' (n :: TryDomainResult) (m :: TryDomainResult) :: TryDomainResult where
Merge' 'NotFound b = b
Merge' ('Ambiguous dom1 dom2) b = 'Ambiguous dom1 dom2
Merge' a 'NotFound = a
Merge' a ('Ambiguous dom1 dom2) = 'Ambiguous dom1 dom2
Merge' ('Found dom) ('Found dom) = 'Found dom
Merge' ('Found dom1) ('Found dom2) = 'Ambiguous dom1 dom2
-- | Same as Merge', but will insert a type error if Merge' got stuck.
type family Merge (orig :: Type) (n :: Type) (m :: Type) :: TryDomainResult where
Merge orig n m =
IfStuck
(TryDomain orig n)
(DelayError (StuckErrorMsg orig n))
(Pure
(IfStuck
(TryDomain orig m)
(DelayError (StuckErrorMsg orig m))
(Pure (Merge' (TryDomain orig n) (TryDomain orig m)))
))
type family ErrOnConflict (t :: Type) (n :: TryDomainResult) :: Domain where
ErrOnConflict t 'NotFound = TypeError (NotFoundError t)
ErrOnConflict t ('Ambiguous dom1 dom2) = TypeError (AmbiguousError t dom1 dom2)
ErrOnConflict t ('Found dom) = dom
type family TryDomain (orig :: Type) (n :: Type) :: TryDomainResult
type instance TryDomain t (DSignal dom delay a) = 'Found dom
type instance TryDomain t (Signal dom a) = 'Found dom
type instance TryDomain t (Clock dom) = 'Found dom
type instance TryDomain t (Reset dom) = 'Found dom
type instance TryDomain t (Enable dom) = 'Found dom
type instance TryDomain t (Proxy dom) = 'Found dom
type instance TryDomain t (Vec n a) = TryDomain t a
type instance TryDomain t (RTree d a) = TryDomain t a
type instance TryDomain t (a -> b) = Merge t a b
type instance TryDomain t (a, b) = Merge t a b
type instance TryDomain t () = 'NotFound
type instance TryDomain t Bool = 'NotFound
type instance TryDomain t Integer = 'NotFound
type instance TryDomain t Int = 'NotFound
type instance TryDomain t Float = 'NotFound
type instance TryDomain t Double = 'NotFound
type instance TryDomain t (Maybe a) = TryDomain t a
type instance TryDomain t (Either a b) = Merge t a b
-- TODO: Add more instances, including:
--type instance TryDomain t Bit = 'NotFound
--type instance TryDomain t (BitVector n) = 'NotFound
--type instance TryDomain t (Index n) = 'NotFound
--type instance TryDomain t (Fixed rep int frac) = 'NotFound
--type instance TryDomain t (Signed n) = 'NotFound
--type instance TryDomain t (Unsigned n) = 'NotFound
-- | Type family that searches a type and checks whether all subtypes that can
-- contain a domain (for example, Signal) contain the /same/ domain. Its
-- associated type, GetDomain, will yield a type error if that doesn't hold OR
-- if it can't check it.
class HasSingleDomain (r :: Type) where
type GetDomain r :: Domain
type GetDomain r =
-- Handle types not in TryDomain type family
IfStuck
(TryDomain r r)
(DelayError (StuckErrorMsg r r))
(Pure (ErrOnConflict r (TryDomain r r)))
instance HasSingleDomain a
mkTryDomainTuples ''TryDomain ''Merge