content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveAnyClass #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  
  module Data.Morpheus.Types.Internal.AST.TypeCategory
    ( TypeCategory (IN, OUT, LEAF),
      type (<=!),
      type (<=?),
      OUT,
      IN,
      ANY,
      LEAF,
      OBJECT,
      INPUT_OBJECT,
      IMPLEMENTABLE,
      fromAny,
      toAny,
      ToCategory (..),
      FromCategory (..),
      ToOBJECT,
    )
  where
  
  import Data.Morpheus.Types.Internal.AST.Base
    ( FALSE,
      TRUE,
    )
  import Data.Morpheus.Types.Internal.AST.Stage (Stage)
  import Relude
  
  data TypeCategory
    = IN
    | OUT
    | ANY
    | LEAF
    | OBJECT
    | INPUT_OBJECT
    | IMPLEMENTABLE
    deriving (Show, Eq, Ord, Generic, Hashable)
  
  type IN = 'IN
  
  type OUT = 'OUT
  
  type ANY = 'ANY
  
  type OBJECT = 'OBJECT
  
  type IMPLEMENTABLE = 'IMPLEMENTABLE
  
  type LEAF = 'LEAF
  
  type INPUT_OBJECT = 'INPUT_OBJECT
  
  toAny ::
    (ToCategory a k ANY) =>
    a (k :: TypeCategory) (s :: Stage) ->
    a ANY s
  toAny = toCategory
  
  fromAny ::
    (FromCategory a ANY k) =>
    a ANY (s :: Stage) ->
    Maybe (a k s)
  fromAny = fromCategory
  
  class ToCategory a (k :: TypeCategory) (k' :: TypeCategory) where
    toCategory :: a k (s :: Stage) -> a k' s
  
  class FromCategory a (k :: TypeCategory) (k' :: TypeCategory) where
    fromCategory :: a k (s :: Stage) -> Maybe (a k' s)
  
  type (a :: TypeCategory) <=! (b :: TypeCategory) = a <=? b ~ TRUE
  
  -- <=
  type family (elem :: TypeCategory) <=? (cat :: TypeCategory) :: Bool where
    -- leaf
    LEAF <=? IN = TRUE
    LEAF <=? OUT = TRUE
    -- input
    INPUT_OBJECT <=? IN = TRUE
    -- output
    OBJECT <=? IMPLEMENTABLE = TRUE
    OBJECT <=? OUT = TRUE
    IMPLEMENTABLE <=? OUT = TRUE
    -- all other cases are false
    ANY <=? a = TRUE
    a <=? ANY = TRUE
    a <=? a = TRUE
    a <=? b = FALSE
  
  type family ToOBJECT (s :: TypeCategory) :: TypeCategory where
    ToOBJECT OUT = OBJECT
    ToOBJECT IN = INPUT_OBJECT
  