module SyntaxTrees.Purescript.Type where

import Data.List                     (intercalate)
import SyntaxTrees.Purescript.Common (Module, QClass, showQualified)
import Utils.String                  (str, wrapParens, wrapParensCsv,
                                      wrapSpaces, (+++))


newtype TypeParam
  = TypeParam String
  deriving (TypeParam -> TypeParam -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeParam -> TypeParam -> Bool
$c/= :: TypeParam -> TypeParam -> Bool
== :: TypeParam -> TypeParam -> Bool
$c== :: TypeParam -> TypeParam -> Bool
Eq, Eq TypeParam
TypeParam -> TypeParam -> Bool
TypeParam -> TypeParam -> Ordering
TypeParam -> TypeParam -> TypeParam
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TypeParam -> TypeParam -> TypeParam
$cmin :: TypeParam -> TypeParam -> TypeParam
max :: TypeParam -> TypeParam -> TypeParam
$cmax :: TypeParam -> TypeParam -> TypeParam
>= :: TypeParam -> TypeParam -> Bool
$c>= :: TypeParam -> TypeParam -> Bool
> :: TypeParam -> TypeParam -> Bool
$c> :: TypeParam -> TypeParam -> Bool
<= :: TypeParam -> TypeParam -> Bool
$c<= :: TypeParam -> TypeParam -> Bool
< :: TypeParam -> TypeParam -> Bool
$c< :: TypeParam -> TypeParam -> Bool
compare :: TypeParam -> TypeParam -> Ordering
$ccompare :: TypeParam -> TypeParam -> Ordering
Ord)

newtype TypeVar
  = TypeVar String

data TypeCtor
  = TypeCtor String
  | Arrow
  | TupleType

data AnyKindedType
  = TypeValue Type
  | TypeFn QTypeCtor

data ClassConstraint
  = ClassConstraint QClass [Type]

data Type
  = CtorTypeApply QTypeCtor [Type]
  | ParamTypeApply TypeParam [Type]
  | NestedTypeApply Type [Type]
  | TypeVar' QTypeVar
  | TypeParam' TypeParam
  | TypeScope [TypeParam] Type
  | ClassScope [ClassConstraint] Type


data QTypeVar
  = QTypeVar (Maybe Module) TypeVar

data QTypeCtor
  = QTypeCtor (Maybe Module) TypeCtor



instance Show TypeParam where
  show :: TypeParam -> String
show (TypeParam String
x) = String
x

instance Show TypeVar where
  show :: TypeVar -> String
show (TypeVar String
x) = String
x

instance Show TypeCtor where
  show :: TypeCtor -> String
show (TypeCtor String
x) = String
x
  show TypeCtor
Arrow        = String
"->"
  show TypeCtor
TupleType    = String
"()"

instance Show AnyKindedType where
  show :: AnyKindedType -> String
show (TypeValue Type
x) = forall a. Show a => a -> String
show Type
x
  show (TypeFn QTypeCtor
x)    = forall a. Show a => a -> String
show QTypeCtor
x

instance Show Type where
  show :: Type -> String
show (CtorTypeApply (QTypeCtor Maybe Module
_ TypeCtor
Arrow) [Type]
x)        = forall a. [a] -> [[a]] -> [a]
intercalate (String -> String
wrapSpaces String
"->")
    (Type -> String
showArrowTypeNested forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
x)
  show (CtorTypeApply x :: QTypeCtor
x@(QTypeCtor Maybe Module
_ (TypeCtor String
_)) [Type]
y) = forall a. Show a => a -> String
show QTypeCtor
x String -> String -> String
+++
    (forall a. [a] -> [[a]] -> [a]
intercalate String
" " forall a b. (a -> b) -> a -> b
$ Type -> String
showTypeNested forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
y)
  show (CtorTypeApply (QTypeCtor Maybe Module
_ TypeCtor
TupleType) [Type]
x)    = forall a. Show a => String -> [a] -> String
str (String -> String
wrapSpaces String
"/\\") [Type]
x
  show (ParamTypeApply TypeParam
x [Type]
y) = forall a. Show a => a -> String
show TypeParam
x  String -> String -> String
+++ (forall a. [a] -> [[a]] -> [a]
intercalate String
" " forall a b. (a -> b) -> a -> b
$ Type -> String
showTypeNested forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
y)
  show (NestedTypeApply Type
x [Type]
y) = forall a. Show a => a -> String
show Type
x String -> String -> String
+++ (forall a. [a] -> [[a]] -> [a]
intercalate String
" " forall a b. (a -> b) -> a -> b
$ Type -> String
showTypeNested forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Type]
y)
  show (TypeVar' QTypeVar
x) = forall a. Show a => a -> String
show QTypeVar
x
  show (TypeParam' TypeParam
x) = forall a. Show a => a -> String
show TypeParam
x
  show (TypeScope [TypeParam]
x Type
y) = String
"forall" String -> String -> String
+++ forall a. Show a => String -> [a] -> String
str String
" " [TypeParam]
x forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
+++ Type -> String
showTypeScopeNested Type
y
  show (ClassScope [ClassConstraint]
x Type
y) = forall a. Show a => String -> [a] -> String
str (String -> String
wrapSpaces String
",") [ClassConstraint]
x String -> String -> String
+++ String
"=>" String -> String -> String
+++ Type -> String
showClassScopeNested Type
y

