Haskell part of case splitting working!
This commit is contained in:
Alejandro Serrano
parent
5fa536714f
commit
40cd5b7deb
|
|
@ -84,24 +84,6 @@ 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]
|
||||
|
||||
instance ToString [(Int,Int,Int,Int)] where
|
||||
toLisp opt = toSexp2 . map toS
|
||||
where
|
||||
toS x = ('(' :) . fourIntsToString opt x . (')' :)
|
||||
toPlain opt = inter '\n' . map (fourIntsToString opt)
|
||||
|
||||
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]
|
||||
|
||||
instance (ToString a, ToString b, ToString c, ToString d) => ToString (a,b,c,d) where
|
||||
toLisp opt (x,y,z,t) = toSexp2 $ [toLisp opt x, toLisp opt y, toLisp opt z, toLisp opt t]
|
||||
toPlain opt (x,y,z,t) = inter '\n' [toPlain opt x, toPlain opt y, toPlain opt z, toPlain opt t]
|
||||
|
||||
toSexp1 :: Options -> [String] -> Builder
|
||||
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase, RecordWildCards #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Rewrite (
|
||||
splitVar
|
||||
|
|
@ -9,6 +9,8 @@ module Language.Haskell.GhcMod.Rewrite (
|
|||
|
||||
import Data.Char (isSymbol)
|
||||
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 (Ghc, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
|
||||
import qualified GHC as G
|
||||
|
|
@ -29,11 +31,15 @@ import qualified Class as Ty
|
|||
import OccName (OccName, occName)
|
||||
import qualified Language.Haskell.Exts.Annotated as HE
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data SplitInfo = SplitInfo G.Name (SrcSpan,Type) (SrcSpan, Type) [SrcSpan]
|
||||
data SplitToTextInfo = SplitToTextInfo { sVarName :: String
|
||||
, sBindingSpan :: SrcSpan
|
||||
, sVarSpan :: SrcSpan
|
||||
, sMatchesSpan :: [SrcSpan]
|
||||
, sTycons :: [String]
|
||||
}
|
||||
|
||||
-- | Splitting a variable in a equation.
|
||||
splitVar :: Options
|
||||
|
|
@ -59,11 +65,12 @@ splits opt file lineNo colNo = ghandle handler body
|
|||
splitInfo <- getSrcSpanTypeForSplit modSum lineNo colNo
|
||||
case splitInfo of
|
||||
Nothing -> return $ convert opt ([] :: [String])
|
||||
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)
|
||||
Just (SplitInfo varName (bndLoc,_) (varLoc,varT) matches) -> do
|
||||
let varName' = showName dflag style varName -- Convert name to string
|
||||
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc matches $
|
||||
getTyCons dflag style varName varT)
|
||||
return $ convert opt $ ( fourInts bndLoc
|
||||
, text)
|
||||
handler (SomeException _) = return $ convert opt ([] :: [String])
|
||||
|
||||
getSrcSpanTypeForSplit :: G.ModSummary -> Int -> Int -> Ghc (Maybe SplitInfo)
|
||||
|
|
@ -92,6 +99,8 @@ 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
|
||||
|
|
@ -136,7 +145,9 @@ 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)
|
||||
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
|
||||
|
|
@ -175,6 +186,49 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
|
|||
|
||||
----------------------------------------------------------------
|
||||
|
||||
genCaseSplitTextFile :: FilePath -> SplitToTextInfo -> Ghc String
|
||||
genCaseSplitTextFile file info = liftIO $ do
|
||||
text <- T.readFile file
|
||||
return $ getCaseSplitText (T.lines text) info
|
||||
|
||||
getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
|
||||
getCaseSplitText text (SplitToTextInfo { .. }) =
|
||||
let bindingText = getBindingText text sBindingSpan
|
||||
difference = srcSpanDifference sBindingSpan sVarSpan
|
||||
replaced = concatMap (replaceVarWithTyCon bindingText difference sVarName) sTycons
|
||||
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
|
||||
----------------------------------------------------------------
|
||||
|
||||
data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
|
||||
| InstanceDecl SrcSpan G.Class
|
||||
|
||||
|
|
|
|||
|
|
@ -103,6 +103,7 @@ Library
|
|||
, monad-control
|
||||
, split
|
||||
, haskell-src-exts
|
||||
, text
|
||||
if impl(ghc < 7.7)
|
||||
Build-Depends: convertible
|
||||
, Cabal >= 1.10 && < 1.17
|
||||
|
|
|
|||
Loading…
Reference in New Issue