-- | Generation of type-level AST fragments for refactorings.
  The bindings defined here create a the annotated version of the AST constructor with the same name .
  For example , @mkTyForall@ creates the annotated version of the @TyForall@ AST constructor .
# LANGUAGE MonoLocalBinds #
{-# LANGUAGE OverloadedStrings #-}

module Language.Haskell.Tools.Rewrite.Create.Types where

import Data.String (IsString(..), String)
import Language.Haskell.Tools.AST
import Language.Haskell.Tools.PrettyPrint.Prepare
import Language.Haskell.Tools.Rewrite.Create.Kinds (mkKindConstraint)
import Language.Haskell.Tools.Rewrite.Create.Names (mkUnqualName')
import Language.Haskell.Tools.Rewrite.Create.Utils
import Language.Haskell.Tools.Rewrite.ElementTypes
import qualified Name as GHC (Name)

-- * Generation of types

-- | Forall types (@ forall x y . type @)
mkForallType :: [TyVar] -> Type -> Type
mkForallType vars t = mkAnn ("forall " <> child <> " . " <> child) (UTyForall (mkAnnList (separatedBy " " list) vars) t)

-- | Simplified creation of type variables
mkTypeVar' :: GHC.Name -> TyVar
mkTypeVar' = mkTypeVar . mkUnqualName'

-- | Type with a context (@ forall x y . type @)
mkCtxType :: Context -> Type -> Type
mkCtxType ctx t = mkAnn (child <> " " <> child) (UTyCtx ctx t)

-- | Function types (@ a -> b @)
mkFunctionType :: Type -> Type -> Type
mkFunctionType at rt = mkAnn (child <> " -> " <> child) (UTyFun at rt)

-- | Tuple types (@ (a,b) @)
mkTupleType :: [Type] -> Type
mkTupleType args = mkAnn ("(" <> child <> ")") (UTyTuple (mkAnnList (separatedBy ", " list) args))

-- | Unboxed tuple types (@ (\#a,b\#) @)
mkUnboxedTupleType :: [Type] -> Type
mkUnboxedTupleType args = mkAnn ("(#" <> child <> "#)") (UTyUnbTuple (mkAnnList (separatedBy ", " list) args))

-- | List type with special syntax (@ [a] @)
mkListType :: Type -> Type
mkListType = mkAnn ("[" <> child <> "]") . UTyList

-- | Parallel array type (@ [:a:] @)
mkParArrayType :: Type -> Type
mkParArrayType = mkAnn ("[:" <> child <> ":]") . UTyParArray

-- | Type application (@ F a @)
mkTypeApp :: Type -> Type -> Type
mkTypeApp ft at = mkAnn (child <> " " <> child) (UTyApp ft at)

-- | Infix type constructor (@ (a <: b) @)
mkInfixTypeApp :: Type -> Operator -> Type -> Type
mkInfixTypeApp left op right = mkAnn (child <> " " <> child <> " " <> child) (UTyInfix left op right)

-- | Type surrounded by parentheses (@ (T a) @)
mkParenType :: Type -> Type
mkParenType = mkAnn ("(" <> child <> ")") . UTyParen

-- | Creates a simple type variable
mkTypeVar :: Name -> TyVar
mkTypeVar n = mkAnn (child <> child) (UTyVarDecl n noth)

-- | Creates a type variable with kind specification (@ t :: * @)
mkKindedTypeVar :: Name -> Kind -> TyVar
mkKindedTypeVar n k = mkAnn (child <> child) (UTyVarDecl n (justVal (mkKindConstraint k)))

-- | Type variable or constructor (@ a @)
mkVarType :: Name -> Type
mkVarType = wrapperAnn . UTyVar

-- | Type with explicit kind signature (@ a :: * @)
mkKindedType :: Type -> Kind -> Type
mkKindedType t k = mkAnn (child <> " :: " <> child) (UTyKinded t k)

  | Strict type marked with @!@.
mkBangType :: Type -> Type
mkBangType = mkAnn ("!" <> child) . UTyBang

  | Lazy type marked with @~@. ( Should only be used if @Strict@ or @StrictData@ language extension is used )
mkLazyType :: Type -> Type
mkLazyType = mkAnn ("~" <> child) . UTyLazy

  | Strict type marked with UNPACK pragma . ( Usually contains the bang mark . )
mkUnpackType :: Type -> Type
mkUnpackType = mkAnn ("{-# UNPACK #-} " <> child) . UTyUnpack

  | Strict type marked with UNPACK pragma . ( Usually contains the bang mark . )
mkNoUnpackType :: Type -> Type
mkNoUnpackType = mkAnn ("{-# NOUNPACK #-} " <> child) . UTyNoUnpack

  | A wildcard type ( @ _ @ ) with @-XPartialTypeSignatures@
mkWildcardType :: Type
mkWildcardType = mkAnn "_" UTyWildcard

  | A named wildcard type ( @ _ t @ ) with @-XPartialTypeSignatures@
mkNamedWildcardType :: Name -> Type
mkNamedWildcardType = mkAnn ("_" <> child) . UTyNamedWildc

-- | A Template Haskell splice type (@ $(genType) @).
mkSpliceType :: Splice -> Type
mkSpliceType = mkAnn child . UTySplice

-- | A Template Haskell quasi-quote type (@ [quoter| ... ] @).
mkQuasiQuoteType :: QuasiQuote -> Type
mkQuasiQuoteType = mkAnn child . UTyQuasiQuote


-- | Numeric value promoted to the kind level.
mkPromotedIntType :: Integer -> Type
mkPromotedIntType i = mkAnn child $ UTyPromoted $ mkAnn (fromString $ show i) (UPromotedInt i)

-- | String value promoted to the kind level.
mkPromotedStringType :: String -> Type
mkPromotedStringType i = mkAnn child $ UTyPromoted $ mkAnn (fromString $ show i) (UPromotedString i)

-- | A data constructor value promoted to the kind level.
mkPromotedConType :: Name -> Type
mkPromotedConType = mkAnn child . UTyPromoted . mkAnn child . UPromotedCon

-- | A list of elements as a kind.
mkPromotedListType :: [Type] -> Type
mkPromotedListType
  = mkAnn child . UTyPromoted . mkAnn ("[" <> child <> "]") . UPromotedList . mkAnnList (separatedBy ", " list)

-- | A tuple of elements as a kind.
mkPromotedTupleType :: [Type] -> Type
mkPromotedTupleType
  = mkAnn child . UTyPromoted . mkAnn ("(" <> child <> ")") . UPromotedTuple . mkAnnList (separatedBy ", " list)

  | Kind of the unit value @()@.
mkPromotedUnitType :: Type
mkPromotedUnitType = mkAnn child $ UTyPromoted $ mkAnn "()" UPromotedUnit

-- * Generation of contexts

-- | Creates a context of assertions (@ C a => ... @)
mkContext :: Assertion -> Context
mkContext = mkAnn (child <> " =>") . UContext

-- * Generation of assertions

  | Class assertion ( @Cls  )
mkClassAssert :: Name -> [Type] -> Assertion
-- fixme: class assertion without parameters should not have the last space
mkClassAssert n args = mkAnn (child <> " " <> child) $ UClassAssert n (mkAnnList (separatedBy " " list) args)

-- | Infix class assertion, also contains type equations (@ a ~ X y @)
mkInfixAssert :: Type -> Operator -> Type -> Assertion
mkInfixAssert left op right = mkAnn (child <> " " <> child <> " " <> child) $ UInfixAssert left op right

  | Creates an assertion for implicit parameter binding ( @ ?  : : a - > a - > Bool @ )
mkImplicitAssert :: Name -> Type -> Assertion
mkImplicitAssert n t = mkAnn (child <> " :: " <> child) $ UImplicitAssert n t

  | Creates a list of assertions ( @ ( Eq a , Show a ) @ )
mkTupleAssertion :: [Assertion] -> Assertion
mkTupleAssertion ass = mkAnn ("(" <> child <> ")") $ UTupleAssert $ mkAnnList (separatedBy ", " list) ass

 | Generation of type-level AST fragments for refactorings.
# LANGUAGE OverloadedStrings #
 * Generation of types
 | Forall types (@ forall x y . type @)
 | Simplified creation of type variables
 | Type with a context (@ forall x y . type @)
 | Function types (@ a -> b @)
 | Tuple types (@ (a,b) @)
 | Unboxed tuple types (@ (\#a,b\#) @)
 | List type with special syntax (@ [a] @)
 | Parallel array type (@ [:a:] @)
 | Type application (@ F a @)
 | Infix type constructor (@ (a <: b) @)
 | Type surrounded by parentheses (@ (T a) @)
 | Creates a simple type variable
 | Creates a type variable with kind specification (@ t :: * @)
 | Type variable or constructor (@ a @)
 | Type with explicit kind signature (@ a :: * @)
 | A Template Haskell splice type (@ $(genType) @).
 | A Template Haskell quasi-quote type (@ [quoter| ... ] @).
 | Numeric value promoted to the kind level.
 | String value promoted to the kind level.
 | A data constructor value promoted to the kind level.
 | A list of elements as a kind.
 | A tuple of elements as a kind.
 * Generation of contexts
 | Creates a context of assertions (@ C a => ... @)
 * Generation of assertions
 fixme: class assertion without parameters should not have the last space
 | Infix class assertion, also contains type equations (@ a ~ X y @)
  The bindings defined here create a the annotated version of the AST constructor with the same name .
  For example , @mkTyForall@ creates the annotated version of the @TyForall@ AST constructor .
# LANGUAGE MonoLocalBinds #

module Language.Haskell.Tools.Rewrite.Create.Types where

import Data.String (IsString(..), String)
import Language.Haskell.Tools.AST
import Language.Haskell.Tools.PrettyPrint.Prepare
import Language.Haskell.Tools.Rewrite.Create.Kinds (mkKindConstraint)
import Language.Haskell.Tools.Rewrite.Create.Names (mkUnqualName')
import Language.Haskell.Tools.Rewrite.Create.Utils
import Language.Haskell.Tools.Rewrite.ElementTypes
import qualified Name as GHC (Name)


mkForallType :: [TyVar] -> Type -> Type
mkForallType vars t = mkAnn ("forall " <> child <> " . " <> child) (UTyForall (mkAnnList (separatedBy " " list) vars) t)

mkTypeVar' :: GHC.Name -> TyVar
mkTypeVar' = mkTypeVar . mkUnqualName'

mkCtxType :: Context -> Type -> Type
mkCtxType ctx t = mkAnn (child <> " " <> child) (UTyCtx ctx t)

mkFunctionType :: Type -> Type -> Type
mkFunctionType at rt = mkAnn (child <> " -> " <> child) (UTyFun at rt)

mkTupleType :: [Type] -> Type
mkTupleType args = mkAnn ("(" <> child <> ")") (UTyTuple (mkAnnList (separatedBy ", " list) args))

mkUnboxedTupleType :: [Type] -> Type
mkUnboxedTupleType args = mkAnn ("(#" <> child <> "#)") (UTyUnbTuple (mkAnnList (separatedBy ", " list) args))

mkListType :: Type -> Type
mkListType = mkAnn ("[" <> child <> "]") . UTyList

mkParArrayType :: Type -> Type
mkParArrayType = mkAnn ("[:" <> child <> ":]") . UTyParArray

mkTypeApp :: Type -> Type -> Type
mkTypeApp ft at = mkAnn (child <> " " <> child) (UTyApp ft at)

mkInfixTypeApp :: Type -> Operator -> Type -> Type
mkInfixTypeApp left op right = mkAnn (child <> " " <> child <> " " <> child) (UTyInfix left op right)

mkParenType :: Type -> Type
mkParenType = mkAnn ("(" <> child <> ")") . UTyParen

mkTypeVar :: Name -> TyVar
mkTypeVar n = mkAnn (child <> child) (UTyVarDecl n noth)

mkKindedTypeVar :: Name -> Kind -> TyVar
mkKindedTypeVar n k = mkAnn (child <> child) (UTyVarDecl n (justVal (mkKindConstraint k)))

mkVarType :: Name -> Type
mkVarType = wrapperAnn . UTyVar

mkKindedType :: Type -> Kind -> Type
mkKindedType t k = mkAnn (child <> " :: " <> child) (UTyKinded t k)

  | Strict type marked with @!@.
mkBangType :: Type -> Type
mkBangType = mkAnn ("!" <> child) . UTyBang

  | Lazy type marked with @~@. ( Should only be used if @Strict@ or @StrictData@ language extension is used )
mkLazyType :: Type -> Type
mkLazyType = mkAnn ("~" <> child) . UTyLazy

  | Strict type marked with UNPACK pragma . ( Usually contains the bang mark . )
mkUnpackType :: Type -> Type
mkUnpackType = mkAnn ("{-# UNPACK #-} " <> child) . UTyUnpack

  | Strict type marked with UNPACK pragma . ( Usually contains the bang mark . )
mkNoUnpackType :: Type -> Type
mkNoUnpackType = mkAnn ("{-# NOUNPACK #-} " <> child) . UTyNoUnpack

  | A wildcard type ( @ _ @ ) with @-XPartialTypeSignatures@
mkWildcardType :: Type
mkWildcardType = mkAnn "_" UTyWildcard

  | A named wildcard type ( @ _ t @ ) with @-XPartialTypeSignatures@
mkNamedWildcardType :: Name -> Type
mkNamedWildcardType = mkAnn ("_" <> child) . UTyNamedWildc

mkSpliceType :: Splice -> Type
mkSpliceType = mkAnn child . UTySplice

mkQuasiQuoteType :: QuasiQuote -> Type
mkQuasiQuoteType = mkAnn child . UTyQuasiQuote


mkPromotedIntType :: Integer -> Type
mkPromotedIntType i = mkAnn child $ UTyPromoted $ mkAnn (fromString $ show i) (UPromotedInt i)

mkPromotedStringType :: String -> Type
mkPromotedStringType i = mkAnn child $ UTyPromoted $ mkAnn (fromString $ show i) (UPromotedString i)

mkPromotedConType :: Name -> Type
mkPromotedConType = mkAnn child . UTyPromoted . mkAnn child . UPromotedCon

mkPromotedListType :: [Type] -> Type
mkPromotedListType
  = mkAnn child . UTyPromoted . mkAnn ("[" <> child <> "]") . UPromotedList . mkAnnList (separatedBy ", " list)

mkPromotedTupleType :: [Type] -> Type
mkPromotedTupleType
  = mkAnn child . UTyPromoted . mkAnn ("(" <> child <> ")") . UPromotedTuple . mkAnnList (separatedBy ", " list)

  | Kind of the unit value @()@.
mkPromotedUnitType :: Type
mkPromotedUnitType = mkAnn child $ UTyPromoted $ mkAnn "()" UPromotedUnit


mkContext :: Assertion -> Context
mkContext = mkAnn (child <> " =>") . UContext


  | Class assertion ( @Cls  )
mkClassAssert :: Name -> [Type] -> Assertion
mkClassAssert n args = mkAnn (child <> " " <> child) $ UClassAssert n (mkAnnList (separatedBy " " list) args)

mkInfixAssert :: Type -> Operator -> Type -> Assertion
mkInfixAssert left op right = mkAnn (child <> " " <> child <> " " <> child) $ UInfixAssert left op right

  | Creates an assertion for implicit parameter binding ( @ ?  : : a - > a - > Bool @ )
mkImplicitAssert :: Name -> Type -> Assertion
mkImplicitAssert n t = mkAnn (child <> " :: " <> child) $ UImplicitAssert n t

  | Creates a list of assertions ( @ ( Eq a , Show a ) @ )
mkTupleAssertion :: [Assertion] -> Assertion
mkTupleAssertion ass = mkAnn ("(" <> child <> ")") $ UTupleAssert $ mkAnnList (separatedBy ", " list) ass
