diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 0ce414d..4f081db 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -20,6 +20,7 @@ module Language.Haskell.GhcMod ( , expandTemplate , infoExpr , typeExpr + , fillSig , listModules , listLanguages , listFlags @@ -27,6 +28,7 @@ module Language.Haskell.GhcMod ( , rootInfo , packageDoc , findSymbol + , splitVar ) where import Language.Haskell.GhcMod.Boot @@ -41,4 +43,6 @@ import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint import Language.Haskell.GhcMod.List import Language.Haskell.GhcMod.PkgDoc +import Language.Haskell.GhcMod.FillSig +import Language.Haskell.GhcMod.CaseSplit import Language.Haskell.GhcMod.Types diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs index 93e6e37..7392ae4 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ b/Language/Haskell/GhcMod/CabalConfig.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | Reading cabal @dist/setup-config@ module Language.Haskell.GhcMod.CabalConfig ( CabalConfig @@ -15,7 +17,11 @@ import qualified Language.Haskell.GhcMod.Cabal18 as C18 import qualified Control.Exception as E import Control.Applicative ((<$>)) import Control.Monad (mplus) +#if MIN_VERSION_mtl(2,2,1) +import Control.Monad.Except () +#else import Control.Monad.Error () +#endif import Data.Maybe () import Data.Set () import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs new file mode 100644 index 0000000..3399a3c --- /dev/null +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE CPP #-} + +module Language.Haskell.GhcMod.CaseSplit ( + splitVar + , splits + ) where + +import Data.List (find, intercalate) +import qualified Data.Text as T +import qualified Data.Text.IO as T (readFile) +import Exception (ghandle, SomeException(..)) +import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import qualified GHC as G +import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.Gap (HasType(..)) +import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.SrcUtils +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Convert +import MonadUtils (liftIO) +import Outputable (PprStyle) +import qualified Type as Ty +import qualified TyCon as Ty +import qualified DataCon as Ty + +---------------------------------------------------------------- +-- CASE SPLITTING +---------------------------------------------------------------- + +data SplitInfo = SplitInfo G.Name (SrcSpan,Type) (SrcSpan, Type) [SrcSpan] +data SplitToTextInfo = SplitToTextInfo { sVarName :: String + , sBindingSpan :: SrcSpan + , sVarSpan :: SrcSpan + , sTycons :: [String] + } + +-- | Splitting a variable in a equation. +splitVar :: Options + -> Cradle + -> FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> IO String +splitVar opt cradle file lineNo colNo = runGhcMod opt $ do + initializeFlagsWithCradle opt cradle + splits file lineNo colNo + +-- | Splitting a variable in a equation. +splits :: FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcMod String +splits file lineNo colNo = ghandle handler body + where + body = inModuleContext file $ \dflag style -> do + opt <- options + modSum <- Gap.fileModSummary file + whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ + \(SplitInfo varName (bndLoc,_) (varLoc,varT) _matches) -> do + let varName' = showName dflag style varName -- Convert name to string + text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ + getTyCons dflag style varName varT) + return (fourInts bndLoc, text) + handler (SomeException _) = emptyResult =<< options + +---------------------------------------------------------------- +-- a. Code for getting the information of the variable + +getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) +getSrcSpanTypeForSplit modSum lineNo colNo = do + p@ParsedModule{pm_parsed_source = pms} <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + let bs:_ = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] + varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) + match:_ = listifyParsedSpans pms (lineNo, colNo) +#if __GLASGOW_HASKELL__ < 708 + :: [G.LMatch G.RdrName] +#else + :: [G.LMatch G.RdrName (LHsExpr G.RdrName)] +#endif + case varPat of + Nothing -> return Nothing + Just varPat' -> do + varT <- getType tcm varPat' -- Finally we get the type of the var + bsT <- getType tcm bs + case (varT, bsT) of + (Just varT', Just (_,bsT')) -> + let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match + in return $ Just (SplitInfo (getPatternVarName varPat') (matchL,bsT') varT' (map G.getLoc rhsLs) ) + _ -> return Nothing + +isPatternVar :: LPat Id -> Bool +isPatternVar (L _ (G.VarPat _)) = True +isPatternVar _ = False + +getPatternVarName :: LPat Id -> G.Name +getPatternVarName (L _ (G.VarPat vName)) = G.getName vName +getPatternVarName _ = error "This should never happend" + +---------------------------------------------------------------- +-- b. Code for getting the possible constructors + +getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type -> [String] +getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = + let name' = showName dflag style name -- Convert name to string + in getTyCon dflag style name' tyCon +getTyCons dflag style name _ = [showName dflag style name] + +-- Write cases for one type +getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String] +-- 1. Non-matcheable type constructors +getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name] +-- 2. Special cases +-- 2.1. Tuples +getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon = + let [uniqueDataCon] = Ty.tyConDataCons tyCon + tupleArity = Ty.dataConSourceArity uniqueDataCon + -- Deal with both boxed and unboxed tuples + isUnboxed = Ty.isUnboxedTupleTyCon tyCon + startSign = if isUnboxed then "(#" else "(" + endSign = if isUnboxed then "#)" else ")" + in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ] +-- 3. General case +getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon) + +-- These type constructors should not be matched against +isNotMatcheableTyCon :: Ty.TyCon -> Bool +isNotMatcheableTyCon ty = Ty.isPrimTyCon ty -- Primitive types, such as Int# + || Ty.isFunTyCon ty -- Function types + +-- Write case for one constructor +getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String +-- 1. Infix constructors +getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon = + let dName = showName dflag style $ Ty.dataConName dcon + in case Ty.dataConSourceArity dcon of + 0 -> dName + 1 -> vName ++ dName + n -> if dName == ":" -- Special case for lists + then vName ++ ":" ++ vName ++ "s" + else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1) +-- 2. Non-record, non-infix syntax +getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon = + let dName = showName dflag style $ Ty.dataConName dcon + in if last dName == '#' -- Special case for I#, C# and so on + then vName + else case Ty.dataConSourceArity dcon of + 0 -> dName + _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon) +-- 3. Records +getDataCon dflag style vName dcon = + let dName = showName dflag style $ Ty.dataConName dcon + flds = Ty.dataConFieldLabels dcon + in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }" + +-- Create a new variable by adjoining a number +newVar :: String -> Int -> String +newVar v n = v ++ show n + +-- Create a list of variables which start with the same prefix +newVars :: String -> Int -> Int -> String +newVars _ _ 0 = "" +newVars v s 1 = newVar v s +newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1) + +-- Create a list of variables which start with the same prefix +-- Special case for a single variable, in which case no number is adjoint +newVarsSpecialSingleton :: String -> Int -> Int -> String +newVarsSpecialSingleton v _ 1 = v +newVarsSpecialSingleton v start n = newVars v start n + +showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String +showFieldNames _ _ _ [] = "" -- This should never happen +showFieldNames dflag style v (x:xs) = let fName = showName dflag style x + fAcc = fName ++ " = " ++ v ++ "_" ++ fName + in case xs of + [] -> fAcc + _ -> fAcc ++ ", " ++ showFieldNames dflag style v xs + +---------------------------------------------------------------- +-- c. Code for performing the case splitting + +genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String +genCaseSplitTextFile file info = liftIO $ do + text <- T.readFile file + return $ getCaseSplitText (T.lines text) info + +getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String +getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS + , sVarSpan = sVS, sTycons = sT }) = + let bindingText = getBindingText text sBS + difference = srcSpanDifference sBS sVS + replaced = concatMap (replaceVarWithTyCon bindingText difference sVN) sT + in T.unpack $ T.intercalate (T.pack "\n") replaced + +getBindingText :: [T.Text] -> SrcSpan -> [T.Text] +getBindingText text srcSpan = + let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan + lines_ = drop (sl - 1) $ take el text + in if sl == el + then -- only one line + [T.drop (sc - 1) $ T.take ec $ head lines_] + else -- several lines + let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_) + in (T.drop (sc - 1) first) : rest ++ [T.take ec last_] + +srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int) +srcSpanDifference b v = + let Just (bsl,bsc,_ ,_) = Gap.getSrcSpan b + Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v + in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line + +replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text] +replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon = + let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon + lengthDiff = length tycon' - length varname + tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon' + spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff + in zipWith (\n line -> if n < vsl + then line -- before variable starts + else if n == vsl + then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line + else T.replicate spacesToAdd (T.pack " ") `T.append` line) + [0 ..] text diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 4a422ce..e348eca 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-} -module Language.Haskell.GhcMod.Convert (convert, convert') where +module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types @@ -76,12 +76,26 @@ instance ToString [((Int,Int,Int,Int),String)] where toS x = ('(' :) . tupToString opt x . (')' :) toPlain opt = inter '\n' . map (tupToString opt) +instance ToString ((Int,Int,Int,Int),String) where + toLisp opt x = ('(' :) . tupToString opt x . (')' :) + toPlain opt x = tupToString opt x + +instance ToString (String, (Int,Int,Int,Int),[String]) where + toLisp opt (s,x,y) = toSexp2 $ [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y] + toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y] + toSexp1 :: Options -> [String] -> Builder toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) toSexp2 :: [Builder] -> Builder toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :) +fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder +fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :) + . (show b ++) . (' ' :) + . (show c ++) . (' ' :) + . (show d ++) + tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :) . (show b ++) . (' ' :) @@ -101,3 +115,15 @@ quote opt str = ("\"" ++) . (quote' str ++) . ("\"" ++) | otherwise = x : quote' xs ---------------------------------------------------------------- + +-- Empty result to be returned when no info can be gathered +emptyResult :: Monad m => Options -> m String +emptyResult opt = return $ convert opt ([] :: [String]) + +-- Return an emptyResult when Nothing +whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String +whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from + +-- Return an emptyResult when Nothing, inside a monad +whenFound' :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> m b) -> m String +whenFound' opt from f = maybe (emptyResult opt) (\x -> do y <- f x ; return (convert opt y)) =<< from diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs index 4c3d8ce..bbc6b77 100644 --- a/Language/Haskell/GhcMod/Doc.hs +++ b/Language/Haskell/GhcMod/Doc.hs @@ -1,6 +1,6 @@ module Language.Haskell.GhcMod.Doc where -import GHC (Ghc, DynFlags) +import GHC (DynFlags, GhcMonad) import qualified GHC as G import Language.Haskell.GhcMod.Gap (withStyle, showDocWith) import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify) @@ -12,7 +12,7 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style showOneLine :: DynFlags -> PprStyle -> SDoc -> String showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style -getStyle :: Ghc PprStyle +getStyle :: GhcMonad m => m PprStyle getStyle = do unqual <- G.getPrintUnqual return $ mkUserStyle unqual AllTheWay diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs new file mode 100644 index 0000000..8e3566f --- /dev/null +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP #-} + +module Language.Haskell.GhcMod.FillSig ( + fillSig + , sig + ) where + +import Data.Char (isSymbol) +import Data.List (find, intercalate) +import Exception (ghandle, SomeException(..)) +import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import qualified GHC as G +import Language.Haskell.GhcMod.GHCApi +import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.SrcUtils +import Language.Haskell.GhcMod.Types +import MonadUtils (liftIO) +import Outputable (PprStyle) +import qualified Type as Ty +import qualified HsBinds as Ty +import qualified Class as Ty +#if __GLASGOW_HASKELL__ >= 706 +import OccName (occName) +#else +import OccName (OccName) +import RdrName (rdrNameOcc) +#endif +import qualified Language.Haskell.Exts.Annotated as HE + +---------------------------------------------------------------- +-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE +---------------------------------------------------------------- + +-- Possible signatures we can find: function or instance +data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) + | InstanceDecl SrcSpan G.Class + +-- Signature for fallback operation via haskell-src-exts +data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) + +-- | Create a initial body from a signature. +fillSig :: Options + -> Cradle + -> FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> IO String +fillSig opt cradle file lineNo colNo = runGhcMod opt $ do + initializeFlagsWithCradle opt cradle + sig file lineNo colNo + +-- | Create a initial body from a signature. +sig :: FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> GhcMod String +sig file lineNo colNo = ghandle handler body + where + body = inModuleContext file $ \dflag style -> do + opt <- options + modSum <- Gap.fileModSummary file + whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of + Signature loc names ty -> + ("function", fourInts loc, map (initialBody dflag style ty) names) + InstanceDecl loc cls -> do + ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x) + (Ty.classMethods cls)) + + handler (SomeException _) = do + opt <- options + -- Code cannot be parsed by ghc module + -- Fallback: try to get information via haskell-src-exts + whenFound opt (getSignatureFromHE file lineNo colNo) $ + \(HESignature loc names ty) -> + ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names) + +---------------------------------------------------------------- +-- a. Code for getting the information + +-- Get signature from ghc parsing and typechecking +getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo) +getSignature modSum lineNo colNo = do + p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum + -- Inspect the parse tree to find the signature + case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of + [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] -> + -- We found a type signature + return $ Just $ Signature loc (map G.unLoc names) ty + [L _ (G.InstD _)] -> do + -- We found an instance declaration + TypecheckedModule{tm_renamed_source = Just tcs + ,tm_checked_module_info = minfo} <- G.typecheckModule p + case listifyRenamedSpans tcs (lineNo, colNo) :: [G.LInstDecl G.Name] of + -- Instance declarations of sort 'instance F (G a)' +#if __GLASGOW_HASKELL__ >= 708 + [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = + (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] -> +#elif __GLASGOW_HASKELL__ >= 706 + [L loc (G.ClsInstD + (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] -> +#else + [L loc (G.InstDecl + (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] -> +#endif + obtainClassInfo minfo clsName loc + -- Instance declarations of sort 'instance F G' (no variables) +#if __GLASGOW_HASKELL__ >= 708 + [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = + (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] -> +#elif __GLASGOW_HASKELL__ >= 706 + [L loc (G.ClsInstD + (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] -> +#else + [L loc (G.InstDecl + (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] -> +#endif + obtainClassInfo minfo clsName loc + _ -> return Nothing + _ -> return Nothing + where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo) + obtainClassInfo minfo clsName loc = do + tyThing <- G.modInfoLookupName minfo clsName + return $ do Ty.ATyCon clsCon <- tyThing -- In Maybe + cls <- G.tyConClass_maybe clsCon + return $ InstanceDecl loc cls + +-- Get signature from haskell-src-exts +getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo) +getSignatureFromHE file lineNo colNo = do + presult <- liftIO $ HE.parseFile file + return $ case presult of + HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do + HE.TypeSig (HE.SrcSpanInfo s _) names ty <- find (typeSigInRangeHE lineNo colNo) mdecls + return $ HESignature s names ty + _ -> Nothing + +---------------------------------------------------------------- +-- b. Code for generating initial code + +-- A list of function arguments, and whether they are functions or normal arguments +-- is built from either a function signature or an instance signature +data FnArg = FnArgFunction | FnArgNormal + +initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String +initialBody dflag style ty name = initialBody' (getFnName dflag style name) (getFnArgs ty) + +initialBody' :: String -> [FnArg] -> String +initialBody' fname args = + case initialBodyArgs args infiniteVars infiniteFns of + [] -> fname + arglist -> if isSymbolName fname + then (head arglist) ++ " " ++ fname ++ " " ++ (intercalate " " (tail arglist)) + else fname ++ " " ++ (intercalate " " arglist) + ++ " = " ++ (if isSymbolName fname then "" else '_':fname) ++ "_body" + +initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String] +initialBodyArgs [] _ _ = [] +initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs +initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs +initialBodyArgs _ _ _ = error "This should never happen" -- Lists are infinite + +-- Getting the initial body of function and instances differ +-- This is because for functions we only use the parsed file +-- (so the full file doesn't have to be type correct) +-- but for instances we need to get information about the class + +class FnArgsInfo ty name | ty -> name, name -> ty where + getFnName :: DynFlags -> PprStyle -> name -> String + getFnArgs :: ty -> [FnArg] + +instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where + getFnName dflag style name = showOccName dflag style $ occName name + getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy + getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy + getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy + where fnarg = \ty -> case ty of + (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy + (G.HsParTy (L _ iTy)) -> fnarg iTy + (G.HsFunTy _ _) -> True + _ -> False + getFnArgs _ = [] + +#if __GLASGOW_HASKELL__ < 706 +occName :: G.RdrName -> OccName +occName = rdrNameOcc +#endif + +instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where + getFnName _ _ (HE.Ident _ s) = s + getFnName _ _ (HE.Symbol _ s) = s + getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy + getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy + getFnArgs (HE.TyFun _ lTy rTy) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy + where fnarg = \ty -> case ty of + (HE.TyForall _ _ _ iTy) -> fnarg iTy + (HE.TyParen _ iTy) -> fnarg iTy + (HE.TyFun _ _ _) -> True + _ -> False + getFnArgs _ = [] + +instance FnArgsInfo Type Id where + getFnName dflag style method = showOccName dflag style $ G.getOccName method + getFnArgs = getFnArgs' . Ty.dropForAlls + where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty = + maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy) + (\_ -> FnArgFunction:getFnArgs' rTy) + $ Ty.splitFunTy_maybe lTy + getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = getFnArgs' iTy + getFnArgs' _ = [] + +-- Infinite supply of variable and function variable names +infiniteVars, infiniteFns :: [String] +infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"] +infiniteFns = infiniteSupply ["f","g","h"] +infiniteSupply :: [String] -> [String] +infiniteSupply initialSupply = initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply) ([1 .. ] :: [Integer]) + +-- Check whether a String is a symbol name +isSymbolName :: String -> Bool +isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c +isSymbolName [] = error "This should never happen" diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index e12df43..d48b2e7 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -19,11 +19,11 @@ import Language.Haskell.GhcMod.GhcPkg import Control.Applicative ((<$>)) import Control.Monad (forM, void) -import CoreMonad (liftIO) import Data.Maybe (isJust, fromJust) import Exception (ghandle, SomeException(..)) -import GHC (Ghc, GhcMonad, DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) +import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) import qualified GHC as G +import GhcMonad import GHC.Paths (libdir) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types diff --git a/Language/Haskell/GhcMod/GHCChoice.hs b/Language/Haskell/GhcMod/GHCChoice.hs index 99904f0..3ac604e 100644 --- a/Language/Haskell/GhcMod/GHCChoice.hs +++ b/Language/Haskell/GhcMod/GHCChoice.hs @@ -5,21 +5,21 @@ module Language.Haskell.GhcMod.GHCChoice where import Control.Exception (IOException) import CoreMonad (liftIO) import qualified Exception as GE -import GHC (Ghc, GhcMonad) +import GHC (GhcMonad) ---------------------------------------------------------------- -- | Try the left 'Ghc' action. If 'IOException' occurs, try -- the right 'Ghc' action. -(||>) :: Ghc a -> Ghc a -> Ghc a +(||>) :: GhcMonad m => m a -> m a -> m a x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y) -- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'. -goNext :: Ghc a +goNext :: GhcMonad m => m a goNext = liftIO . GE.throwIO $ userError "goNext" -- | Run any one 'Ghc' monad. -runAnyOne :: [Ghc a] -> Ghc a +runAnyOne :: GhcMonad m => [m a] -> m a runAnyOne = foldr (||>) goNext ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 770b28e..062538b 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-} module Language.Haskell.GhcMod.Gap ( Language.Haskell.GhcMod.Gap.ClsInst @@ -24,6 +24,8 @@ module Language.Haskell.GhcMod.Gap ( , HasType(..) , errorMsgSpan , typeForUser + , nameForUser + , occNameForUser , deSugar , showDocWith , GapThing(..) @@ -44,10 +46,12 @@ import Desugar (deSugarExpr) import DynFlags import ErrUtils import FastString +import GhcMonad import HscTypes import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Types import NameSet +import OccName import Outputable import PprTyThing import StringBuffer @@ -148,7 +152,7 @@ getSrcFile _ = Nothing ---------------------------------------------------------------- -toStringBuffer :: [String] -> Ghc StringBuffer +toStringBuffer :: GhcMonad m => [String] -> m StringBuffer #if __GLASGOW_HASKELL__ >= 702 toStringBuffer = return . stringToStringBuffer . unlines #else @@ -171,13 +175,13 @@ fOptions = [option | (option,_,_,_) <- fFlags] ---------------------------------------------------------------- ---------------------------------------------------------------- -fileModSummary :: FilePath -> Ghc ModSummary +fileModSummary :: GhcMonad m => FilePath -> m ModSummary fileModSummary file = do mss <- getModuleGraph let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss return ms -withContext :: Ghc a -> Ghc a +withContext :: GhcMonad m => m a -> m a withContext action = gbracket setup teardown body where setup = getContext @@ -293,7 +297,7 @@ filterOutChildren get_thing xs where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] -infoThing :: String -> Ghc SDoc +infoThing :: GhcMonad m => String -> m SDoc infoThing str = do names <- parseName str #if __GLASGOW_HASKELL__ >= 708 @@ -345,6 +349,12 @@ typeForUser = pprTypeForUser typeForUser = pprTypeForUser False #endif +nameForUser :: Name -> SDoc +nameForUser = pprOccName . getOccName + +occNameForUser :: OccName -> SDoc +occNameForUser = pprOccName + deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv -> IO (Maybe CoreExpr) #if __GLASGOW_HASKELL__ >= 708 diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index 540a29a..112dfd1 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -8,6 +8,8 @@ module Language.Haskell.GhcMod.Ghc ( , check , info , types + , splits + , sig , modules -- * 'SymMdlDb' , Symbol @@ -24,3 +26,5 @@ import Language.Haskell.GhcMod.Find import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.List +import Language.Haskell.GhcMod.FillSig +import Language.Haskell.GhcMod.CaseSplit diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 50a0811..4394f9f 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Language.Haskell.GhcMod.Info ( infoExpr , info @@ -9,25 +6,20 @@ module Language.Haskell.GhcMod.Info ( ) where import Control.Applicative ((<$>)) -import CoreMonad (liftIO) -import CoreUtils (exprType) import Data.Function (on) -import Data.Generics import Data.List (sortBy) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Ord as O +import Data.Maybe (catMaybes) import Exception (ghandle, SomeException(..)) -import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, TypecheckedSource, GenLocated(L)) +import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) import qualified GHC as G -import GHC.SYB.Utils (Stage(TypeChecker), everythingStaged) -import Language.Haskell.GhcMod.Doc (showPage, showOneLine, getStyle) +import Language.Haskell.GhcMod.Doc (showPage) import Language.Haskell.GhcMod.GHCApi -import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors) +import Language.Haskell.GhcMod.Gap (HasType(..)) import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Monad +import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Convert -import Outputable (PprStyle) -import TcHsSyn (hsPatType) ---------------------------------------------------------------- @@ -37,16 +29,17 @@ infoExpr :: Options -> FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. -> IO String -infoExpr opt cradle file expr = withGHC' $ do +infoExpr opt cradle file expr = runGhcMod opt $ do initializeFlagsWithCradle opt cradle - info opt file expr + info file expr -- | Obtaining information of a target expression. (GHCi's info:) -info :: Options - -> FilePath -- ^ A target file. +info :: FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. - -> Ghc String -info opt file expr = convert opt <$> ghandle handler body + -> GhcMod String +info file expr = do + opt <- options + convert opt <$> ghandle handler body where body = inModuleContext file $ \dflag style -> do sdoc <- Gap.infoThing expr @@ -55,17 +48,6 @@ info opt file expr = convert opt <$> ghandle handler body ---------------------------------------------------------------- -instance HasType (LHsExpr Id) where - getType tcm e = do - hs_env <- G.getSession - mbe <- liftIO $ Gap.deSugar tcm e hs_env - return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe - -instance HasType (LPat Id) where - getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) - ----------------------------------------------------------------- - -- | Obtaining type of a target expression. (GHCi's type:) typeExpr :: Options -> Cradle @@ -73,17 +55,18 @@ typeExpr :: Options -> Int -- ^ Line number. -> Int -- ^ Column number. -> IO String -typeExpr opt cradle file lineNo colNo = withGHC' $ do +typeExpr opt cradle file lineNo colNo = runGhcMod opt $ do initializeFlagsWithCradle opt cradle - types opt file lineNo colNo + types file lineNo colNo -- | Obtaining type of a target expression. (GHCi's type:) -types :: Options - -> FilePath -- ^ A target file. +types :: FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> Ghc String -types opt file lineNo colNo = convert opt <$> ghandle handler body + -> GhcMod String +types file lineNo colNo = do + opt <- options + convert opt <$> ghandle handler body where body = inModuleContext file $ \dflag style -> do modSum <- Gap.fileModSummary file @@ -91,7 +74,7 @@ types opt file lineNo colNo = convert opt <$> ghandle handler body return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes handler (SomeException _) = return [] -getSrcSpanType :: G.ModSummary -> Int -> Int -> Ghc [(SrcSpan, Type)] +getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do p <- G.parseModule modSum tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p @@ -103,36 +86,3 @@ getSrcSpanType modSum lineNo colNo = do pts <- mapM (getType tcm) ps return $ catMaybes $ concat [ets, bts, pts] -listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] -listifySpans tcs lc = listifyStaged TypeChecker p tcs - where - p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc - -listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] -listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) - -cmp :: SrcSpan -> SrcSpan -> Ordering -cmp a b - | a `G.isSubspanOf` b = O.LT - | b `G.isSubspanOf` a = O.GT - | otherwise = O.EQ - -toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) -toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ) - -fourInts :: SrcSpan -> (Int,Int,Int,Int) -fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan - -pretty :: DynFlags -> PprStyle -> Type -> String -pretty dflag style = showOneLine dflag style . Gap.typeForUser - ----------------------------------------------------------------- - -inModuleContext :: FilePath -> (DynFlags -> PprStyle -> Ghc a) -> Ghc a -inModuleContext file action = - withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do - setTargetFiles [file] - Gap.withContext $ do - dflag <- G.getSessionDynFlags - style <- getStyle - action dflag style diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs new file mode 100644 index 0000000..c5438a2 --- /dev/null +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Haskell.GhcMod.SrcUtils where + +import Control.Applicative ((<$>)) +import CoreUtils (exprType) +import Data.Generics +import Data.Maybe (fromMaybe) +import Data.Ord as O +import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) +import GhcMonad +import qualified GHC as G +import GHC.SYB.Utils (Stage(..), everythingStaged) +import Language.Haskell.GhcMod.Doc (showOneLine, getStyle) +import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors) +import qualified Language.Haskell.GhcMod.Gap as Gap +import Outputable (PprStyle) +import TcHsSyn (hsPatType) +import OccName (OccName) +import qualified Language.Haskell.Exts.Annotated as HE + +---------------------------------------------------------------- + +instance HasType (LHsExpr Id) where + getType tcm e = do + hs_env <- G.getSession + mbe <- liftIO $ Gap.deSugar tcm e hs_env + return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe + +instance HasType (LPat Id) where + getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) + +---------------------------------------------------------------- + +listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] +listifySpans tcs lc = listifyStaged TypeChecker p tcs + where + p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc + +listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a] +listifyParsedSpans pcs lc = listifyStaged Parser p pcs + where + p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc + +listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a] +listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs + where + p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc + +listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] +listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) + +cmp :: SrcSpan -> SrcSpan -> Ordering +cmp a b + | a `G.isSubspanOf` b = O.LT + | b `G.isSubspanOf` a = O.GT + | otherwise = O.EQ + +toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) +toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ) + +fourInts :: SrcSpan -> (Int,Int,Int,Int) +fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan + +fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int) +fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc + , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc) + +-- Check whether (line,col) is inside a given SrcSpanInfo +typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool +typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) = + HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) +typeSigInRangeHE _ _ _= False + +pretty :: DynFlags -> PprStyle -> Type -> String +pretty dflag style = showOneLine dflag style . Gap.typeForUser + +---------------------------------------------------------------- + +inModuleContext ::GhcMonad m => FilePath -> (DynFlags -> PprStyle -> m a) -> m a +inModuleContext file action = + withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do + setTargetFiles [file] + Gap.withContext $ do + dflag <- G.getSessionDynFlags + style <- getStyle + action dflag style + +---------------------------------------------------------------- + +showName :: DynFlags -> PprStyle -> G.Name -> String +showName dflag style name = showOneLine dflag style $ Gap.nameForUser name + +showOccName :: DynFlags -> PprStyle -> OccName -> String +showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name diff --git a/elisp/Makefile b/elisp/Makefile index d77aed3..96bec8b 100644 --- a/elisp/Makefile +++ b/elisp/Makefile @@ -1,5 +1,5 @@ SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el \ - ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el + ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el ghc-rewrite.el EMACS = emacs DETECT = xemacs diff --git a/elisp/ghc-rewrite.el b/elisp/ghc-rewrite.el new file mode 100644 index 0000000..681c897 --- /dev/null +++ b/elisp/ghc-rewrite.el @@ -0,0 +1,77 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ghc-rewrite.el +;;; + +;; Author: Alejandro Serrano +;; Created: Jun 17, 2014 + +;;; Code: + +(require 'ghc-func) +(require 'ghc-process) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Case splitting +;;; + +(ghc-defstruct sinfo beg-line beg-column end-line end-column info) + +(defun ghc-case-split () + (interactive) + (let ((info (ghc-obtain-case-split))) + (if (null info) + (message "Cannot split in cases") + (let* ((current-line (line-number-at-pos)) + (begin-line (ghc-sinfo-get-beg-line info)) + (begin-line-diff (+ 1 (- begin-line current-line))) + (begin-line-pos (line-beginning-position begin-line-diff)) + (begin-pos (- (+ begin-line-pos (ghc-sinfo-get-beg-column info)) 1)) + (end-line (ghc-sinfo-get-end-line info)) + (end-line-diff (+ 1 (- end-line current-line))) + (end-line-pos (line-beginning-position end-line-diff)) + (end-pos (- (+ end-line-pos (ghc-sinfo-get-end-column info)) 1)) ) + (delete-region begin-pos end-pos) + (insert (ghc-sinfo-get-info info)) ) ))) + +(defun ghc-obtain-case-split () + (let* ((ln (int-to-string (line-number-at-pos))) + (cn (int-to-string (1+ (current-column)))) + (file (buffer-file-name)) + (cmd (format "split %s %s %s\n" file ln cn))) + (ghc-sync-process cmd))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Initial code from signature +;;; + +(ghc-defstruct icsinfo sort pos fns) + +(defun ghc-initial-code-from-signature () + (interactive) + (let ((info (ghc-obtain-initial-code-from-signature))) + (if (null info) + (message "Cannot obtain initial code") + (let* ((ln-current (line-number-at-pos)) + (sort (ghc-icsinfo-get-sort info)) + (pos (ghc-icsinfo-get-pos info)) + (ln-end (ghc-sinfo-get-end-line pos)) + (ln-diff (+ 1 (- ln-end ln-current))) + (fns-to-insert (ghc-icsinfo-get-fns info))) + (goto-char (line-end-position ln-diff)) + (dolist (fn-to-insert fns-to-insert) + (if (equal sort "function") + (newline) + (newline-and-indent)) + (insert fn-to-insert)))))) + +(defun ghc-obtain-initial-code-from-signature () + (let* ((ln (int-to-string (line-number-at-pos))) + (cn (int-to-string (1+ (current-column)))) + (file (buffer-file-name)) + (cmd (format "sig %s %s %s\n" file ln cn))) + (ghc-sync-process cmd))) + +(provide 'ghc-rewrite) diff --git a/elisp/ghc.el b/elisp/ghc.el index 50b3146..5640dad 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -40,6 +40,7 @@ (require 'ghc-command) (require 'ghc-ins-mod) (require 'ghc-indent) +(require 'ghc-rewrite) (require 'dabbrev) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -72,6 +73,8 @@ (defvar ghc-hoogle-key (format "\C-c%c" (ghc-find-C-h))) (defvar ghc-shallower-key "\C-c<") (defvar ghc-deeper-key "\C-c>") +(defvar ghc-case-split-key "\C-c\C-p") +(defvar ghc-initial-sig-key "\C-c\C-s") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -104,6 +107,8 @@ (define-key haskell-mode-map ghc-hoogle-key 'haskell-hoogle) (define-key haskell-mode-map ghc-shallower-key 'ghc-make-indent-shallower) (define-key haskell-mode-map ghc-deeper-key 'ghc-make-indent-deeper) + (define-key haskell-mode-map ghc-case-split-key 'ghc-case-split) + (define-key haskell-mode-map ghc-initial-sig-key 'ghc-initial-code-from-signature) (ghc-comp-init) (setq ghc-initialized t)) (ghc-import-module) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 7699634..ec9b820 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -61,11 +61,13 @@ Library Language.Haskell.GhcMod.CabalConfig Language.Haskell.GhcMod.Cabal16 Language.Haskell.GhcMod.Cabal18 + Language.Haskell.GhcMod.CaseSplit Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Cradle Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Debug Language.Haskell.GhcMod.Doc + Language.Haskell.GhcMod.FillSig Language.Haskell.GhcMod.Find Language.Haskell.GhcMod.Flag Language.Haskell.GhcMod.GHCApi @@ -81,6 +83,7 @@ Library Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Read + Language.Haskell.GhcMod.SrcUtils Build-Depends: base >= 4.0 && < 5 , containers , deepseq @@ -100,6 +103,8 @@ Library , mtl , monad-control , split + , haskell-src-exts + , text if impl(ghc < 7.7) Build-Depends: convertible , Cabal >= 1.10 && < 1.17 @@ -177,6 +182,8 @@ Test-Suite spec , monad-control , hspec >= 1.8.2 , split + , haskell-src-exts + , text if impl(ghc < 7.7) Build-Depends: convertible , Cabal >= 1.10 && < 1.17 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 14ab61e..a2958e6 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -38,6 +38,8 @@ usage = progVersion ++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n" ++ "\t ghc-mod info" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod type" ++ ghcOptHelp ++ " \n" + ++ "\t ghc-mod split" ++ ghcOptHelp ++ " \n" + ++ "\t ghc-mod sig" ++ ghcOptHelp ++ " \n" ++ "\t ghc-mod find \n" ++ "\t ghc-mod lint [-h opt] \n" ++ "\t ghc-mod root\n" @@ -119,6 +121,8 @@ main = flip E.catches handlers $ do "debug" -> debugInfo opt cradle "info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3 "type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) + "split" -> nArgs 4 $ splitVar opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) + "sig" -> nArgs 4 $ fillSig opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) "find" -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1 "lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1 "root" -> rootInfo opt cradle diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 139ef1c..0baf43c 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -31,7 +31,7 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Typeable (Typeable) import Data.Version (showVersion) -import GHC (Ghc) +import GHC (GhcMonad) import qualified GHC as G import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Ghc @@ -142,8 +142,10 @@ loop opt set mvar = do "check" -> checkStx opt set arg "find" -> findSym set arg mvar "lint" -> toGhcMod $ lintStx opt set arg - "info" -> toGhcMod $ showInfo opt set arg - "type" -> toGhcMod $ showType opt set arg + "info" -> showInfo set arg + "type" -> showType set arg + "split" -> doSplit set arg + "sig" -> doSig set arg "boot" -> bootIt set "browse" -> browseIt set arg "quit" -> return ("quit", False, set) @@ -171,7 +173,7 @@ checkStx _ set file = do Right ret -> return (ret, True, set') Left ret -> return (ret, True, set) -- fxime: set -newFileSet :: Set FilePath -> FilePath -> Ghc (Set FilePath) +newFileSet :: GhcMonad m => Set FilePath -> FilePath -> m (Set FilePath) newFileSet set file = do let set1 | S.member file set = set @@ -181,7 +183,7 @@ newFileSet set file = do Nothing -> set1 Just mainfile -> S.delete mainfile set1 -getModSummaryForMain :: Ghc (Maybe G.ModSummary) +getModSummaryForMain :: GhcMonad m => m (Maybe G.ModSummary) getModSummaryForMain = find isMain <$> G.getModuleGraph where isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main" @@ -207,8 +209,9 @@ findSym set sym mvar = do let ret = lookupSym' opt sym db return (ret, True, set) -lintStx :: Options -> Set FilePath -> FilePath - -> Ghc (String, Bool, Set FilePath) +lintStx :: GhcMonad m + => Options -> Set FilePath -> FilePath + -> m (String, Bool, Set FilePath) lintStx opt set optFile = liftIO $ do ret <-lintSyntax opt' file return (ret, True, set) @@ -234,24 +237,40 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of ---------------------------------------------------------------- -showInfo :: Options - -> Set FilePath +showInfo :: Set FilePath -> FilePath - -> Ghc (String, Bool, Set FilePath) -showInfo opt set fileArg = do + -> GhcMod (String, Bool, Set FilePath) +showInfo set fileArg = do let [file, expr] = words fileArg set' <- newFileSet set file - ret <- info opt file expr + ret <- info file expr return (ret, True, set') -showType :: Options - -> Set FilePath +showType :: Set FilePath -> FilePath - -> Ghc (String, Bool, Set FilePath) -showType opt set fileArg = do + -> GhcMod (String, Bool, Set FilePath) +showType set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file - ret <- types opt file (read line) (read column) + ret <- types file (read line) (read column) + return (ret, True, set') + +doSplit :: Set FilePath + -> FilePath + -> GhcMod (String, Bool, Set FilePath) +doSplit set fileArg = do + let [file, line, column] = words fileArg + set' <- newFileSet set file + ret <- splits file (read line) (read column) + return (ret, True, set') + +doSig :: Set FilePath + -> FilePath + -> GhcMod (String, Bool, Set FilePath) +doSig set fileArg = do + let [file, line, column] = words fileArg + set' <- newFileSet set file + ret <- sig file (read line) (read column) return (ret, True, set') ----------------------------------------------------------------