instance Show ClassConstraint where
  show :: ClassConstraint -> String
show (ClassConstraint QClass
x [Type
y]) = forall a. Show a => a -> String
show QClass
x String -> String -> String
+++ forall a. Show a => a -> String
show Type
y
  show (ClassConstraint QClass
x [Type]
y)   = forall a. Show a => a -> String
show QClass
x String -> String -> String
+++ forall a. Show a => [a] -> String
wrapParensCsv [Type]
y

instance Show QTypeVar where
  show :: QTypeVar -> String
show (QTypeVar Maybe Module
x TypeVar
y) = forall a b. (Show a, Show b) => Maybe a -> b -> String
showQualified Maybe Module
x TypeVar
y

instance Show QTypeCtor where
  show :: QTypeCtor -> String
show (QTypeCtor Maybe Module
x TypeCtor
y) = forall a b. (Show a, Show b) => Maybe a -> b -> String
showQualified Maybe Module
x TypeCtor
y


showAnyKindedTypeNested :: AnyKindedType -> String
showAnyKindedTypeNested :: AnyKindedType -> String
showAnyKindedTypeNested (TypeValue Type
x) = Type -> String
showTypeNested Type
x
showAnyKindedTypeNested (TypeFn QTypeCtor
x)    = forall a. Show a => a -> String
show QTypeCtor
x

showTypeNested :: Type -> String
showTypeNested :: Type -> String
showTypeNested Type
x = String -> String
transformFn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Type
x
  where
    transformFn :: String -> String
transformFn = if Bool
shouldWrap then String -> String
wrapParens else forall a. a -> a
id
    shouldWrap :: Bool
shouldWrap = case Type
x of
      CtorTypeApply (QTypeCtor Maybe Module
_ (TypeCtor String
_)) [Type]
_ -> Bool
True
      CtorTypeApply (QTypeCtor Maybe Module
_ TypeCtor
Arrow) [Type]
_        -> Bool
True
      CtorTypeApply (QTypeCtor Maybe Module
_ TypeCtor
TupleType) [Type]
_    -> Bool
True
      ParamTypeApply TypeParam
_ [Type]
_                         -> Bool
True
      NestedTypeApply Type
_ [Type]
_                        -> Bool
True
      TypeScope [TypeParam]
_ Type
_                              -> Bool
True
      ClassScope [ClassConstraint]
_ Type
_                             -> Bool
True
      Type
_                                          -> Bool
False

showArrowTypeNested :: Type -> String
showArrowTypeNested :: Type -> String
showArrowTypeNested Type
x = String -> String
transformFn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Type
x
  where
    transformFn :: String -> String
transformFn = if Bool
shouldWrap then String -> String
wrapParens else forall a. a -> a
id
    shouldWrap :: Bool
shouldWrap = case Type
x of
      CtorTypeApply (QTypeCtor Maybe Module
_ TypeCtor
Arrow) [Type]
_ -> Bool
True
      TypeScope [TypeParam]
_ Type
_                       -> Bool
True
      ClassScope [ClassConstraint]
_ Type
_                      -> Bool
True
      Type
_                                   -> Bool
False

showTypeScopeNested :: Type -> String
showTypeScopeNested :: Type -> String
showTypeScopeNested Type
x = String -> String
transformFn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Type
x
  where
    transformFn :: String -> String
transformFn = if Bool
shouldWrap then String -> String
wrapParens else forall a. a -> a
id
    shouldWrap :: Bool
shouldWrap = case Type
x of
      TypeScope [TypeParam]
_ Type
_ -> Bool
True
      Type
_             -> Bool
False

showClassScopeNested :: Type -> String
showClassScopeNested :: Type -> String
showClassScopeNested Type
x = String -> String
transformFn forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Type
x
  where
    transformFn :: String -> String
transformFn = if Bool
shouldWrap then String -> String
wrapParens else forall a. a -> a
id
    shouldWrap :: Bool
shouldWrap = case Type
x of
      TypeScope [TypeParam]
_ Type
_  -> Bool
True
      ClassScope [ClassConstraint]
_ Type
_ -> Bool
True
      Type
_              -> Bool
False