module Conversions.ToPurescript.DataDef where

import qualified SyntaxTrees.Haskell.DataDef     as H
import qualified SyntaxTrees.Haskell.Type        as H
import qualified SyntaxTrees.Purescript.ClassDef as P
import qualified SyntaxTrees.Purescript.DataDef  as P
import qualified SyntaxTrees.Purescript.Type     as P

import Conversions.ToPurescript.Common (class', ctor, var)
import Conversions.ToPurescript.Type   (anyKindedType, type', typeCtor,
                                        typeParam)
import SyntaxTrees.Haskell.DataDef     (derivingClasses)


typeDef :: H.TypeDef -> P.TypeDef
typeDef :: TypeDef -> TypeDef
typeDef (H.TypeDef TypeCtor
x [TypeParam]
y AnyKindedType
z) =
  TypeCtor -> [TypeParam] -> AnyKindedType -> TypeDef
P.TypeDef (TypeCtor -> TypeCtor
typeCtor TypeCtor
x) (TypeParam -> TypeParam
typeParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeParam]
y) (AnyKindedType -> AnyKindedType
anyKindedType AnyKindedType
z)


newtypeDef :: H.NewTypeDef -> (P.NewTypeDef, [P.DerivingDef])
newtypeDef :: NewTypeDef -> (NewTypeDef, [DerivingDef])
newtypeDef (H.NewTypeDef TypeCtor
x [TypeParam]
y Ctor
z FieldDef
t [DerivingClause]
u) =
  (NewTypeDef
newtype', TypeCtor -> [TypeParam] -> [DerivingClause] -> [DerivingDef]
extractDerivingDefs TypeCtor
x [TypeParam]
y [DerivingClause]
u)
  where
    newtype' :: NewTypeDef
newtype' = TypeCtor -> [TypeParam] -> Ctor -> FieldDef -> NewTypeDef
P.NewTypeDef (TypeCtor -> TypeCtor
typeCtor TypeCtor
x) (TypeParam -> TypeParam
typeParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeParam]
y)
                            (Ctor -> Ctor
ctor Ctor
z) (FieldDef -> FieldDef
fieldDef FieldDef
t)


dataDef :: H.DataDef -> (P.DataDef, [P.DerivingDef])
dataDef :: DataDef -> (DataDef, [DerivingDef])
dataDef (H.DataDef TypeCtor
x [TypeParam]
y [DataCtorDef]
z [DerivingClause]
u) =
  (DataDef
data', TypeCtor -> [TypeParam] -> [DerivingClause] -> [DerivingDef]
extractDerivingDefs TypeCtor
x [TypeParam]
y [DerivingClause]
u)
  where
    data' :: DataDef
data' = TypeCtor -> [TypeParam] -> [DataCtorDef] -> DataDef
P.DataDef (TypeCtor -> TypeCtor
typeCtor  TypeCtor
x) (TypeParam -> TypeParam
typeParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeParam]
y)
                      (DataCtorDef -> DataCtorDef
dataCtorDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DataCtorDef]
z)


dataCtorDef :: H.DataCtorDef -> P.DataCtorDef
dataCtorDef :: DataCtorDef -> DataCtorDef
dataCtorDef (H.UnNamedFieldsCtor Ctor
x [UnNamedFieldDef]
y) =
  Ctor -> [UnNamedFieldDef] -> DataCtorDef
P.UnNamedFieldsCtor (Ctor -> Ctor
ctor Ctor
x) (UnNamedFieldDef -> UnNamedFieldDef
unnamedFieldDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UnNamedFieldDef]
y)
dataCtorDef (H.NamedFieldsCtor Ctor
x [NamedFieldDef]
y) =
  Ctor -> [NamedFieldDef] -> DataCtorDef
P.NamedFieldsCtor (Ctor -> Ctor
ctor Ctor
x) (NamedFieldDef -> NamedFieldDef
namedFieldDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedFieldDef]
y)


