hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial implementation of case splitting

Browse Source 
- It doesn't handle vars correctly yet
This commit is contained in:
Alejandro Serrano 2014-06-08 12:33:13 +02:00
parent 1e70c32b39
commit 6854d417c0
7 changed files with 132 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Language/Haskell/GhcMod.hs
View File

@ -27,6 +27,7 @@ module Language.Haskell.GhcMod (
, rootInfo
, packageDoc
, findSymbol
, splitVar
) where
import Language.Haskell.GhcMod.Boot

14
Language/Haskell/GhcMod/Convert.hs
View File

@ -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) . (')' :)

9
Language/Haskell/GhcMod/Gap.hs
View File

@ -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

1
Language/Haskell/GhcMod/Ghc.hs
View File

@ -8,6 +8,7 @@ module Language.Haskell.GhcMod.Ghc (
, check
, info
, types
, splits
, modules
-- * 'SymMdlDb'
, Symbol

96
Language/Haskell/GhcMod/Info.hs
View File

@ -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

2
src/GHCMod.hs
View File

@ -38,6 +38,7 @@ usage = progVersion
++ "\t ghc-mod debug" ++ ghcOptHelp ++ "\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 split" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
++ "\t ghc-mod find <symbol>\n"
++ "\t ghc-mod lint [-h opt] <HaskellFile>\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

11
src/GHCModi.hs
View File

@ -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