-- | 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 x@)

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 (@ ?cmp :: 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