diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 5f201bb..379bba7 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -43,4 +43,5 @@ import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint import Language.Haskell.GhcMod.List import Language.Haskell.GhcMod.PkgDoc +import Language.Haskell.GhcMod.Rewrite import Language.Haskell.GhcMod.Types diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index 311053c..dd6caa8 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -26,3 +26,4 @@ import Language.Haskell.GhcMod.Find import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.List +import Language.Haskell.GhcMod.Rewrite diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 9ca6616..14c338c 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -1,44 +1,24 @@ -{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types, LambdaCase #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Language.Haskell.GhcMod.Info ( infoExpr , info , typeExpr , types - , splitVar - , splits - , fillSig - , sig ) where import Control.Applicative ((<$>)) -import CoreMonad (liftIO) -import CoreUtils (exprType) -import Data.Char (isSymbol) import Data.Function (on) -import Data.Generics -import Data.List (find, intercalate, sortBy) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Ord as O +import Data.List (sortBy) +import Data.Maybe (catMaybes) import Exception (ghandle, SomeException(..)) -import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) +import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) import qualified GHC as G -import GHC.SYB.Utils (Stage(..), everythingStaged, showData) -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.SrcUtils import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Convert -import Outputable (PprStyle) -import TcHsSyn (hsPatType) -import qualified Type as Ty -import qualified TyCon as Ty -import qualified DataCon as Ty -import qualified HsBinds as Ty -import qualified Class as Ty -import OccName (OccName, occName) ---------------------------------------------------------------- @@ -66,17 +46,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 @@ -114,319 +83,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 - -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 - -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 - ----------------------------------------------------------------- - -data SplitInfo = SplitInfo G.Name (SrcSpan,Type) (SrcSpan, Type) [SrcSpan] - --- | 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 = withGHC' $ do - initializeFlagsWithCradle opt cradle - splits opt file lineNo colNo - --- | Splitting a variable in a equation. -splits :: Options - -> FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> Ghc String -splits opt file lineNo colNo = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - modSum <- Gap.fileModSummary file - splitInfo <- getSrcSpanTypeForSplit modSum lineNo colNo - case splitInfo of - Nothing -> return "" - Just (SplitInfo varName binding var@(_,varT) matches) -> do - return $ convert opt $ ( toTup dflag style binding - , toTup dflag style var - , (map fourInts matches) - , getTyCons dflag style varName varT) - handler (SomeException _) = return [] - -getSrcSpanTypeForSplit :: G.ModSummary -> Int -> Int -> Ghc (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) :: [G.LMatch G.RdrName (LHsExpr G.RdrName)] - 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" - -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 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 - -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 - -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 - ----------------------------------------------------------------- - -data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) - | InstanceDecl SrcSpan G.Class - --- | 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 = withGHC' $ do - initializeFlagsWithCradle opt cradle - sig opt file lineNo colNo - --- | Splitting a variable in a equation. -sig :: Options - -> FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> Ghc String -sig opt file lineNo colNo = ghandle handler body - where - body = inModuleContext file $ \dflag style -> do - modSum <- Gap.fileModSummary file - sigTy <- getSignature modSum lineNo colNo - case sigTy of - Nothing -> return "" - Just (Signature loc names ty) -> do - return $ convert opt $ ( fourInts loc - , map (initialFnBody dflag style ty) names - ) - Just (InstanceDecl loc cls) -> do - return $ convert opt $ ( fourInts loc - , map (initialInstBody dflag style) (Ty.classMethods cls) - ) - - handler (SomeException _) = return "" - -getSignature :: G.ModSummary -> Int -> Int -> Ghc (Maybe SigInfo) -getSignature modSum lineNo colNo = do - p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum - -- Look into 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)' - [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = - (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] -> - obtainClassInfo minfo clsName loc - -- Instance declarations of sort 'instance F G' (no variables) - [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = - (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] -> - obtainClassInfo minfo clsName loc - _ -> return Nothing - _ -> return Nothing - where obtainClassInfo minfo clsName loc = do - tyThing <- G.modInfoLookupName minfo clsName - case tyThing of - Just (Ty.ATyCon clsCon) -> - case G.tyConClass_maybe clsCon of - Just cls -> return $ Just $ InstanceDecl loc cls - Nothing -> return Nothing - _ -> return Nothing - --- 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 :: 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) - ++ " = _" ++ 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 - -initialFnBody :: DynFlags -> PprStyle -> G.HsType G.RdrName -> G.RdrName -> String -initialFnBody dflag style ty name = - let fname = showOccName dflag style $ occName name -- get function name - args = \case (G.HsForAllTy _ _ _ (L _ iTy)) -> args iTy - (G.HsParTy (L _ iTy)) -> args iTy - (G.HsFunTy (L _ lTy) (L _ rTy)) -> (if fnarg lTy then FnArgFunction else FnArgNormal):args rTy - _ -> [] - fnarg = \case (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy - (G.HsParTy (L _ iTy)) -> fnarg iTy - (G.HsFunTy _ _) -> True - _ -> False - in initialBody fname (args ty) - -initialInstBody :: DynFlags -> PprStyle -> Id -> String -initialInstBody dflag style method = - let fname = showOccName dflag style $ G.getOccName method -- get function name - args = \case ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty -> - case Ty.splitFunTy_maybe lTy of - Just _ -> FnArgFunction:args rTy - Nothing -> -- Drop the class predicates - if Ty.isPredTy lTy then args rTy else FnArgNormal:args rTy - ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty -> args iTy - _ -> [] - in initialBody fname (args (Ty.dropForAlls $ G.idType method)) - -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]) - -isSymbolName :: String -> Bool -isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c -isSymbolName [] = error "This should never happen" diff --git a/Language/Haskell/GhcMod/Rewrite.hs b/Language/Haskell/GhcMod/Rewrite.hs new file mode 100644 index 0000000..db09f88 --- /dev/null +++ b/Language/Haskell/GhcMod/Rewrite.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE LambdaCase #-} + +module Language.Haskell.GhcMod.Rewrite ( + splitVar + , splits + , fillSig + , sig + ) where + +import Data.Char (isSymbol) +import Data.List (find, intercalate) +import Exception (ghandle, SomeException(..)) +import GHC (Ghc, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import qualified GHC as G +import Language.Haskell.GhcMod.Doc (showOneLine) +import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.Gap (HasType(..)) +import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.SrcUtils +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Convert +import Outputable (PprStyle) +import qualified Type as Ty +import qualified TyCon as Ty +import qualified DataCon as Ty +import qualified HsBinds as Ty +import qualified Class as Ty +import OccName (OccName, occName) + +---------------------------------------------------------------- + +data SplitInfo = SplitInfo G.Name (SrcSpan,Type) (SrcSpan, Type) [SrcSpan] + +-- | 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 = withGHC' $ do + initializeFlagsWithCradle opt cradle + splits opt file lineNo colNo + +-- | Splitting a variable in a equation. +splits :: Options + -> FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> Ghc String +splits opt file lineNo colNo = ghandle handler body + where + body = inModuleContext file $ \dflag style -> do + modSum <- Gap.fileModSummary file + splitInfo <- getSrcSpanTypeForSplit modSum lineNo colNo + case splitInfo of + Nothing -> return "" + Just (SplitInfo varName binding var@(_,varT) matches) -> do + return $ convert opt $ ( toTup dflag style binding + , toTup dflag style var + , (map fourInts matches) + , getTyCons dflag style varName varT) + handler (SomeException _) = return [] + +getSrcSpanTypeForSplit :: G.ModSummary -> Int -> Int -> Ghc (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) :: [G.LMatch G.RdrName (LHsExpr G.RdrName)] + 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" + +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 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 + +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 + +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 + +---------------------------------------------------------------- + +data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName) + | InstanceDecl SrcSpan G.Class + +-- | 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 = withGHC' $ do + initializeFlagsWithCradle opt cradle + sig opt file lineNo colNo + +-- | Splitting a variable in a equation. +sig :: Options + -> FilePath -- ^ A target file. + -> Int -- ^ Line number. + -> Int -- ^ Column number. + -> Ghc String +sig opt file lineNo colNo = ghandle handler body + where + body = inModuleContext file $ \dflag style -> do + modSum <- Gap.fileModSummary file + sigTy <- getSignature modSum lineNo colNo + case sigTy of + Nothing -> return "" + Just (Signature loc names ty) -> do + return $ convert opt $ ( fourInts loc + , map (initialFnBody dflag style ty) names + ) + Just (InstanceDecl loc cls) -> do + return $ convert opt $ ( fourInts loc + , map (initialInstBody dflag style) (Ty.classMethods cls) + ) + + handler (SomeException _) = return "" + +getSignature :: G.ModSummary -> Int -> Int -> Ghc (Maybe SigInfo) +getSignature modSum lineNo colNo = do + p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum + -- Look into 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)' + [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = + (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] -> + obtainClassInfo minfo clsName loc + -- Instance declarations of sort 'instance F G' (no variables) + [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = + (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] -> + obtainClassInfo minfo clsName loc + _ -> return Nothing + _ -> return Nothing + where obtainClassInfo minfo clsName loc = do + tyThing <- G.modInfoLookupName minfo clsName + case tyThing of + Just (Ty.ATyCon clsCon) -> + case G.tyConClass_maybe clsCon of + Just cls -> return $ Just $ InstanceDecl loc cls + Nothing -> return Nothing + _ -> return Nothing + +-- 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 :: 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) + ++ " = _" ++ 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 + +initialFnBody :: DynFlags -> PprStyle -> G.HsType G.RdrName -> G.RdrName -> String +initialFnBody dflag style ty name = + let fname = showOccName dflag style $ occName name -- get function name + args = \case (G.HsForAllTy _ _ _ (L _ iTy)) -> args iTy + (G.HsParTy (L _ iTy)) -> args iTy + (G.HsFunTy (L _ lTy) (L _ rTy)) -> (if fnarg lTy then FnArgFunction else FnArgNormal):args rTy + _ -> [] + fnarg = \case (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy + (G.HsParTy (L _ iTy)) -> fnarg iTy + (G.HsFunTy _ _) -> True + _ -> False + in initialBody fname (args ty) + +initialInstBody :: DynFlags -> PprStyle -> Id -> String +initialInstBody dflag style method = + let fname = showOccName dflag style $ G.getOccName method -- get function name + args = \case ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty -> + case Ty.splitFunTy_maybe lTy of + Just _ -> FnArgFunction:args rTy + Nothing -> -- Drop the class predicates + if Ty.isPredTy lTy then args rTy else FnArgNormal:args rTy + ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty -> args iTy + _ -> [] + in initialBody fname (args (Ty.dropForAlls $ G.idType method)) + +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]) + +isSymbolName :: String -> Bool +isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c +isSymbolName [] = error "This should never happen" diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs new file mode 100644 index 0000000..c959500 --- /dev/null +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Language.Haskell.GhcMod.SrcUtils where + +import Control.Applicative ((<$>)) +import CoreMonad (liftIO) +import CoreUtils (exprType) +import Data.Generics +import Data.Maybe (fromMaybe) +import Data.Ord as O +import GHC (Ghc, LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) +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) + +---------------------------------------------------------------- + +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 + +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/ghc-mod.cabal b/ghc-mod.cabal index 7699634..685f521 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -81,6 +81,8 @@ Library Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Read + Language.Haskell.GhcMod.Rewrite + Language.Haskell.GhcMod.SrcUtils Build-Depends: base >= 4.0 && < 5 , containers , deepseq