{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# 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 (Int -> TypeCategory -> ShowS
[TypeCategory] -> ShowS
TypeCategory -> String
(Int -> TypeCategory -> ShowS)
-> (TypeCategory -> String)
-> ([TypeCategory] -> ShowS)
-> Show TypeCategory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeCategory] -> ShowS
$cshowList :: [TypeCategory] -> ShowS
show :: TypeCategory -> String
$cshow :: TypeCategory -> String
showsPrec :: Int -> TypeCategory -> ShowS
$cshowsPrec :: Int -> TypeCategory -> ShowS
Show, TypeCategory -> TypeCategory -> Bool
(TypeCategory -> TypeCategory -> Bool)
-> (TypeCategory -> TypeCategory -> Bool) -> Eq TypeCategory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeCategory -> TypeCategory -> Bool
$c/= :: TypeCategory -> TypeCategory -> Bool
== :: TypeCategory -> TypeCategory -> Bool
$c== :: TypeCategory -> TypeCategory -> Bool
Eq, Eq TypeCategory
Eq TypeCategory
-> (TypeCategory -> TypeCategory -> Ordering)
-> (TypeCategory -> TypeCategory -> Bool)
-> (TypeCategory -> TypeCategory -> Bool)
-> (TypeCategory -> TypeCategory -> Bool)
-> (TypeCategory -> TypeCategory -> Bool)
-> (TypeCategory -> TypeCategory -> TypeCategory)
-> (TypeCategory -> TypeCategory -> TypeCategory)
-> Ord TypeCategory
TypeCategory -> TypeCategory -> Bool
TypeCategory -> TypeCategory -> Ordering
TypeCategory -> TypeCategory -> TypeCategory
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TypeCategory -> TypeCategory -> TypeCategory
$cmin :: TypeCategory -> TypeCategory -> TypeCategory
max :: TypeCategory -> TypeCategory -> TypeCategory
$cmax :: TypeCategory -> TypeCategory -> TypeCategory
>= :: TypeCategory -> TypeCategory -> Bool
$c>= :: TypeCategory -> TypeCategory -> Bool
> :: TypeCategory -> TypeCategory -> Bool
$c> :: TypeCategory -> TypeCategory -> Bool
<= :: TypeCategory -> TypeCategory -> Bool
$c<= :: TypeCategory -> TypeCategory -> Bool
< :: TypeCategory -> TypeCategory -> Bool
$c< :: TypeCategory -> TypeCategory -> Bool
compare :: TypeCategory -> TypeCategory -> Ordering
$ccompare :: TypeCategory -> TypeCategory -> Ordering
$cp1Ord :: Eq TypeCategory
Ord)

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 :: a k s -> a ANY s
toAny = a k s -> a ANY s
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (k' :: TypeCategory) (s :: Stage).
ToCategory a k k' =>
a k s -> a k' s
toCategory

fromAny ::
  (FromCategory a ANY k) =>
  a ANY (s :: Stage) ->
  Maybe (a k s)
fromAny :: a ANY s -> Maybe (a k s)
fromAny = a ANY s -> Maybe (a k s)
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (k' :: TypeCategory) (s :: Stage).
FromCategory a k k' =>
a k s -> Maybe (a k' s)
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