module ProjectM36.DataTypes.NonEmptyList where
import ProjectM36.Base
import qualified Data.Map as M
import qualified Data.HashSet as HS
import ProjectM36.AtomFunctionError
import ProjectM36.DataTypes.List
nonEmptyListAtomType :: AtomType -> AtomType
nonEmptyListAtomType :: AtomType -> AtomType
nonEmptyListAtomType AtomType
arg = DataConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType DataConstructorName
"NonEmptyList" (forall k a. k -> a -> Map k a
M.singleton DataConstructorName
"a" AtomType
arg)
nonEmptyListTypeConstructorMapping :: TypeConstructorMapping
nonEmptyListTypeConstructorMapping :: TypeConstructorMapping
nonEmptyListTypeConstructorMapping = [(DataConstructorName -> [DataConstructorName] -> TypeConstructorDef
ADTypeConstructorDef DataConstructorName
"NonEmptyList" [DataConstructorName
"a"],
[DataConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef DataConstructorName
"NECons" [DataConstructorName -> DataConstructorDefArg
DataConstructorDefTypeVarNameArg DataConstructorName
"a",
TypeConstructor -> DataConstructorDefArg
DataConstructorDefTypeConstructorArg (forall a.
DataConstructorName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor DataConstructorName
"List" [forall a. DataConstructorName -> TypeConstructorBase a
TypeVariable DataConstructorName
"a"])]])]
nonEmptyListLength :: Atom -> Either AtomFunctionError Int
nonEmptyListLength :: Atom -> Either AtomFunctionError Int
nonEmptyListLength (ConstructedAtom DataConstructorName
"NECons" AtomType
_ (Atom
_:Atom
nextCons:[Atom]
_)) = do
Int
c <- Atom -> Either AtomFunctionError Int
listLength Atom
nextCons
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
c forall a. Num a => a -> a -> a
+ Int
1)
nonEmptyListLength (ConstructedAtom DataConstructorName
"NECons" AtomType
_ [Atom]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
nonEmptyListLength Atom
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
nonEmptyListHead :: Atom -> Either AtomFunctionError Atom
nonEmptyListHead :: Atom -> Either AtomFunctionError Atom
nonEmptyListHead (ConstructedAtom DataConstructorName
"NECons" AtomType
_ (Atom
val:[Atom]
_)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
val
nonEmptyListHead Atom
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
nonEmptyListAtomFunctions :: AtomFunctions
nonEmptyListAtomFunctions :: AtomFunctions
nonEmptyListAtomFunctions = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [
Function {
funcName :: DataConstructorName
funcName = DataConstructorName
"nonEmptyListLength",
funcType :: [AtomType]
funcType = [AtomType -> AtomType
nonEmptyListAtomType (DataConstructorName -> AtomType
TypeVariableType DataConstructorName
"a"), AtomType
IntAtomType],
funcBody :: FunctionBody ([Atom] -> Either AtomFunctionError Atom)
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody forall a b. (a -> b) -> a -> b
$
\case
(Atom
nonEmptyListAtom:[Atom]
_) ->
Int -> Atom
IntAtom forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> Either AtomFunctionError Int
nonEmptyListLength Atom
nonEmptyListAtom
[Atom]
_ -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
},
Function {
funcName :: DataConstructorName
funcName = DataConstructorName
"nonEmptyListHead",
funcType :: [AtomType]
funcType = [AtomType -> AtomType
nonEmptyListAtomType (DataConstructorName -> AtomType
TypeVariableType DataConstructorName
"a"), DataConstructorName -> AtomType
TypeVariableType DataConstructorName
"a"],
funcBody :: FunctionBody ([Atom] -> Either AtomFunctionError Atom)
funcBody = forall a. a -> FunctionBody a
FunctionBuiltInBody forall a b. (a -> b) -> a -> b
$
\case
(Atom
nonEmptyListAtom:[Atom]
_) -> Atom -> Either AtomFunctionError Atom
nonEmptyListHead Atom
nonEmptyListAtom
[Atom]
_ -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
}
]