module ProjectM36.DataTypes.Either where
import ProjectM36.Base
import ProjectM36.AtomFunction
import ProjectM36.AtomFunctionError
import qualified Data.HashSet as HS
import qualified Data.Map as M
       
eitherAtomType :: AtomType -> AtomType -> AtomType
eitherAtomType :: AtomType -> AtomType -> AtomType
eitherAtomType AtomType
tA AtomType
tB = TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType TypeConstructorName
"Either" ([(TypeConstructorName, AtomType)] -> TypeVarMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(TypeConstructorName
"a", AtomType
tA), (TypeConstructorName
"b", AtomType
tB)])
  
eitherTypeConstructorMapping :: TypeConstructorMapping                
eitherTypeConstructorMapping :: TypeConstructorMapping
eitherTypeConstructorMapping = [(TypeConstructorName -> [TypeConstructorName] -> TypeConstructorDef
ADTypeConstructorDef TypeConstructorName
"Either" [TypeConstructorName
"a", TypeConstructorName
"b"],
                                 [TypeConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef TypeConstructorName
"Left" [TypeConstructorName -> DataConstructorDefArg
DataConstructorDefTypeVarNameArg TypeConstructorName
"a"],
                                  TypeConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef TypeConstructorName
"Right" [TypeConstructorName -> DataConstructorDefArg
DataConstructorDefTypeVarNameArg TypeConstructorName
"b"]])]
       
eitherAtomFunctions :: AtomFunctions                               
eitherAtomFunctions :: AtomFunctions
eitherAtomFunctions = [AtomFunction] -> AtomFunctions
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [
  TypeConstructorName
-> [AtomType] -> AtomFunctionBodyType -> AtomFunction
compiledAtomFunction TypeConstructorName
"isLeft" [AtomType -> AtomType -> AtomType
eitherAtomType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a") (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"b"), AtomType
BoolAtomType] (AtomFunctionBodyType -> AtomFunction)
-> AtomFunctionBodyType -> AtomFunction
forall a b. (a -> b) -> a -> b
$ \case
        (ConstructedAtom TypeConstructorName
dConsName AtomType
_ [Atom]
_:[Atom]
_) -> Atom -> Either AtomFunctionError Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> Atom
BoolAtom (TypeConstructorName
dConsName TypeConstructorName -> TypeConstructorName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeConstructorName
"Left"))
        [Atom]
_ -> AtomFunctionError -> Either AtomFunctionError Atom
forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
  ]