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 = TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType TypeConstructorName
"NonEmptyList" (TypeConstructorName -> AtomType -> TypeVarMap
forall k a. k -> a -> Map k a
M.singleton TypeConstructorName
"a" AtomType
arg)

-- data NonEmptyList = NECons a (Cons a)
nonEmptyListTypeConstructorMapping :: TypeConstructorMapping
nonEmptyListTypeConstructorMapping :: TypeConstructorMapping
nonEmptyListTypeConstructorMapping = [(TypeConstructorName -> [TypeConstructorName] -> TypeConstructorDef
ADTypeConstructorDef TypeConstructorName
"NonEmptyList" [TypeConstructorName
"a"],
                           [TypeConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef TypeConstructorName
"NECons" [TypeConstructorName -> DataConstructorDefArg
DataConstructorDefTypeVarNameArg TypeConstructorName
"a",
                            TypeConstructor -> DataConstructorDefArg
DataConstructorDefTypeConstructorArg (TypeConstructorName -> [TypeConstructor] -> TypeConstructor
forall a.
TypeConstructorName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor TypeConstructorName
"List" [TypeConstructorName -> TypeConstructor
forall a. TypeConstructorName -> TypeConstructorBase a
TypeVariable TypeConstructorName
"a"])]])]
                         
nonEmptyListLength :: Atom -> Either AtomFunctionError Int                         
nonEmptyListLength :: Atom -> Either AtomFunctionError Int
nonEmptyListLength (ConstructedAtom TypeConstructorName
"NECons" AtomType
_ (Atom
_:Atom
nextCons:[Atom]
_)) = do
  Int
c <- Atom -> Either AtomFunctionError Int
listLength Atom
nextCons
  Int -> Either AtomFunctionError Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
nonEmptyListLength (ConstructedAtom TypeConstructorName
"NECons" AtomType
_ [Atom]
_) = Int -> Either AtomFunctionError Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
nonEmptyListLength Atom
_ = AtomFunctionError -> Either AtomFunctionError Int
forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError

nonEmptyListHead :: Atom -> Either AtomFunctionError Atom
nonEmptyListHead :: Atom -> Either AtomFunctionError Atom
nonEmptyListHead (ConstructedAtom TypeConstructorName
"NECons" AtomType
_ (Atom
val:[Atom]
_)) = Atom -> Either AtomFunctionError Atom
forall (f :: * -> *) a. Applicative f => a -> f a
pure Atom
val
nonEmptyListHead Atom
_ = AtomFunctionError -> Either AtomFunctionError Atom
forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError

{-
listMaybeHead :: Atom -> Either AtomFunctionError Atom
listMaybeHead (ConstructedAtom "Cons" _ (val:_)) = pure (ConstructedAtom "Just" aType [val])
  where
    aType = maybeAtomType (atomTypeForAtom val)
listMaybeHead (ConstructedAtom "Empty" (ConstructedAtomType _ tvMap) _) =
  case M.lookup "a" tvMap of
    Nothing -> Left AtomFunctionTypeMismatchError
    Just aType -> pure (ConstructedAtom "Nothing" aType [])
listMaybeHead _ = Left AtomFunctionTypeMismatchError
-}

nonEmptyListAtomFunctions :: AtomFunctions
nonEmptyListAtomFunctions :: AtomFunctions
nonEmptyListAtomFunctions = [Function ([Atom] -> Either AtomFunctionError Atom)]
-> AtomFunctions
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [
  Function :: forall a.
TypeConstructorName -> [AtomType] -> FunctionBody a -> Function a
Function {
     funcName :: TypeConstructorName
funcName = TypeConstructorName
"nonEmptyListLength",
     funcType :: [AtomType]
funcType = [AtomType -> AtomType
nonEmptyListAtomType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a"), AtomType
IntAtomType],
     funcBody :: FunctionBody ([Atom] -> Either AtomFunctionError Atom)
funcBody = ([Atom] -> Either AtomFunctionError Atom)
-> FunctionBody ([Atom] -> Either AtomFunctionError Atom)
forall a. a -> FunctionBody a
FunctionBuiltInBody (([Atom] -> Either AtomFunctionError Atom)
 -> FunctionBody ([Atom] -> Either AtomFunctionError Atom))
-> ([Atom] -> Either AtomFunctionError Atom)
-> FunctionBody ([Atom] -> Either AtomFunctionError Atom)
forall a b. (a -> b) -> a -> b
$
       \case
         (Atom
nonEmptyListAtom:[Atom]
_) ->
           Int -> Atom
IntAtom (Int -> Atom) -> (Int -> Int) -> Int -> Atom
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Atom)
-> Either AtomFunctionError Int -> Either AtomFunctionError Atom
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> Either AtomFunctionError Int
nonEmptyListLength Atom
nonEmptyListAtom
         [Atom]
_ -> AtomFunctionError -> Either AtomFunctionError Atom
forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
     },
  Function :: forall a.
TypeConstructorName -> [AtomType] -> FunctionBody a -> Function a
Function {
    funcName :: TypeConstructorName
funcName = TypeConstructorName
"nonEmptyListHead",
    funcType :: [AtomType]
funcType = [AtomType -> AtomType
nonEmptyListAtomType (TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a"), TypeConstructorName -> AtomType
TypeVariableType TypeConstructorName
"a"],
    funcBody :: FunctionBody ([Atom] -> Either AtomFunctionError Atom)
funcBody = ([Atom] -> Either AtomFunctionError Atom)
-> FunctionBody ([Atom] -> Either AtomFunctionError Atom)
forall a. a -> FunctionBody a
FunctionBuiltInBody (([Atom] -> Either AtomFunctionError Atom)
 -> FunctionBody ([Atom] -> Either AtomFunctionError Atom))
-> ([Atom] -> Either AtomFunctionError Atom)
-> FunctionBody ([Atom] -> Either AtomFunctionError Atom)
forall a b. (a -> b) -> a -> b
$
      \case
        (Atom
nonEmptyListAtom:[Atom]
_) -> Atom -> Either AtomFunctionError Atom
nonEmptyListHead Atom
nonEmptyListAtom
        [Atom]
_ -> AtomFunctionError -> Either AtomFunctionError Atom
forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
    }
  ]