module Language.Haskell.Tools.Refactor.RefactorBase where
import Language.Haskell.Tools.AST
import Language.Haskell.Tools.AST.Gen
import Language.Haskell.Tools.AnnTrf.SourceTemplateHelpers
import Language.Haskell.Tools.AnnTrf.SourceTemplate
import GHC (Ghc, GhcMonad(..), TyThing(..), lookupName)
import Exception (ExceptionMonad(..))
import DynFlags (HasDynFlags(..))
import qualified Name as GHC
import qualified Module as GHC
import qualified PrelNames as GHC
import qualified TyCon as GHC
import qualified TysWiredIn as GHC
import Control.Reference hiding (element)
import Data.Function (on)
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Char
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Writer
data RefactorCtx dom = RefactorCtx { refModuleName :: GHC.Module
, refCtxImports :: [Ann ImportDecl dom SrcTemplateStage]
}
runRefactor :: (SemanticInfo' dom SameInfoModuleCls ~ ModuleInfo n)
=> Ann Module dom SrcTemplateStage -> (Ann Module dom SrcTemplateStage -> RefactoredModule dom) -> Ghc (Either String (Ann Module dom SrcTemplateStage))
runRefactor mod trf = let init = RefactorCtx (fromJust $ mod ^? semantics&defModuleName) (mod ^? element&modImports&annList)
in runExceptT $ runReaderT (addGeneratedImports (runWriterT (fromRefactorT $ trf mod))) init
addGeneratedImports :: (Monad m) => ReaderT (RefactorCtx dom) m (Ann Module dom SrcTemplateStage, [GHC.Name]) -> ReaderT (RefactorCtx dom) m (Ann Module dom SrcTemplateStage)
addGeneratedImports =
fmap (\(m,names) -> element&modImports&annListElems .- (++ addImports names) $ m)
where addImports :: [GHC.Name] -> [Ann ImportDecl dom SrcTemplateStage]
addImports names = map createImport $ groupBy ((==) `on` GHC.nameModule) $ nub $ sort names
createImport :: [GHC.Name] -> Ann ImportDecl dom SrcTemplateStage
createImport names = mkImportDecl False False False Nothing (mkModuleName $ GHC.moduleNameString $ GHC.moduleName $ GHC.nameModule $ head names)
Nothing (Just $ mkImportSpecList (map (\n -> mkIeSpec (mkUnqualName' n) Nothing) names))
instance (GhcMonad m, Monoid s) => GhcMonad (WriterT s m) where
getSession = lift getSession
setSession env = lift (setSession env)
instance (ExceptionMonad m, Monoid s) => ExceptionMonad (WriterT s m) where
gcatch w c = WriterT (runWriterT w `gcatch` (runWriterT . c))
gmask m = WriterT $ gmask (\f -> runWriterT $ m (WriterT . f . runWriterT))
instance GhcMonad m => GhcMonad (ReaderT s m) where
getSession = lift getSession
setSession env = lift (setSession env)
instance ExceptionMonad m => ExceptionMonad (ReaderT s m) where
gcatch r c = ReaderT (\ctx -> runReaderT r ctx `gcatch` (flip runReaderT ctx . c))
gmask m = ReaderT $ \ctx -> gmask (\f -> runReaderT (m (\a -> ReaderT $ \ctx' -> f (runReaderT a ctx'))) ctx)
instance GhcMonad m => GhcMonad (ExceptT s m) where
getSession = lift getSession
setSession env = lift (setSession env)
instance ExceptionMonad m => ExceptionMonad (ExceptT s m) where
gcatch e c = ExceptT (runExceptT e `gcatch` (runExceptT . c))
gmask m = ExceptT $ gmask (\f -> runExceptT $ m (ExceptT . f . runExceptT))
newtype RefactorT dom m a = RefactorT { fromRefactorT :: WriterT [GHC.Name] (ReaderT (RefactorCtx dom) m) a }
deriving (Functor, Applicative, Monad, MonadReader (RefactorCtx dom), MonadWriter [GHC.Name], MonadIO, HasDynFlags, ExceptionMonad, GhcMonad)
instance MonadTrans (RefactorT dom) where
lift = RefactorT . lift . lift
refactError :: String -> Refactor n a
refactError = lift . throwE
type Refactor dom = RefactorT dom (ExceptT String Ghc)
type RefactoredModule dom = Refactor dom (Ann Module dom SrcTemplateStage)
registeredNamesFromPrelude :: [GHC.Name]
registeredNamesFromPrelude = GHC.basicKnownKeyNames ++ map GHC.tyConName GHC.wiredInTyCons
otherNamesFromPrelude :: [String]
otherNamesFromPrelude
= ["GHC.Base.Maybe", "GHC.Base.Just", "GHC.Base.Nothing", "GHC.Base.maybe", "GHC.Base.either", "GHC.Base.not"
, "Data.Tuple.curry", "Data.Tuple.uncurry", "GHC.Base.compare", "GHC.Base.max", "GHC.Base.min", "GHC.Base.id"]
qualifiedName :: GHC.Name -> String
qualifiedName name = case GHC.nameModule_maybe name of
Just mod -> GHC.moduleNameString (GHC.moduleName mod) ++ "." ++ GHC.occNameString (GHC.nameOccName name)
Nothing -> GHC.occNameString (GHC.nameOccName name)
referenceName :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, GHC.NamedThing n)
=> n -> Refactor dom (Ann Name dom SrcTemplateStage)
referenceName = referenceName' mkQualName'
referenceOperator :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, GHC.NamedThing n)
=> n -> Refactor dom (Ann Operator dom SrcTemplateStage)
referenceOperator = referenceName' mkQualOp'
referenceName' :: (SemanticInfo' dom SameInfoImportCls ~ ImportInfo n, Eq n, GHC.NamedThing n)
=> ([String] -> GHC.Name -> Ann nt dom SrcTemplateStage) -> n -> Refactor dom (Ann nt dom SrcTemplateStage)
referenceName' makeName n@(GHC.getName -> name)
| name `elem` registeredNamesFromPrelude || qualifiedName name `elem` otherNamesFromPrelude
= return $ makeName [] name
| otherwise
= do RefactorCtx {refCtxImports = imports, refModuleName = thisModule} <- ask
if maybe True (thisModule ==) (GHC.nameModule_maybe name)
then return $ makeName [] name
else let possibleImports = filter ((n `elem`) . (\imp -> fromJust $ imp ^? semantics&importedNames)) imports
in if null possibleImports
then do tell [name]
return $ makeName [] name
else return $ referenceBy makeName name possibleImports
referenceBy :: ([String] -> GHC.Name -> Ann nt dom SrcTemplateStage) -> GHC.Name -> [Ann ImportDecl dom SrcTemplateStage] -> Ann nt dom SrcTemplateStage
referenceBy makeName name imps =
let prefixes = map importQualifier imps
in makeName (minimumBy (compare `on` (length . concat)) prefixes) name
where importQualifier :: Ann ImportDecl dom SrcTemplateStage -> [String]
importQualifier imp
= if isJust (imp ^? element&importQualified&annJust)
then case imp ^? element&importAs&annJust&element&importRename&element of
Nothing -> splitOn "." (imp ^. element&importModule&element&moduleNameString)
Just asName -> splitOn "." (asName ^. moduleNameString)
else []
data NameClass = Variable
| Ctor
| ValueOperator
| DataCtorOperator
| SynonymOperator
classifyName :: GHC.Name -> Refactor dom NameClass
classifyName n = lookupName n >>= return . \case
Just (AnId id) | isop -> ValueOperator
Just (AnId id) -> Variable
Just (AConLike id) | isop -> DataCtorOperator
Just (AConLike id) -> Ctor
Just (ATyCon id) | isop -> SynonymOperator
Just (ATyCon id) -> Ctor
Nothing | isop -> ValueOperator
Nothing -> Variable
where isop = GHC.isSymOcc (GHC.getOccName n)
nameValid :: NameClass -> String -> Bool
nameValid n "" = False
nameValid n str | str `elem` reservedNames = False
where
reservedNames = [ "case", "class", "data", "default", "deriving", "do", "else", "if", "import", "in", "infix"
, "infixl", "infixr", "instance", "let", "module", "newtype", "of", "then", "type", "where", "_"
, "..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>", "[]"
]
nameValid DataCtorOperator (':' : nameRest)
= all isOperatorChar nameRest
nameValid SynonymOperator (c : nameRest)
= isOperatorChar c && all isOperatorChar nameRest
nameValid ValueOperator (c : nameRest)
= isOperatorChar c && c /= ':' && all isOperatorChar nameRest
nameValid Ctor (c : nameRest)
= isUpper c && isIdStartChar c && all (\c -> isIdStartChar c || isDigit c) nameRest
nameValid Variable (c : nameRest)
= isLower c && isIdStartChar c && all (\c -> isIdStartChar c || isDigit c) nameRest
nameValid _ _ = False
isIdStartChar c = (isLetter c && isAscii c) || c == '\'' || c == '_'
isOperatorChar c = (isPunctuation c || isSymbol c) && isAscii c