fieldDef :: H.FieldDef -> P.FieldDef
fieldDef :: FieldDef -> FieldDef
fieldDef (H.UnNamedField UnNamedFieldDef
x) = UnNamedFieldDef -> FieldDef
P.UnNamedField forall a b. (a -> b) -> a -> b
$ UnNamedFieldDef -> UnNamedFieldDef
unnamedFieldDef UnNamedFieldDef
x
fieldDef (H.NamedField NamedFieldDef
x)   = NamedFieldDef -> FieldDef
P.NamedField forall a b. (a -> b) -> a -> b
$ NamedFieldDef -> NamedFieldDef
namedFieldDef NamedFieldDef
x

unnamedFieldDef :: H.UnNamedFieldDef -> P.UnNamedFieldDef
unnamedFieldDef :: UnNamedFieldDef -> UnNamedFieldDef
unnamedFieldDef (H.UnNamedFieldDef Type
x) =
  Type -> UnNamedFieldDef
P.UnNamedFieldDef (Type -> Type
type' Type
x)

namedFieldDef :: H.NamedFieldDef -> P.NamedFieldDef
namedFieldDef :: NamedFieldDef -> NamedFieldDef
namedFieldDef (H.NamedFieldDef Var
x Type
y) =
  Var -> Type -> NamedFieldDef
P.NamedFieldDef (Var -> Var
var Var
x) (Type -> Type
type' Type
y)


extractDerivingDefs :: H.TypeCtor -> [H.TypeParam] -> [H.DerivingClause]
                    -> [P.DerivingDef]
extractDerivingDefs :: TypeCtor -> [TypeParam] -> [DerivingClause] -> [DerivingDef]
extractDerivingDefs TypeCtor
x [TypeParam]
y [DerivingClause]
z =
  (DerivingStrategy, Class) -> DerivingDef
buildDeriving forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap DerivingClause -> [(DerivingStrategy, Class)]
derivingClasses [DerivingClause]
z
  where
    buildDeriving :: (DerivingStrategy, Class) -> DerivingDef
buildDeriving (DerivingStrategy
strat , Class
cls) =
      DerivingStrategy
-> [ClassConstraint]
-> Maybe Var
-> Class
-> [AnyKindedType]
-> DerivingDef
P.DerivingDef (DerivingStrategy -> DerivingStrategy
derivingStrategy DerivingStrategy
strat) [] forall a. Maybe a
Nothing (Class -> Class
class' Class
cls) [AnyKindedType
classType]
    classType :: AnyKindedType
classType = case [TypeParam]
y of
      [] -> Type -> AnyKindedType
P.TypeValue forall a b. (a -> b) -> a -> b
$ QTypeVar -> Type
P.TypeVar' forall a b. (a -> b) -> a -> b
$ Maybe Module -> TypeVar -> QTypeVar
P.QTypeVar
             (forall a. Maybe a
Nothing) (TypeCtor -> TypeVar
typeCtorToVar forall a b. (a -> b) -> a -> b
$ TypeCtor -> TypeCtor
typeCtor TypeCtor
x)
      [TypeParam]
_ -> Type -> AnyKindedType
P.TypeValue forall a b. (a -> b) -> a -> b
$ QTypeCtor -> [Type] -> Type
P.CtorTypeApply
                (Maybe Module -> TypeCtor -> QTypeCtor
P.QTypeCtor forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ TypeCtor -> TypeCtor
typeCtor TypeCtor
x)
                ((TypeParam -> Type
P.TypeParam' forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParam -> TypeParam
typeParam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeParam]
y))

    typeCtorToVar :: TypeCtor -> TypeVar
typeCtorToVar (P.TypeCtor String
name) = String -> TypeVar
P.TypeVar String
name
    typeCtorToVar TypeCtor
_                 = String -> TypeVar
P.TypeVar forall a. Monoid a => a
mempty


derivingStrategy :: H.DerivingStrategy -> P.DerivingStrategy
derivingStrategy :: DerivingStrategy -> DerivingStrategy
derivingStrategy DerivingStrategy
H.NewTypeDeriving = DerivingStrategy
P.NewTypeDeriving
derivingStrategy DerivingStrategy
_                 = DerivingStrategy
P.StandardDeriving