module ProjectM36.DataTypes.List where
import ProjectM36.Base
import ProjectM36.DataTypes.Maybe
import ProjectM36.DataTypes.Primitive
import qualified Data.Map as M
import qualified Data.HashSet as HS
import ProjectM36.AtomFunctionError

listAtomType :: AtomType -> AtomType
listAtomType :: AtomType -> AtomType
listAtomType AtomType
arg = DataConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType DataConstructorName
"List" (forall k a. k -> a -> Map k a
M.singleton DataConstructorName
"a" AtomType
arg)

listTypeConstructorMapping :: TypeConstructorMapping
listTypeConstructorMapping :: TypeConstructorMapping
listTypeConstructorMapping = [(DataConstructorName -> [DataConstructorName] -> TypeConstructorDef
ADTypeConstructorDef DataConstructorName
"List" [DataConstructorName
"a"],
                           [DataConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef DataConstructorName
"Empty" [],
                           DataConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef DataConstructorName
"Cons" [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"])]])]
                         
listLength :: Atom -> Either AtomFunctionError Int                         
listLength :: Atom -> Either AtomFunctionError Int
listLength (ConstructedAtom DataConstructorName
"Cons" 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)
listLength (ConstructedAtom DataConstructorName
"Empty" AtomType
_ [Atom]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
listLength Atom
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError

listMaybeHead :: Atom -> Either AtomFunctionError Atom
listMaybeHead :: Atom -> Either AtomFunctionError Atom
listMaybeHead (ConstructedAtom DataConstructorName
"Cons" AtomType
_ (Atom
val:[Atom]
_)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Just" AtomType
aType [Atom
val])
  where
    aType :: AtomType
aType = AtomType -> AtomType
maybeAtomType (Atom -> AtomType
atomTypeForAtom Atom
val)
listMaybeHead (ConstructedAtom DataConstructorName
"Empty" (ConstructedAtomType DataConstructorName
_ TypeVarMap
tvMap) [Atom]
_) =
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup DataConstructorName
"a" TypeVarMap
tvMap of
    Maybe AtomType
Nothing -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
    Just AtomType
aType -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Nothing" AtomType
aType [])
listMaybeHead Atom
_ = forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError

listAtomFunctions :: AtomFunctions
listAtomFunctions :: AtomFunctions
listAtomFunctions = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [
  Function {
     funcName :: DataConstructorName
funcName = DataConstructorName
"length",
     funcType :: [AtomType]
funcType = [AtomType -> AtomType
listAtomType (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
listAtom:[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
listLength Atom
listAtom
               [Atom]
_ -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
     },
  Function {
    funcName :: DataConstructorName
funcName = DataConstructorName
"maybeHead",
    funcType :: [AtomType]
funcType = [AtomType -> AtomType
listAtomType (DataConstructorName -> AtomType
TypeVariableType DataConstructorName
"a"), AtomType -> AtomType
maybeAtomType (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
listAtom:[Atom]
_) -> Atom -> Either AtomFunctionError Atom
listMaybeHead Atom
listAtom
                 [Atom]
_ -> forall a b. a -> Either a b
Left AtomFunctionError
AtomFunctionTypeMismatchError
    }
  ]
                    
--just a private utility function
listCons :: AtomType -> [Atom] -> Atom
listCons :: AtomType -> [Atom] -> Atom
listCons AtomType
typ [] = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Empty" (AtomType -> AtomType
listAtomType AtomType
typ) []
listCons AtomType
typ (Atom
a:[Atom]
as) = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Cons" (AtomType -> AtomType
listAtomType AtomType
typ) [Atom
a, AtomType -> [Atom] -> Atom
listCons AtomType
typ [Atom]
as]