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

{-# 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