{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeApplications #-}
module Language.Haskell.Tools.Refactor.Utils.Monadic where
import Control.Monad.Reader (Monad(..), ReaderT(..), MonadReader(..))
import Control.Monad.State.Strict
import Control.Monad.Writer
import Control.Monad.Trans.Except (runExceptT)
import Control.Reference hiding (element)
import Data.Either
import Data.Function (on)
import Data.List
import Data.List.Split (splitOn)
import Data.Maybe
import GHC hiding (mkModuleName, moduleNameString)
import qualified Module as GHC (Module(..), moduleNameString)
import qualified Name as GHC
import qualified PrelNames as GHC (basicKnownKeyNames)
import qualified TyCon as GHC (TyCon(..))
import qualified TysWiredIn as GHC (wiredInTyCons)
import Language.Haskell.Tools.AST as AST
import Language.Haskell.Tools.PrettyPrint.Prepare
import Language.Haskell.Tools.Refactor.Monad
import Language.Haskell.Tools.Refactor.Representation (RefactorChange(..), ModuleDom, UnnamedModule)
import Language.Haskell.Tools.Rewrite as HT
runRefactor :: ModuleDom -> [ModuleDom] -> Refactoring -> Ghc (Either String [RefactorChange])
runRefactor mod mods trf = runExceptT $ trf mod mods
localRefactoring :: LocalRefactoring -> Refactoring
localRefactoring ref (name, mod) _
= (\m -> [ContentChanged (name, m)]) <$> localRefactoringRes id mod (ref mod)
localRefactoringRes :: ((UnnamedModule -> UnnamedModule) -> a -> a)
-> UnnamedModule -> LocalRefactor a -> Refactor a
localRefactoringRes access mod trf
= let init = RefactorCtx (semanticsModule $ mod ^. semantics) mod (mod ^? modImports&annList)
in flip runReaderT init $ do (mod, recorded) <- runWriterT (fromRefactorT trf)
return $ access (insertText (rights recorded) . addGeneratedImports (lefts recorded)) mod
insertText :: SourceInfoTraversal p => [(SrcSpan,String,String)] -> p dom SrcTemplateStage -> p dom SrcTemplateStage
insertText [] p = p
insertText inserted p
= evalState (sourceInfoTraverseUp (SourceInfoTrf
(\stn -> sourceTemplateNodeElems !~ takeWhatPrecedesElem (stn ^. sourceTemplateNodeRange) $ stn)
(srcTmpSeparators !~ takeWhatPrecedesSep)
pure) (return ()) (return ()) p) (map Right $ sortOn (^. _1) inserted)
where
takeWhatPrecedesSep :: [([SourceTemplateTextElem], SrcSpan)] -> State [Either SrcSpan (SrcSpan,String,String)] [([SourceTemplateTextElem], SrcSpan)]
takeWhatPrecedesSep seps = takeWhatPrecedes Nothing (Just . (^. _2))
(\str -> _1 .- (++ [StayingText str ""]))
(\str -> _1 .- ([StayingText str ""] ++))
seps
takeWhatPrecedesElem :: SrcSpan -> [SourceTemplateElem] -> State [Either SrcSpan (SrcSpan,String,String)] [SourceTemplateElem]
takeWhatPrecedesElem rng elems = takeWhatPrecedes (Just rng) (^? sourceTemplateTextRange)
(\s -> sourceTemplateTextElem .- (++ [StayingText s ""]))
(\s -> sourceTemplateTextElem .- ([StayingText s ""] ++))
elems
takeWhatPrecedes :: Maybe SrcSpan -> (a -> Maybe SrcSpan) -> (String -> a -> a) -> (String -> a -> a) -> [a] -> State [Either SrcSpan (SrcSpan,String,String)] [a]
takeWhatPrecedes rng access append prepend elems
| ranges <- mapMaybe access elems
, not (null ranges)
= do let start = srcSpanStart $ fromMaybe (head ranges) rng
end = srcSpanEnd $ fromMaybe (last ranges) rng
toInsert <- get
let (prefix,rest) = break ((>= start) . srcSpanStart . either id (\(sp,_,_) -> sp)) toInsert
(middle,suffix) = break ((> end) . srcSpanEnd . either id (\(sp,_,_) -> sp)) rest
put $ prefix ++ Left (mkSrcSpan start end) : suffix
return $ mergeInserted access append prepend False middle elems
where mergeInserted :: (a -> Maybe SrcSpan) -> (String -> a -> a) -> (String -> a -> a) -> Bool -> [Either SrcSpan (SrcSpan,String,String)] -> [a] -> [a]
mergeInserted _ _ _ _ [] elems = elems
mergeInserted access append prepend prep insert@(Right (insertSpan,insertStr,ln):toInsert) (fstElem:elems)
| Just _ <- access fstElem
, not prep && case mapMaybe access elems of sp:_ -> srcSpanStart sp >= srcSpanEnd insertSpan
_ -> True
= mergeInserted access append prepend prep toInsert (append (ln ++ insertStr ++ ln) fstElem : elems)
| Just fstElemSpace <- access fstElem
, prep && srcSpanStart fstElemSpace >= srcSpanEnd insertSpan
= mergeInserted access append prepend prep toInsert (prepend (ln ++ insertStr ++ ln) fstElem : elems)
| isJust (access fstElem) && prep
= mergeInserted access append prepend False insert (fstElem : elems)
| otherwise
= fstElem : mergeInserted access append prepend (if isJust (access fstElem) then False else prep) insert elems
mergeInserted access append prepend prep insert@(Left sp : toInsert) (fstElem:elems)
| Just fstElemSpace <- access fstElem
= if srcSpanStart fstElemSpace > srcSpanEnd sp
then mergeInserted access append prepend True toInsert (fstElem:elems)
else fstElem : mergeInserted access append prepend prep insert elems
| otherwise
= fstElem : mergeInserted access append prepend True toInsert elems
mergeInserted _ _ _ _ _ [] = []
takeWhatPrecedes _ _ _ _ elems = return elems
addGeneratedImports :: [GHC.Name] -> HT.Module -> HT.Module
addGeneratedImports names m = modImports&annListElems .- (++ addImports names) $ m
where addImports :: [GHC.Name] -> [HT.ImportDecl]
addImports names = map createImport $ groupBy ((==) `on` GHC.nameModule) $ filter (isJust . GHC.nameModule_maybe) $ nub $ sort names
createImport :: [GHC.Name] -> HT.ImportDecl
createImport names = mkImportDecl False True False Nothing (mkModuleName $ GHC.moduleNameString $ GHC.moduleName $ GHC.nameModule $ head names)
Nothing (Just $ mkImportSpecList (map (\n -> mkIESpec (mkUnqualName' n) Nothing) names))
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 :: GHC.Name -> LocalRefactor (Ann UName IdDom SrcTemplateStage)
referenceName = referenceName' mkQualName'
referenceOperator :: GHC.Name -> LocalRefactor (Ann UOperator IdDom SrcTemplateStage)
referenceOperator = referenceName' mkQualOp'
referenceName' :: ([String] -> GHC.Name -> Ann nt IdDom SrcTemplateStage) -> GHC.Name
-> LocalRefactor (Ann nt IdDom SrcTemplateStage)
referenceName' makeName name
| name `elem` registeredNamesFromPrelude || qualifiedName name `elem` otherNamesFromPrelude
= return $ makeName [] name
| otherwise
= do RefactorCtx {refCtxRoot = mod, refCtxImports = imports, refModuleName = thisModule} <- ask
if maybe True (thisModule ==) (GHC.nameModule_maybe name)
then return $ makeName [] name
else let possibleImports = filter ((name `elem`) . (\imp -> semanticsImported $ imp ^. semantics)) imports
fromPrelude = name `elem` semanticsImplicitImports (mod ^. semantics)
in if | fromPrelude -> return $ makeName [] name
| null possibleImports -> do tell [Left name]
return $ makeName (moduleParts name) name
| otherwise -> return $ referenceBy makeName name possibleImports
where moduleParts = maybe [] (splitOn "." . GHC.moduleNameString . GHC.moduleName) . GHC.nameModule_maybe
referenceBy :: ([String] -> GHC.Name -> Ann nt IdDom SrcTemplateStage) -> GHC.Name
-> [Ann UImportDecl IdDom SrcTemplateStage] -> Ann nt IdDom SrcTemplateStage
referenceBy makeName name imps =
let prefixes = map importQualifier imps
in makeName (minimumBy (compare `on` (length . concat)) prefixes) name
where importQualifier :: Ann UImportDecl IdDom SrcTemplateStage -> [String]
importQualifier imp
= if isJust (imp ^? importQualified&annJust)
then case imp ^? importAs&annJust&importRename of
Nothing -> splitOn "." (imp ^. importModule&moduleNameString)
Just asName -> splitOn "." (asName ^. moduleNameString)
else []