Initial implementation of case splitting
- It doesn't handle vars correctly yet
This commit is contained in:
parent
1e70c32b39
commit
6854d417c0
@ -27,6 +27,7 @@ module Language.Haskell.GhcMod (
|
|||||||
, rootInfo
|
, rootInfo
|
||||||
, packageDoc
|
, packageDoc
|
||||||
, findSymbol
|
, findSymbol
|
||||||
|
, splitVar
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Language.Haskell.GhcMod.Boot
|
import Language.Haskell.GhcMod.Boot
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-}
|
||||||
|
|
||||||
module Language.Haskell.GhcMod.Convert (convert, convert') where
|
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 . (')' :)
|
toS x = ('(' :) . tupToString opt x . (')' :)
|
||||||
toPlain opt = inter '\n' . map (tupToString opt)
|
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 :: Options -> [String] -> Builder
|
||||||
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
|
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
|
||||||
|
|
||||||
|
@ -23,6 +23,7 @@ module Language.Haskell.GhcMod.Gap (
|
|||||||
, HasType(..)
|
, HasType(..)
|
||||||
, errorMsgSpan
|
, errorMsgSpan
|
||||||
, typeForUser
|
, typeForUser
|
||||||
|
, nameForUser
|
||||||
, deSugar
|
, deSugar
|
||||||
, showDocWith
|
, showDocWith
|
||||||
, GapThing(..)
|
, GapThing(..)
|
||||||
@ -47,6 +48,7 @@ import HscTypes
|
|||||||
import Language.Haskell.GhcMod.GHCChoice
|
import Language.Haskell.GhcMod.GHCChoice
|
||||||
import Language.Haskell.GhcMod.Types
|
import Language.Haskell.GhcMod.Types
|
||||||
import NameSet
|
import NameSet
|
||||||
|
import OccName
|
||||||
import Outputable
|
import Outputable
|
||||||
import PprTyThing
|
import PprTyThing
|
||||||
import StringBuffer
|
import StringBuffer
|
||||||
@ -337,6 +339,13 @@ typeForUser = pprTypeForUser
|
|||||||
typeForUser = pprTypeForUser False
|
typeForUser = pprTypeForUser False
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
nameForUser :: Name -> SDoc
|
||||||
|
#if __GLASGOW_HASKELL__ >= 708
|
||||||
|
nameForUser = pprOccName . getOccName
|
||||||
|
#else
|
||||||
|
nameForUser = pprOccName False . getOccName
|
||||||
|
#endif
|
||||||
|
|
||||||
deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
|
deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv
|
||||||
-> IO (Maybe CoreExpr)
|
-> IO (Maybe CoreExpr)
|
||||||
#if __GLASGOW_HASKELL__ >= 708
|
#if __GLASGOW_HASKELL__ >= 708
|
||||||
|
@ -8,6 +8,7 @@ module Language.Haskell.GhcMod.Ghc (
|
|||||||
, check
|
, check
|
||||||
, info
|
, info
|
||||||
, types
|
, types
|
||||||
|
, splits
|
||||||
, modules
|
, modules
|
||||||
-- * 'SymMdlDb'
|
-- * 'SymMdlDb'
|
||||||
, Symbol
|
, Symbol
|
||||||
|
@ -6,6 +6,8 @@ module Language.Haskell.GhcMod.Info (
|
|||||||
, info
|
, info
|
||||||
, typeExpr
|
, typeExpr
|
||||||
, types
|
, types
|
||||||
|
, splitVar
|
||||||
|
, splits
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
@ -13,7 +15,7 @@ import CoreMonad (liftIO)
|
|||||||
import CoreUtils (exprType)
|
import CoreUtils (exprType)
|
||||||
import Data.Function (on)
|
import Data.Function (on)
|
||||||
import Data.Generics
|
import Data.Generics
|
||||||
import Data.List (sortBy)
|
import Data.List (find, sortBy)
|
||||||
import Data.Maybe (catMaybes, fromMaybe)
|
import Data.Maybe (catMaybes, fromMaybe)
|
||||||
import Data.Ord as O
|
import Data.Ord as O
|
||||||
import Exception (ghandle, SomeException(..))
|
import Exception (ghandle, SomeException(..))
|
||||||
@ -28,6 +30,9 @@ import Language.Haskell.GhcMod.Types
|
|||||||
import Language.Haskell.GhcMod.Convert
|
import Language.Haskell.GhcMod.Convert
|
||||||
import Outputable (PprStyle)
|
import Outputable (PprStyle)
|
||||||
import TcHsSyn (hsPatType)
|
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
|
dflag <- G.getSessionDynFlags
|
||||||
style <- getStyle
|
style <- getStyle
|
||||||
action dflag style
|
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
|
||||||
|
@ -38,6 +38,7 @@ usage = progVersion
|
|||||||
++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n"
|
++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\n"
|
||||||
++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
|
++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
|
||||||
++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
|
++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
|
||||||
|
++ "\t ghc-mod split" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
|
||||||
++ "\t ghc-mod find <symbol>\n"
|
++ "\t ghc-mod find <symbol>\n"
|
||||||
++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
|
++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"
|
||||||
++ "\t ghc-mod root\n"
|
++ "\t ghc-mod root\n"
|
||||||
@ -119,6 +120,7 @@ main = flip E.catches handlers $ do
|
|||||||
"debug" -> debugInfo opt cradle
|
"debug" -> debugInfo opt cradle
|
||||||
"info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3
|
"info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3
|
||||||
"type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4)
|
"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
|
"find" -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1
|
||||||
"lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1
|
"lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1
|
||||||
"root" -> rootInfo opt cradle
|
"root" -> rootInfo opt cradle
|
||||||
|
@ -144,6 +144,7 @@ loop opt set mvar = do
|
|||||||
"lint" -> toGhcMod $ lintStx opt set arg
|
"lint" -> toGhcMod $ lintStx opt set arg
|
||||||
"info" -> toGhcMod $ showInfo opt set arg
|
"info" -> toGhcMod $ showInfo opt set arg
|
||||||
"type" -> toGhcMod $ showType opt set arg
|
"type" -> toGhcMod $ showType opt set arg
|
||||||
|
"split" -> toGhcMod $ doSplit opt set arg
|
||||||
"boot" -> bootIt set
|
"boot" -> bootIt set
|
||||||
"browse" -> browseIt set arg
|
"browse" -> browseIt set arg
|
||||||
"quit" -> return ("quit", False, set)
|
"quit" -> return ("quit", False, set)
|
||||||
@ -254,6 +255,16 @@ showType opt set fileArg = do
|
|||||||
ret <- types opt file (read line) (read column)
|
ret <- types opt file (read line) (read column)
|
||||||
return (ret, True, set')
|
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
|
bootIt :: Set FilePath
|
||||||
|
Loading…
Reference in New Issue
Block a user