{-|
  Copyright   :  (C) 2012-2016, University of Twente,
                     2016     , Myrtle Software Ltd,
                     2017     , Google Inc.
                     2021     , QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  Types in CoreHW
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Clash.Core.Type
  ( Type (..)
  , TypeView (..)
  , ConstTy (..)
  , LitTy (..)
  , Kind
  , KindOrType
  , KiName
  , TyName
  , TyVar
  , tyView
  , coreView
  , coreView1
  , mkTyConTy
  , mkFunTy
  , mkPolyFunTy
  , mkTyConApp
  , splitFunTy
  , splitFunTys
  , splitFunForallTy
  , splitCoreFunForallTy
  , splitTyConAppM
  , isPolyFunTy
  , isPolyFunCoreTy
  , isPolyTy
  , isTypeFamilyApplication
  , isFunTy
  , isClassTy
  , applyFunTy
  , findFunSubst
  , reduceTypeFamily
  , isIntegerTy
  , normalizeType
  , varAttrs
  , typeAttrs
  )
where

-- External import
import           Control.DeepSeq        as DS
import           Data.Binary            (Binary)
import           Data.Coerce            (coerce)
import           Data.Hashable          (Hashable (hashWithSalt))
import           Data.List              (foldl')
import           Data.List.Extra        (splitAtList)
import           Data.Maybe             (isJust, mapMaybe)
import           Data.Text              (Text)
import           GHC.Base               (isTrue#,(==#))
import           GHC.Generics           (Generic(..))
import           GHC.Integer            (smallInteger)
import           GHC.Integer.Logarithms (integerLogBase#)
import           GHC.TypeLits           (type TypeError, ErrorMessage(Text, (:<>:)))
#if MIN_VERSION_base(4,16,0)
import           GHC.Base               (ord)
import           Data.Char              (chr)
import           Data.Maybe             (fromMaybe)
import           Data.Text.Extra        (showt)
#endif

-- GHC API
#if MIN_VERSION_ghc(9,0,0)
#if MIN_VERSION_ghc(9,2,0)
import           GHC.Builtin.Names
  (typeCharCmpTyFamNameKey, typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey,
   typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey)
#else
import           GHC.Builtin.Names      (typeNatLeqTyFamNameKey)
#endif
import           GHC.Builtin.Names
  (integerTyConKey, typeNatAddTyFamNameKey, typeNatExpTyFamNameKey,
   typeNatMulTyFamNameKey, typeNatSubTyFamNameKey,
   typeNatCmpTyFamNameKey, ordLTDataConKey, ordEQDataConKey, ordGTDataConKey,
   typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey)
import           GHC.Types.SrcLoc       (wiredInSrcSpan)
import           GHC.Types.Unique       (getKey)
#else
#if __GLASGOW_HASKELL__ >= 808
import           PrelNames
  (ordLTDataConKey, ordEQDataConKey, ordGTDataConKey)
#else
import           Unique                 (Unique)
import           PrelNames
  (ltDataConKey, eqDataConKey, gtDataConKey)
#endif
import           PrelNames
  (integerTyConKey, typeNatAddTyFamNameKey, typeNatExpTyFamNameKey,
   typeNatLeqTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey,
   typeNatCmpTyFamNameKey,
   typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey)
import           SrcLoc                 (wiredInSrcSpan)
import           Unique                 (getKey)
#endif

-- Local imports
import           Clash.Annotations.SynthesisAttributes
import           Clash.Core.DataCon
import           Clash.Core.Name
import {-# SOURCE #-} Clash.Core.Subst
import           Clash.Core.TyCon
import           Clash.Core.Var
import qualified Clash.Data.UniqMap as UniqMap
import           Clash.Util

#if __GLASGOW_HASKELL__ <= 806
ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique.Unique
ordLTDataConKey = ltDataConKey
ordEQDataConKey = eqDataConKey
ordGTDataConKey = gtDataConKey
#endif

varAttrs :: Var a -> [Attr Text]
varAttrs t@(TyVar {}) =
  error $ $(curLoc) ++ "Unexpected argument: " ++ show t

varAttrs (Id _ _ ty _) =
  case ty of
    AnnType attrs _typ -> attrs
    _                  -> []


-- | Types in CoreHW: function and polymorphic types
data Type
  = VarTy    !TyVar             -- ^ Type variable
  | ConstTy  !ConstTy           -- ^ Type constant
  | ForAllTy !TyVar !Type       -- ^ Polymorphic Type
  | AppTy    !Type !Type        -- ^ Type Application
  | LitTy    !LitTy             -- ^ Type literal
  | AnnType  [Attr Text] !Type  -- ^ Annotated type, see Clash.Annotations.SynthesisAttributes
  deriving (Show, Generic, NFData, Binary)

instance TypeError (
        'Text "A broken implementation of Hashable Type has been "
  ':<>: 'Text "removed in Clash 1.4.7. If this is an issue for you, please submit "
  ':<>: 'Text "an issue report at https://github.com/clash-lang/clash-compiler/issues."
  ) => Hashable Type where
    hashWithSalt = error "Type.hashWithSalt: unreachable"

-- | An easier view on types
data TypeView
  = FunTy    !Type  !Type      -- ^ Function type
  | TyConApp !TyConName [Type] -- ^ Applied TyCon
  | OtherType !Type            -- ^ Neither of the above
  deriving Show

-- | Type Constants
data ConstTy
  = TyCon !TyConName -- ^ TyCon type
  | Arrow            -- ^ Function type
  deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary)

-- | Literal Types
data LitTy
  = NumTy !Integer
  | SymTy !String
  | CharTy !Char
  deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary)

-- | The level above types
type Kind       = Type
-- | Either a Kind or a Type
type KindOrType = Type

-- | Reference to a Type
type TyName     = Name Type
-- | Reference to a Kind
type KiName     = Name Kind

-- TODO
--
-- tyView could be smarter about what it gives back. Since it traverses the
-- arguments to make a `TyConApp`, if the leftmost innermost type isn't a
-- TyCon it could still return a list of applied types to save a later call to
-- something like splitFunForallTy.
--
-- It could / should also look through annotations instead of just returning
-- the original type wrapped in OtherType.

-- | An easier view on types
--
-- Note [Arrow arguments]
--
-- Clash' Arrow type can either have 2 or 4 arguments, depending on who created it.
-- By default it has two arguments: the argument type of a function, and the result
-- type of a function.
--
-- So when do we have 4 arguments? When in Haskell/GHC land the arrow was
-- unsaturated. This can happen in instance heads, or in the eta-reduced
-- representation of newtypes. So what are those additional 2 arguments compared to
-- the "normal" function type? They're the kinds of argument and result type.
tyView :: Type -> TypeView
-- XXX: this is a manually unrolled version of:
--
-- tyView tOrig = go [] tOrig
--  where
--   go args t = case t of
--     ConstTy c -> case c of
--       TyCon tc -> TyConApp tc args
--       Arrow -> case args of
--         (arg:res:rest) -> case rest of
--           [] -> FunTy arg res
--           [arg1,res1] -> FunTy arg1 res1
--           _ -> OtherType tOrig
--     AppTy l r -> go (r:args) l
--     _ -> OtherType tOrig
--
-- To get a FunTy without recursive calls. Because it is called so often this
-- saves us 5-10% runtime.
tyView tOrig = case tOrig of
  ConstTy c -> case c of
    TyCon tc -> TyConApp tc []
    _ -> OtherType tOrig
  AppTy l0 res -> case l0 of
    ConstTy (TyCon tc) -> TyConApp tc [res]
    AppTy l1 arg -> case l1 of
      ConstTy Arrow -> FunTy arg res
      ConstTy (TyCon tc) -> TyConApp tc [arg,res]
      AppTy l2 resK -> case l2 of
        ConstTy (TyCon tc) -> TyConApp tc [resK,arg,res]
        AppTy l3 argK -> case l3 of
          ConstTy (TyCon tc) -> TyConApp tc [argK,resK,arg,res]
          ConstTy Arrow -> FunTy arg res -- See Note [Arrow arguments]
          _ -> case go [argK,resK,arg,res] l3 of
            (ConstTy (TyCon tc),args)
              -> TyConApp tc args
            _ -> OtherType tOrig
        _ -> OtherType tOrig
      _ -> OtherType tOrig
    _ -> OtherType tOrig
  _ -> OtherType tOrig
 where
  go args (AppTy ty1 ty2) = go (ty2:args) ty1
  go args t1              = (t1,args)

-- | A view on types in which newtypes are transparent, the Signal type is
-- transparent, and type functions are evaluated to WHNF (when possible).
--
-- Strips away ALL layers. If no layers are found it returns the given type.
coreView :: TyConMap -> Type -> Type
coreView tcm ty =
  case coreView1 tcm ty of
    Nothing  -> ty
    Just ty' -> coreView tcm ty'

-- | A view on types in which newtypes are transparent, the Signal type is
-- transparent, and type functions are evaluated to WHNF (when possible).
--
-- Only strips away one "layer".
coreView1 :: TyConMap -> Type -> Maybe Type
coreView1 tcMap ty = case tyView ty of
  TyConApp tcNm args
    | nameOcc tcNm == "Clash.Signal.BiSignal.BiSignalIn"
    , [_,_,_,elTy] <- args
    -> Just elTy
    | nameOcc tcNm == "Clash.Signal.BiSignal.BiSignalOut"
    , [_,_,_,elTy] <- args
    -> Just elTy
    | nameOcc tcNm == "Clash.Signal.Internal.Signal"
    , [_,elTy] <- args
    -> Just elTy
    | otherwise
    -> case UniqMap.find tcNm tcMap of
         AlgTyCon {algTcRhs = (NewTyCon _ nt)}
           -> newTyConInstRhs nt args
         _ -> reduceTypeFamily tcMap ty
  OtherType (AnnType _ ty') -> coreView1 tcMap ty'
  _ -> Nothing

-- | Instantiate and Apply the RHS/Original of a NewType with the given
-- list of argument types
--
-- Returns /Nothing/ when under-applied
newTyConInstRhs :: ([TyVar],Type) -> [Type] -> Maybe Type
newTyConInstRhs (tvs,ty) tys
    | length tvs <= length tys
    = Just (foldl' AppTy (substTyWith tvs tys1 ty) tys2)
    | otherwise
    = Nothing
  where
    (tys1, tys2) = splitAtList tvs tys

-- | Make a function type of an argument and result type
mkFunTy :: Type -> Type -> Type
mkFunTy t1 = AppTy (AppTy (ConstTy Arrow) t1)

-- | Make a TyCon Application out of a TyCon and a list of argument types
mkTyConApp :: TyConName -> [Type] -> Type
mkTyConApp tc = foldl AppTy (ConstTy $ TyCon tc)

-- | Make a Type out of a TyCon
mkTyConTy :: TyConName -> Type
mkTyConTy ty = ConstTy $ TyCon ty

-- | Split a TyCon Application in a TyCon and its arguments
splitTyConAppM :: Type
               -> Maybe (TyConName,[Type])
splitTyConAppM (tyView -> TyConApp tc args) = Just (tc,args)
splitTyConAppM _                            = Nothing

-- | Is a type polymorphic?
isPolyTy :: Type -> Bool
isPolyTy (ForAllTy _ _)          = True
isPolyTy (tyView -> FunTy _ res) = isPolyTy res
isPolyTy _                       = False

-- | Split a function type in an argument and result type
splitFunTy :: TyConMap
           -> Type
           -> Maybe (Type, Type)
splitFunTy m (coreView1 m -> Just ty)  = splitFunTy m ty
splitFunTy _ (tyView -> FunTy arg res) = Just (arg,res)
splitFunTy _ _ = Nothing

splitFunTys :: TyConMap
            -> Type
            -> ([Type],Type)
splitFunTys m ty = go [] ty ty
  where
    go args orig_ty (coreView1 m -> Just ty') = go args orig_ty ty'
    go args _       (tyView -> FunTy arg res) = go (arg:args) res res
    go args orig_ty _                         = (reverse args, orig_ty)

-- | Split a poly-function type in a: list of type-binders and argument types,
-- and the result type
splitFunForallTy :: Type
                 -> ([Either TyVar Type],Type)
splitFunForallTy = go []
  where
    go args (ForAllTy tv ty)          = go (Left tv:args) ty
    go args (tyView -> FunTy arg res) = go (Right arg:args) res
    go args ty                        = (reverse args,ty)

-- | Make a polymorphic function type out of a result type and a list of
-- quantifiers and function argument types
mkPolyFunTy
  :: Type
  -- ^ Result type
  -> [Either TyVar Type]
  -- ^ List of quantifiers and function argument types
  -> Type
mkPolyFunTy = foldr (either ForAllTy mkFunTy)

-- | Split a poly-function type in a: list of type-binders and argument types,
-- and the result type. Looks through 'Signal' and type functions.
splitCoreFunForallTy :: TyConMap
                     -> Type
                     -> ([Either TyVar Type], Type)
splitCoreFunForallTy tcm ty = go [] ty ty
  where
    go args orig_ty (coreView1 tcm -> Just ty') = go args orig_ty ty'
    go args _       (ForAllTy tv res)           = go (Left tv:args) res res
    go args _       (tyView -> FunTy arg res)   = go (Right arg:args) res res
    go args orig_ty _                           = (reverse args,orig_ty)

-- | Is a type a polymorphic or function type?
isPolyFunTy :: Type
            -> Bool
isPolyFunTy = not . null . fst . splitFunForallTy

-- | Is a type a polymorphic or function type under 'coreView1'?
isPolyFunCoreTy :: TyConMap
                -> Type
                -> Bool
isPolyFunCoreTy m (coreView1 m -> Just ty) = isPolyFunCoreTy m ty
isPolyFunCoreTy _ ty = case tyView ty of
  FunTy _ _ -> True
  OtherType (ForAllTy _ _) -> True
  _ -> False

-- | Extract attributes from type. Will return an empty list if this is an
-- AnnType with an empty list AND if this is not an AnnType at all.
typeAttrs :: Type -> [Attr Text]
typeAttrs (AnnType attrs _typ) = attrs
typeAttrs _                    = []

-- | Is a type a function type?
isFunTy :: TyConMap
        -> Type
        -> Bool
isFunTy m = isJust . splitFunTy m

-- | Apply a function type to an argument type and get the result type
applyFunTy :: TyConMap
           -> Type
           -> Type
           -> Type
applyFunTy m (coreView1 m -> Just ty)   arg = applyFunTy m ty arg
applyFunTy _ (tyView -> FunTy _ resTy) _    = resTy
applyFunTy _ _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy"

-- Type function substitutions

-- Given a set of type functions, and list of argument types, get the first
-- type function that matches, and return its substituted RHS type.
findFunSubst :: TyConMap -> [([Type],Type)] -> [Type] -> Maybe Type
findFunSubst _   [] _ = Nothing
findFunSubst tcm (tcSubst:rest) args = case funSubsts tcm tcSubst args of
  Just ty -> Just ty
  Nothing -> findFunSubst tcm rest args

-- Given a ([LHS match type], RHS type) representing a type function, and
-- a set of applied types. Match LHS with args, and when successful, return
-- a substituted RHS
funSubsts :: TyConMap -> ([Type],Type) -> [Type] -> Maybe Type
funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do
  let (funArgs,remainder) = zipAtLeast tcSubstLhs args
  tySubts <- foldl' (funSubst tcm) (Just []) funArgs
  let tyRhs = uncurry substTyWith (unzip tySubts) tcSubstRhs
  -- Type functions can return higher-kinded types
  case remainder of
    []    -> return tyRhs
    -- So don't forget to apply the arguments not consumed by the type
    -- function application!
    --
    -- Forgetting leads to: #232
    args' -> return (foldl' AppTy tyRhs args')
  where
    zipAtLeast [] ys = ([],ys)
    zipAtLeast _  [] = error "Under-applied type family"
    zipAtLeast (x:xs) (y:ys) =
      let (zs,remainder) = zipAtLeast xs ys
       in ((x,y):zs,remainder)

-- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS
-- are a match. If they do match, and the LHS is a variable, return a
-- substitution
funSubst
  :: TyConMap
  -> Maybe [(TyVar,Type)]
  -> (Type,Type)
  -> Maybe [(TyVar,Type)]
funSubst _   Nothing  = const Nothing
funSubst tcm (Just s) = uncurry go
  where
    go (VarTy nmF) ty = case lookup nmF s of
      Nothing -> Just ((nmF,ty):s)
      -- Given, for example, the type family definition:
      --
      -- > type family Max x y where
      -- >   Max 0 b = b
      -- >   Max a 0 = a
      -- >   Max n n = n
      -- >   Max a b = If (a <=? b) b a
      --
      -- Then `Max 4 8` matches against the 4th clause.
      --
      -- So this is why, whenever we match against a type variable, we first
      -- check if there is already a substitution defined for this type variable,
      -- and if so, the applied type, and the type in the substitution should match.
      Just ty' | ty' `aeqType` ty -> Just s
      _ -> Nothing

    -- [Note] funSubst FunTy
    --
    -- Whenever type classes have associated types whose instances 'map' to
    -- functions, we try to find substitutions in the LHS and RHS of these
    -- (type-level) functions. Because we use @funSubst@ recursively, we
    -- implicitly check if these functions are of the same arity and match
    -- in the first place. An example of such a construct:
    --
    --   class Example p where
    --     type AB p
    --
    --   instance Example (a -> a) where
    --     type AB (a -> a) = a
    --
    -- In the given example, we would find two substitutions. For example, when
    -- matching against `Char -> Char` we'd find a duplicate `a -> Char`. We
    -- can't think of any (type-checking) cases where these mappings would map
    -- to different types, so this is OK for our purposes.
    go (AppTy a1 r1) (AppTy a2 r2) = do
      s1 <- funSubst tcm (Just s) (a1, a2)
      funSubst tcm (Just s1)
                   ( r1
                   , argView tcm r2 -- See [Note: Eager type families]
                   )

    go ty1@(ConstTy _) ty2 =
      -- Looks through AnnType
      if ty1 `aeqType` ty2 then Just s else Nothing

    go ty1@(LitTy _) ty2 =
      -- Looks through AnnType
      if ty1 `aeqType` ty2 then Just s else Nothing

    go _ _ = Nothing

{- [Note: Eager type families]

I don't know whether type families are evaluated strictly or lazily, but since
type families do not reduce on stuck argument, we assume strictly.
-}

reduceTypeFamily :: TyConMap -> Type -> Maybe Type
reduceTypeFamily tcm (tyView -> TyConApp tc tys)
  | nameUniq tc == getKey typeNatAddTyFamNameKey
  = case mapMaybe (litView tcm) tys of
      [i1,i2] -> Just (LitTy (NumTy (i1 + i2)))
      _ -> Nothing

  | nameUniq tc == getKey typeNatMulTyFamNameKey
  = case mapMaybe (litView tcm) tys of
      [i1, i2] -> Just (LitTy (NumTy (i1 * i2)))
      _ -> Nothing

  | nameUniq tc == getKey typeNatExpTyFamNameKey
  = case mapMaybe (litView tcm) tys of
      [i1, i2] -> Just (LitTy (NumTy (i1 ^ i2)))
      _ -> Nothing

  | nameUniq tc == getKey typeNatSubTyFamNameKey
  = case mapMaybe (litView tcm) tys of
      [i1, i2]
        | let z = i1 - i2
        , z >= 0
        -> Just (LitTy (NumTy z))
      _ -> Nothing

#if !MIN_VERSION_ghc(9,2,0)
  | nameUniq tc == getKey typeNatLeqTyFamNameKey
  = case mapMaybe (litView tcm) tys of
      [i1, i2]
        | Just (FunTyCon {tyConKind = tck}) <- UniqMap.lookup tc tcm
        , (_,tyView -> TyConApp boolTcNm []) <- splitFunTys tcm tck
        , Just boolTc <- UniqMap.lookup boolTcNm tcm
        -> let [falseTc,trueTc] = map (coerce . dcName) (tyConDataCons boolTc)
            in  if i1 <= i2 then Just (mkTyConApp trueTc [])
                            else Just (mkTyConApp falseTc [])
      _ -> Nothing
#endif

  | nameUniq tc == getKey typeNatCmpTyFamNameKey -- "GHC.TypeNats.CmpNat"
  = case mapMaybe (litView tcm) tys of
      [i1, i2] ->
        Just $ ConstTy $ TyCon $
          case compare i1 i2 of
            LT -> Name User "GHC.Types.LT" (getKey ordLTDataConKey) wiredInSrcSpan
            EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan
            GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan
      _ -> Nothing

  | nameUniq tc == getKey typeSymbolCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol"
  = case mapMaybe (symLitView tcm) tys of
      [s1, s2] ->
        Just $ ConstTy $ TyCon $
          case compare s1 s2 of
            LT -> Name User "GHC.Types.LT" (getKey ordLTDataConKey) wiredInSrcSpan
            EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan
            GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan
      _ -> Nothing

#if MIN_VERSION_base(4,16,0)
  | nameUniq tc == getKey typeCharCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol"
  = case mapMaybe (charLitView tcm) tys of
      [s1, s2] ->
        Just $ ConstTy $ TyCon $
          case compare s1 s2 of
            LT -> Name User (showt 'LT) (getKey ordLTDataConKey) wiredInSrcSpan
            EQ -> Name User (showt 'EQ) (getKey ordEQDataConKey) wiredInSrcSpan
            GT -> Name User (showt 'GT) (getKey ordGTDataConKey) wiredInSrcSpan
      _ -> Nothing

  | nameUniq tc == getKey typeConsSymbolTyFamNameKey -- ConsSymbol
  , [c0, s0] <- tys
  , Just c1 <- charLitView tcm c0
  , Just s1 <- symLitView tcm s0
  = Just (LitTy (SymTy (c1:s1)))

  | nameUniq tc == getKey typeUnconsSymbolTyFamNameKey -- UnconsSymbol
  , [s1] <- mapMaybe (symLitView tcm) tys
  = fromMaybe (error "reduceTypeFamily: cannot construct UnconsSymbol result") $ do
      FunTyCon {tyConKind = tck} <- UniqMap.lookup tc tcm
      TyConApp maybeTcNm [tupTcApp] <- pure (tyView (snd (splitFunTys tcm tck)))
      maybeTc <- UniqMap.lookup maybeTcNm tcm
      [nothingTc,justTc] <- pure (map (coerce . dcName) (tyConDataCons maybeTc))
      TyConApp tupTcNm [charTy,symbolTy] <- pure (tyView tupTcApp)
      tupTc <- UniqMap.lookup tupTcNm tcm
      [tupDc] <- pure (map (coerce . dcName) (tyConDataCons tupTc))
      case s1 of
        [] ->
          pure (Just (mkTyConApp nothingTc [tupTcApp]))
        (c:cs) ->
          let tup = mkTyConApp tupDc
                      [charTy,symbolTy,LitTy (CharTy c),LitTy (SymTy cs)]
           in pure (Just (mkTyConApp justTc [tupTcApp,tup]))

  | nameUniq tc == getKey typeCharToNatTyFamNameKey -- CharToNat
  , [c1] <- mapMaybe (charLitView tcm) tys
  = Just (LitTy (NumTy (fromIntegral (ord c1))))

  | nameUniq tc == getKey typeNatToCharTyFamNameKey -- NatToChar
  , [n1] <- mapMaybe (litView tcm) tys
  = Just (LitTy (CharTy (chr (fromInteger n1))))
#endif

  | nameUniq tc == getKey typeSymbolAppendFamNameKey  -- GHC.TypeLits.AppendSymbol"
  = case mapMaybe (symLitView tcm) tys of
      [s1, s2] ->
        Just (LitTy (SymTy (s1 ++ s2)))
      _ -> Nothing

  | nameOcc tc `elem` ["GHC.TypeLits.Extra.FLog", "GHC.TypeNats.FLog"]
  = case mapMaybe (litView tcm) tys of
      [i1, i2]
        | i1 > 1
        , i2 > 0
        -> Just (LitTy (NumTy (smallInteger (integerLogBase# i1 i2))))
      _ -> Nothing


  | nameOcc tc `elem` ["GHC.TypeLits.Extra.CLog", "GHC.TypeNats.CLog"]
  = case mapMaybe (litView tcm) tys of
      [i1, i2]
        | Just k <- clogBase i1 i2
        -> Just (LitTy (NumTy (toInteger k)))
      _ -> Nothing

  | nameOcc tc `elem` ["GHC.TypeLits.Extra.Log", "GHC.TypeNats.Log"]
  = case mapMaybe (litView tcm) tys of
      [i1, i2]
        | i1 > 1
        , i2 > 0
        -> if i2 == 1
           then Just (LitTy (NumTy 0))
           else let z1 = integerLogBase# i1 i2
                    z2 = integerLogBase# i1 (i2-1)
                in  if isTrue# (z1 ==# z2)
                        then Nothing
                        else Just (LitTy (NumTy (smallInteger z1)))
      _ -> Nothing


  | nameOcc tc `elem` ["GHC.TypeLits.Extra.GCD", "GHC.TypeNats.GCD"]
  = case mapMaybe (litView tcm) tys of
      [i1, i2] -> Just (LitTy (NumTy (i1 `gcd` i2)))
      _ -> Nothing

  | nameOcc tc `elem` ["GHC.TypeLits.Extra.LCM", "GHC.TypeNats.LCM"]
  = case  mapMaybe (litView tcm) tys of
      [i1, i2] -> Just (LitTy (NumTy (i1 `lcm` i2)))
      _ -> Nothing

  | nameOcc tc `elem` ["GHC.TypeLits.Extra.Div", "GHC.TypeNats.Div"]
  = case mapMaybe (litView tcm) tys of
      [i1, i2]
        | i2 > 0
        -> Just (LitTy (NumTy (i1 `div` i2)))
      _ -> Nothing

  | nameOcc tc `elem` ["GHC.TypeLits.Extra.Mod", "GHC.TypeNats.Mod"]
  = case mapMaybe (litView tcm) tys of
      [i1, i2]
        | i2 > 0
        -> Just (LitTy (NumTy (i1 `mod` i2)))
      _ -> Nothing

  | Just (FunTyCon {tyConSubst = tcSubst}) <- UniqMap.lookup tc tcm
  = let -- See [Note: Eager type families]
        tysR = map (argView tcm) tys
     in findFunSubst tcm tcSubst tysR

reduceTypeFamily _ _ = Nothing

-- |
isTypeFamilyApplication ::  TyConMap -> Type -> Bool
isTypeFamilyApplication tcm (tyView -> TyConApp tcNm _args)
  | Just (FunTyCon {}) <- UniqMap.lookup tcNm tcm = True
isTypeFamilyApplication _tcm _type = False

argView :: TyConMap -> Type -> Type
argView m t = case reduceTypeFamily m t of
  Nothing -> t
  Just tR -> argView m tR

litView :: TyConMap -> Type -> Maybe Integer
litView _ (LitTy (NumTy i))                = Just i
litView m (reduceTypeFamily m -> Just ty') = litView m ty'
litView _ _ = Nothing

symLitView :: TyConMap -> Type -> Maybe String
symLitView _ (LitTy (SymTy s))                = Just s
symLitView m (reduceTypeFamily m -> Just ty') = symLitView m ty'
symLitView _ _ = Nothing

#if MIN_VERSION_base(4,16,0)
charLitView :: TyConMap -> Type -> Maybe Char
charLitView _ (LitTy (CharTy c)) = Just c
charLitView m (reduceTypeFamily m -> Just t) = charLitView m t
charLitView _ _ = Nothing
#endif

isIntegerTy :: Type -> Bool
isIntegerTy (ConstTy (TyCon nm)) = nameUniq nm == getKey integerTyConKey
isIntegerTy _ = False

-- | Normalize a type, looking through Signals and newtypes
--
-- For example: @Signal a (Vec (6-1) (Unsigned (3+1)))@ normalizes to @Vec 5 (Unsigned 4)@
normalizeType :: TyConMap -> Type -> Type
normalizeType tcMap = go
  where
  go ty = case tyView ty of
    TyConApp tcNm args
      -- These Clash types are implemented with newtypes.
      -- We need to keep these newtypes because they define the width of the numbers.
      | nameOcc tcNm == "Clash.Sized.Internal.BitVector.Bit" ||
        nameOcc tcNm == "Clash.Sized.Internal.BitVector.BitVector" ||
        nameOcc tcNm == "Clash.Sized.Internal.Index.Index"         ||
        nameOcc tcNm == "Clash.Sized.Internal.Signed.Signed"       ||
        nameOcc tcNm == "Clash.Sized.Internal.Unsigned.Unsigned"
      -> mkTyConApp tcNm (map go args)
      | otherwise
      -> case UniqMap.find tcNm tcMap of
          AlgTyCon {algTcRhs = (NewTyCon _ nt)}
             -> case newTyConInstRhs nt args of
                  Just ty' -> go ty'
                  Nothing  -> ty
          _ ->
             let args' = map go args
                 ty' = mkTyConApp tcNm args'
             in case reduceTypeFamily tcMap ty' of
               -- TODO Instead of recursing here, reduceTypeFamily should
               -- ensure that if the result is a reducible type family it is
               -- also reduced. This would reduce traversals over a type.
               --
               -- It may be a good idea to keep reduceTypeFamily only reducing
               -- one family, and definiing reduceTypeFamilies to reduce all
               -- it encounters in one traversal.
               Just ty'' -> go ty''
               Nothing  -> ty'
    FunTy ty1 ty2 -> mkFunTy (go ty1) (go ty2)
    OtherType (ForAllTy tyvar ty')
      -> ForAllTy tyvar (go ty')
    _ -> ty

isClassTy
  :: TyConMap
  -> Type
  -> Bool
isClassTy tcm (tyView -> TyConApp tcNm _) =
  case UniqMap.lookup tcNm tcm of
    Just (AlgTyCon {isClassTc}) -> isClassTc
    _ -> False
isClassTy _ _ = False
