module Language.Haskell.Tools.Refactor.Predefined.GenerateTypeSignature (generateTypeSignature, generateTypeSignature', GenerateSignatureDomain) where
import GHC hiding (Module)
import Type as GHC
import TyCon as GHC
import OccName as GHC
import Outputable as GHC
import TysWiredIn as GHC
import Id as GHC
import Data.List
import Data.Maybe
import Data.Data
import Data.Generics.Uniplate.Data
import Control.Monad
import Control.Monad.State
import Control.Reference hiding (element)
import Language.Haskell.Tools.Refactor as AST
type GenerateSignatureDomain dom = ( HasModuleInfo dom, HasIdInfo dom, HasImportInfo dom )
generateTypeSignature' :: GenerateSignatureDomain dom => RealSrcSpan -> LocalRefactoring dom
generateTypeSignature' sp = generateTypeSignature (nodesContaining sp) (nodesContaining sp) (getValBindInList sp)
generateTypeSignature :: GenerateSignatureDomain dom => Simple Traversal (Module dom) (DeclList dom)
-> Simple Traversal (Module dom) (LocalBindList dom)
-> (forall d . (BindingElem d) => AnnList d dom -> Maybe (ValueBind dom))
-> LocalRefactoring dom
generateTypeSignature topLevelRef localRef vbAccess
= flip evalStateT False .
(topLevelRef !~ genTypeSig vbAccess
<=< localRef !~ genTypeSig vbAccess)
genTypeSig :: (GenerateSignatureDomain dom, BindingElem d) => (AnnList d dom -> Maybe (ValueBind dom))
-> AnnList d dom -> StateT Bool (LocalRefactor dom) (AnnList d dom)
genTypeSig vbAccess ls
| Just vb <- vbAccess ls
, not (typeSignatureAlreadyExist ls vb)
= do let id = getBindingName vb
isTheBind (Just decl)
= isBinding decl && map semanticsId (decl ^? elementName) == map semanticsId (vb ^? bindingName)
isTheBind _ = False
alreadyGenerated <- get
if alreadyGenerated
then return ls
else do put True
typeSig <- lift $ generateTSFor (getName id) (idType id)
return $ insertWhere (createTypeSig typeSig) (const True) isTheBind ls
| otherwise = return ls
generateTSFor :: GenerateSignatureDomain dom => GHC.Name -> GHC.Type -> LocalRefactor dom (TypeSignature dom)
generateTSFor n t = mkTypeSignature (mkUnqualName' n) <$> generateTypeFor (1) (dropForAlls t)
generateTypeFor :: GenerateSignatureDomain dom => Int -> GHC.Type -> LocalRefactor dom (AST.Type dom)
generateTypeFor prec t
| (break (not . isPredTy) -> (preds, other), rt) <- splitFunTys t
, not (null preds)
= do ctx <- case preds of [pred] -> mkContextOne <$> generateAssertionFor pred
_ -> mkContextMulti <$> mapM generateAssertionFor preds
wrapParen 0 <$> (mkCtxType ctx <$> generateTypeFor 0 (mkFunTys other rt))
| Just (at, rt) <- splitFunTy_maybe t
= wrapParen 0 <$> (mkFunctionType <$> generateTypeFor 10 at <*> generateTypeFor 0 rt)
| (op, [at,rt]) <- splitAppTys t
, Just tc <- tyConAppTyCon_maybe op
, isSymOcc (getOccName (getName tc))
= wrapParen 0 <$> (mkInfixTypeApp <$> generateTypeFor 10 at <*> referenceOperator (idName $ getTCId tc) <*> generateTypeFor 10 rt)
| Just (tc, tas) <- splitTyConApp_maybe t
, isTupleTyCon tc
= mkTupleType <$> mapM (generateTypeFor (1)) tas
| Just (ls, [et]) <- splitTyConApp_maybe t
, Just ch <- tyConAppTyCon_maybe et
, listTyCon == ls
, charTyCon == ch
= return $ mkVarType (mkNormalName $ mkSimpleName "String")
| Just (tc, [et]) <- splitTyConApp_maybe t
, listTyCon == tc
= mkListType <$> generateTypeFor (1) et
| Just (tf, ta) <- splitAppTy_maybe t
= wrapParen 10 <$> (mkTypeApp <$> generateTypeFor 10 tf <*> generateTypeFor 11 ta)
| Just tc <- tyConAppTyCon_maybe t
= mkVarType <$> referenceName (idName $ getTCId tc)
| Just tv <- getTyVar_maybe t
= mkVarType <$> referenceName (idName tv)
| (tvs@(_:_), t') <- splitForAllTys t
= wrapParen (1) <$> (mkForallType (map (mkTypeVar' . getName) tvs) <$> generateTypeFor 0 t')
| otherwise = error ("Cannot represent type: " ++ showSDocUnsafe (ppr t))
where wrapParen :: Int -> AST.Type dom -> AST.Type dom
wrapParen prec' node = if prec' < prec then mkParenType node else node
getTCId :: GHC.TyCon -> GHC.Id
getTCId tc = GHC.mkVanillaGlobal (GHC.tyConName tc) (tyConKind tc)
generateAssertionFor :: GenerateSignatureDomain dom => GHC.Type -> LocalRefactor dom (Assertion dom)
generateAssertionFor t
| Just (tc, types) <- splitTyConApp_maybe t
= mkClassAssert <$> referenceName (idName $ getTCId tc) <*> mapM (generateTypeFor 0) types
typeSignatureAlreadyExist :: (GenerateSignatureDomain dom, BindingElem d) => AnnList d dom -> ValueBind dom -> Bool
typeSignatureAlreadyExist ls vb =
getBindingName vb `elem` (map semanticsId $ concatMap (^? elementName) (filter isTypeSig $ ls ^? annList))
getBindingName :: GenerateSignatureDomain dom => ValueBind dom -> GHC.Id
getBindingName vb = case nub $ map semanticsId $ vb ^? bindingName of
[n] -> n
[] -> error "Trying to generate a signature for a binding with no name"
_ -> error "Trying to generate a signature for a binding with multiple names"