From 6854d417c020458fa3636dec487266125b28b4bd Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Sun, 8 Jun 2014 12:33:13 +0200 Subject: [PATCH] Initial implementation of case splitting - It doesn't handle vars correctly yet --- Language/Haskell/GhcMod.hs | 1 + Language/Haskell/GhcMod/Convert.hs | 14 ++++- Language/Haskell/GhcMod/Gap.hs | 9 +++ Language/Haskell/GhcMod/Ghc.hs | 1 + Language/Haskell/GhcMod/Info.hs | 96 +++++++++++++++++++++++++++++- src/GHCMod.hs | 2 + src/GHCModi.hs | 11 ++++ 7 files changed, 132 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 0ce414d..b536024 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -27,6 +27,7 @@ module Language.Haskell.GhcMod ( , rootInfo , packageDoc , findSymbol + , splitVar ) where import Language.Haskell.GhcMod.Boot diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index 4a422ce..6683e88 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-} module Language.Haskell.GhcMod.Convert (convert, convert') where @@ -76,6 +76,18 @@ 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 a, ToString b) => ToString (a,b) where + toLisp opt (x,y) = toSexp2 $ [toLisp opt x, toLisp opt y] + toPlain opt (x,y) = inter '\n' [toPlain opt x, toPlain opt y] + +instance (ToString a, ToString b, ToString c) => ToString (a,b,c) where + toLisp opt (x,y,z) = toSexp2 $ [toLisp opt x, toLisp opt y, toLisp opt z] + toPlain opt (x,y,z) = inter '\n' [toPlain opt x, toPlain opt y, toPlain opt z] + toSexp1 :: Options -> [String] -> Builder toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 03d9c9b..a5a2613 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -23,6 +23,7 @@ module Language.Haskell.GhcMod.Gap ( , HasType(..) , errorMsgSpan , typeForUser + , nameForUser , deSugar , showDocWith , GapThing(..) @@ -47,6 +48,7 @@ import HscTypes import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Types import NameSet +import OccName import Outputable import PprTyThing import StringBuffer @@ -337,6 +339,13 @@ typeForUser = pprTypeForUser typeForUser = pprTypeForUser False #endif +nameForUser :: Name -> SDoc +#if __GLASGOW_HASKELL__ >= 708 +nameForUser = pprOccName . getOccName +#else +nameForUser = pprOccName False . getOccName +#endif + 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..476b95f 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -8,6 +8,7 @@ module Language.Haskell.GhcMod.Ghc ( , check , info , types + , splits , modules -- * 'SymMdlDb' , Symbol diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 0159fa5..e383e58 100644 --- a/Language/Haskell/GhcMod/Info.hs +++ b/Language/Haskell/GhcMod/Info.hs @@ -6,6 +6,8 @@ module Language.Haskell.GhcMod.Info ( , info , typeExpr , types + , splitVar + , splits ) where import Control.Applicative ((<$>)) @@ -13,7 +15,7 @@ import CoreMonad (liftIO) import CoreUtils (exprType) import Data.Function (on) import Data.Generics -import Data.List (sortBy) +import Data.List (find, sortBy) import Data.Maybe (catMaybes, fromMaybe) import Data.Ord as O import Exception (ghandle, SomeException(..)) @@ -28,6 +30,9 @@ 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 ---------------------------------------------------------------- @@ -136,3 +141,92 @@ inModuleContext file action = dflag <- G.getSessionDynFlags style <- getStyle action dflag style + +---------------------------------------------------------------- + +data SplitInfo = SplitInfo (SrcSpan, Type) (SrcSpan, Type) + +-- | 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 var@(_,varT) eq) -> do + return $ convert opt $ (toTup dflag style var, toTup dflag style eq, getTyCons dflag style varT) + handler (SomeException _) = return [] + +getSrcSpanTypeForSplit :: G.ModSummary -> Int -> Int -> Ghc (Maybe SplitInfo) +getSrcSpanTypeForSplit modSum lineNo colNo = do + p <- G.parseModule modSum + tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p + let bs:_ = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] + ps = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) + case ps of + Nothing -> return Nothing + Just ps' -> do bts <- getType tcm bs + pts <- getType tcm ps' + case (bts, pts) of + (Just bI, Just pI) -> return $ Just (SplitInfo pI bI) + _ -> return Nothing + +isPatternVar :: LPat Id -> Bool +isPatternVar (L _ (G.VarPat _)) = True +isPatternVar _ = False + +getTyCons :: DynFlags -> PprStyle -> G.Type -> [String] +getTyCons dflag style ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = + map (getTyCon dflag style) (Ty.tyConDataCons tyCon) +getTyCons _ _ _ = ["v"] + +getTyCon :: DynFlags -> PprStyle -> Ty.DataCon -> String +getTyCon dflag style dcon = + let name = showName dflag style $ Ty.dataConName dcon + in if Ty.dataConIsInfix dcon + then -- We have an infix constructor + case Ty.dataConSourceArity dcon of + 0 -> name + 1 -> "v " ++ name + n -> "v " ++ name ++ " " ++ newVars (n-1) + else case Ty.dataConFieldLabels dcon of + [] -> -- We have a non-record constructor + name ++ " " ++ newVars (Ty.dataConSourceArity dcon) + flds -> -- We have a record constructor + name ++ " { " ++ showFieldNames dflag style flds ++ " }" + + +newVar :: String +newVar = "v" + +newVars :: Int -> String +newVars 0 = "" +newVars 1 = newVar +newVars n = newVar ++ " " ++ newVars (n-1) ++ " " ++ newVar + +showName :: DynFlags -> PprStyle -> G.Name -> String +showName dflag style name = showOneLine dflag style $ Gap.nameForUser name + +showFieldNames :: DynFlags -> PprStyle -> [G.Name] -> String +showFieldNames _ _ [] = "" -- This should never happen +showFieldNames dflag style [first] = let f = showName dflag style first + in f ++ " = " ++ f +showFieldNames dflag style (x:xs) = let f = showName dflag style x + in f ++ " = " ++ f ++ ", " ++ showFieldNames dflag style xs diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 14ab61e..8fda9b6 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -38,6 +38,7 @@ 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 find \n" ++ "\t ghc-mod lint [-h opt] \n" ++ "\t ghc-mod root\n" @@ -119,6 +120,7 @@ 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) "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..664c1b7 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -144,6 +144,7 @@ loop opt set mvar = do "lint" -> toGhcMod $ lintStx opt set arg "info" -> toGhcMod $ showInfo opt set arg "type" -> toGhcMod $ showType opt set arg + "split" -> toGhcMod $ doSplit opt set arg "boot" -> bootIt set "browse" -> browseIt set arg "quit" -> return ("quit", False, set) @@ -254,6 +255,16 @@ showType opt set fileArg = do ret <- types opt file (read line) (read column) return (ret, True, set') +doSplit :: Options + -> Set FilePath + -> FilePath + -> Ghc (String, Bool, Set FilePath) +doSplit opt set fileArg = do + let [file, line, column] = words fileArg + set' <- newFileSet set file + ret <- splits opt file (read line) (read column) + return (ret, True, set') + ---------------------------------------------------------------- bootIt :: Set FilePath