Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit 9183cf5

Browse files
JPMoresmauJPMoresmau
committed
Merge pull request #116 from alanz/diff-type
Bring in a diff type, and introduce semantic types
2 parents 8fc4f9e + 2c15ccc commit 9183cf5

File tree

12 files changed

+226
-70
lines changed

12 files changed

+226
-70
lines changed

Diff for: ‎haskell-ide-engine.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -98,6 +98,7 @@ test-suite haskell-ide-test
9898
JsonStdioSpec
9999
JsonSpec
100100
build-depends: base
101+
, Diff
101102
, aeson
102103
, containers
103104
, unordered-containers

Diff for: ‎hie-ghc-mod/Haskell/Ide/GhcModPlugin.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -6,12 +6,12 @@ module Haskell.Ide.GhcModPlugin where
66
import Control.Exception
77
import Data.Either
88
import Data.Vinyl
9-
-- import Control.Monad
109
import Control.Monad.IO.Class
1110
import qualified Data.Text as T
1211
import qualified Data.Text.Read as T
1312
import Haskell.Ide.Engine.PluginDescriptor
1413
import Haskell.Ide.Engine.PluginUtils
14+
import Haskell.Ide.Engine.SemanticTypes
1515
import qualified Language.Haskell.GhcMod as GM
1616
import qualified Language.Haskell.GhcMod.Monad as GM
1717
import System.FilePath

Diff for: ‎hie-hare/Haskell/Ide/HaRePlugin.hs

+29-12
Original file line numberDiff line numberDiff line change
@@ -8,9 +8,11 @@ import qualified Data.Text as T
88
import Data.Vinyl
99
import Haskell.Ide.Engine.PluginDescriptor
1010
import Haskell.Ide.Engine.PluginUtils
11+
import Haskell.Ide.Engine.SemanticTypes
1112
import qualified Language.Haskell.GhcMod as GM (defaultOptions)
1213
import Language.Haskell.Refact.HaRe
1314
import System.Directory
15+
import System.FilePath.Posix
1416

1517
-- ---------------------------------------------------------------------
1618

@@ -59,8 +61,8 @@ demoteCmd = CmdSync $ \_ctxs req -> do
5961
Left err -> return $ IdeResponseFail (IdeError PluginError
6062
(T.pack $ "demote: " ++ show err) Nothing)
6163
Right fs -> do
62-
fs' <- liftIO $ mapM makeRelativeToCurrentDirectory fs
63-
return (IdeResponseOk $ RefactorResult fs')
64+
r <- liftIO $ makeRefactorResult fs
65+
return (IdeResponseOk r)
6466
Right _ -> return $ IdeResponseError (IdeError InternalError
6567
"HaRePlugin.demoteCmd: ghc’s exhaustiveness checker is broken" Nothing)
6668

@@ -78,8 +80,8 @@ dupdefCmd = CmdSync $ \_ctxs req -> do
7880
Left err -> return $ IdeResponseFail (IdeError PluginError
7981
(T.pack $ "dupdef: " ++ show err) Nothing)
8082
Right fs -> do
81-
fs' <- liftIO $ mapM makeRelativeToCurrentDirectory fs
82-
return (IdeResponseOk $ RefactorResult fs')
83+
r <- liftIO $ makeRefactorResult fs
84+
return (IdeResponseOk r)
8385
Right _ -> return $ IdeResponseError (IdeError InternalError
8486
"HaRePlugin.dupdefCmd: ghc’s exhaustiveness checker is broken" Nothing)
8587

@@ -97,8 +99,8 @@ iftocaseCmd = CmdSync $ \_ctxs req -> do
9799
Left err -> return $ IdeResponseFail (IdeError PluginError
98100
(T.pack $ "ifToCase: " ++ show err) Nothing)
99101
Right fs -> do
100-
fs' <- liftIO $ mapM makeRelativeToCurrentDirectory fs
101-
return (IdeResponseOk $ RefactorResult fs')
102+
r <- liftIO $ makeRefactorResult fs
103+
return (IdeResponseOk r)
102104
Right _ -> return $ IdeResponseError (IdeError InternalError
103105
"HaRePlugin.ifToCaseCmd: ghc’s exhaustiveness checker is broken" Nothing)
104106

@@ -116,8 +118,8 @@ liftonelevelCmd = CmdSync $ \_ctxs req -> do
116118
Left err -> return $ IdeResponseFail (IdeError PluginError
117119
(T.pack $ "liftOneLevel: " ++ show err) Nothing)
118120
Right fs -> do
119-
fs' <- liftIO $ mapM makeRelativeToCurrentDirectory fs
120-
return (IdeResponseOk $ RefactorResult fs')
121+
r <- liftIO $ makeRefactorResult fs
122+
return (IdeResponseOk r)
121123
Right _ -> return $ IdeResponseError (IdeError InternalError
122124
"HaRePlugin.liftOneLevel: ghc’s exhaustiveness checker is broken" Nothing)
123125

@@ -135,8 +137,8 @@ lifttotoplevelCmd = CmdSync $ \_ctxs req -> do
135137
Left err -> return $ IdeResponseFail (IdeError PluginError
136138
(T.pack $ "liftToTopLevel: " ++ show err) Nothing)
137139
Right fs -> do
138-
fs' <- liftIO $ mapM makeRelativeToCurrentDirectory fs
139-
return (IdeResponseOk $ RefactorResult fs')
140+
r <- liftIO $ makeRefactorResult fs
141+
return (IdeResponseOk r)
140142
Right _ -> return $ IdeResponseError (IdeError InternalError
141143
"HaRePlugin.liftToTopLevel: ghc’s exhaustiveness checker is broken" Nothing)
142144

@@ -154,15 +156,30 @@ renameCmd = CmdSync $ \_ctxs req -> do
154156
Left err -> return $ IdeResponseFail (IdeError PluginError
155157
(T.pack $ "rename: " ++ show err) Nothing)
156158
Right fs -> do
157-
fs' <- liftIO $ mapM makeRelativeToCurrentDirectory fs
158-
return (IdeResponseOk $ RefactorResult fs')
159+
r <- liftIO $ makeRefactorResult fs
160+
return (IdeResponseOk r)
159161
Right _ -> return $ IdeResponseError (IdeError InternalError
160162
"HaRePlugin.renameCmd: ghc’s exhaustiveness checker is broken" Nothing)
161163

162164
-- rename :: RefactSettings -> Options -> FilePath -> String -> SimpPos -> IO [FilePath]
163165

164166
-- ---------------------------------------------------------------------
165167

168+
makeRefactorResult :: [FilePath] -> IO RefactorResult
169+
makeRefactorResult changedFiles = do
170+
let
171+
diffOne f1 = do
172+
let (baseFileName,ext) = splitExtension f1
173+
f2 = (baseFileName ++ ".refactored" ++ ext)
174+
(HieDiff f s d) <- diffFiles f1 f2
175+
f' <- liftIO $ makeRelativeToCurrentDirectory f
176+
s' <- liftIO $ makeRelativeToCurrentDirectory s
177+
return (HieDiff f' s' d)
178+
diffs <- mapM diffOne changedFiles
179+
return (RefactorResult diffs)
180+
181+
-- ---------------------------------------------------------------------
182+
166183
catchException :: (IO t) -> IO (Either String t)
167184
catchException f = do
168185
res <- handle handler (f >>= \r -> return $ Right r)

Diff for: ‎hie-hare/hie-hare.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ library
1818
, aeson
1919
, containers
2020
, directory
21+
, filepath
2122
, ghc-mod
2223
, hie-plugin-api
2324
, text

Diff for: ‎hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs

-41
Original file line numberDiff line numberDiff line change
@@ -305,25 +305,6 @@ type SyncCommandFunc resp = forall m. (MonadIO m,GHC.GhcMonad m,HasIdeState m)
305305
type AsyncCommandFunc resp = forall m. (MonadIO m,GHC.GhcMonad m,HasIdeState m)
306306
=> (IdeResponse resp -> IO ()) -> [AcceptedContext] -> IdeRequest -> m ()
307307

308-
-- ---------------------------------------------------------------------
309-
-- Specific response type
310-
311-
-- | Type Information, from the most precise to the most generic
312-
data TypeInfo = TypeInfo { results :: [TypeResult] }
313-
deriving (Show,Read,Eq,Ord,Generic)
314-
315-
-- | One type result from ghc-mod
316-
data TypeResult = TypeResult
317-
{ trStart :: (Int,Int) -- ^ start line/column
318-
, trEnd :: (Int,Int) -- ^ end line/column
319-
, trText :: T.Text -- ^ type text
320-
} deriving (Show,Read,Eq,Ord,Generic)
321-
322-
-- | Result of refactoring
323-
data RefactorResult = RefactorResult
324-
{ rrPaths :: [FilePath]
325-
} deriving (Show,Read,Eq,Ord,Generic)
326-
327308
-- ---------------------------------------------------------------------
328309
-- ValidResponse instances
329310

@@ -396,14 +377,6 @@ instance ValidResponse IdePlugins where
396377
p<-parseJSON vp
397378
return (k,p)) $ H.toList ps
398379

399-
instance ValidResponse TypeInfo where
400-
jsWrite (TypeInfo t) = H.fromList ["type_info" .= t]
401-
jsRead v = TypeInfo <$> v .: "type_info"
402-
403-
instance ValidResponse RefactorResult where
404-
jsWrite (RefactorResult t) = H.fromList ["refactor" .= t]
405-
jsRead v = RefactorResult <$> v .: "refactor"
406-
407380
-- ---------------------------------------------------------------------
408381
-- JSON instances
409382

@@ -547,20 +520,6 @@ instance FromJSON IdeError where
547520
<*> v .:? "info"
548521
parseJSON _ = empty
549522

550-
instance ToJSON TypeResult where
551-
toJSON (TypeResult s e t) =
552-
object [ "start" .= posToJSON s
553-
, "end" .= posToJSON e
554-
, "type" .= t
555-
]
556-
557-
instance FromJSON TypeResult where
558-
parseJSON (Object v) = TypeResult
559-
<$> (jsonToPos =<< (v .: "start"))
560-
<*> (jsonToPos =<< (v .: "end"))
561-
<*> v .: "type"
562-
parseJSON _ = empty
563-
564523
-- -------------------------------------
565524

566525
instance (ValidResponse a) => ToJSON (IdeResponse a) where

Diff for: ‎hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs

+23-3
Original file line numberDiff line numberDiff line change
@@ -7,17 +7,21 @@ module Haskell.Ide.Engine.PluginUtils
77
(
88
getParams
99
, mapEithers
10+
, diffFiles
11+
-- * Helper functions for errors
1012
, missingParameter
1113
, incorrectParameter
1214
) where
1315

1416
import Data.Aeson
15-
17+
import Data.Algorithm.Diff
1618
import Data.Monoid
1719
import Data.Vinyl
1820
import Haskell.Ide.Engine.PluginDescriptor
21+
import Haskell.Ide.Engine.SemanticTypes
1922
import qualified Data.Map as Map
2023
import qualified Data.Text as T
24+
import qualified Data.Text.IO as T
2125
import Prelude hiding (log)
2226

2327
-- ---------------------------------------------------------------------
@@ -64,13 +68,13 @@ mapEithers _ _ = Right []
6468
-- ---------------------------------------------------------------------
6569
-- Helper functions for errors
6670

67-
-- Missing parameter error
71+
-- |Missing parameter error
6872
missingParameter :: forall r. (ValidResponse r) => ParamId -> IdeResponse r
6973
missingParameter param = IdeResponseFail (IdeError MissingParameter
7074
("need `" <> param <> "` parameter")
7175
(Just $ toJSON param))
7276

73-
-- Incorrect parameter error
77+
-- |Incorrect parameter error
7478
incorrectParameter :: forall r a b. (ValidResponse r,Show a,Show b)
7579
=> ParamId -> a -> b -> IdeResponse r
7680
incorrectParameter name expected value = IdeResponseFail
@@ -79,3 +83,19 @@ incorrectParameter name expected value = IdeResponseFail
7983
T.pack (show expected) <>" , got:" <> T.pack (show value))
8084
(Just $ object ["param" .= toJSON name,"expected".= toJSON (show expected),
8185
"value" .= toJSON (show value)]))
86+
87+
-- ---------------------------------------------------------------------
88+
89+
-- |Generate a 'HieDiff' value from a pair of files
90+
diffFiles :: FilePath -> FilePath -> IO HieDiff
91+
diffFiles f1 f2 = do
92+
f1Text <- T.readFile f1
93+
f2Text <- T.readFile f2
94+
let diffb = getDiffBy (\(_,a) (_,b) -> a == b)
95+
(zip [1..] (T.lines f1Text))
96+
(zip [1..] (T.lines f2Text))
97+
isDiff (Both {}) = False
98+
isDiff _ = True
99+
100+
diff = filter isDiff diffb
101+
return (HieDiff f1 f2 diff)

Diff for: ‎hie-plugin-api/Haskell/Ide/Engine/SemanticTypes.hs

+101
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,101 @@
1+
{-# LANGUAGE DeriveGeneric #-}
2+
{-# LANGUAGE FlexibleInstances #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
{-# OPTIONS_GHC -fno-warn-orphans #-}
5+
module Haskell.Ide.Engine.SemanticTypes where
6+
7+
import Control.Applicative
8+
import Data.Aeson
9+
import Data.Algorithm.Diff
10+
import qualified Data.HashMap.Strict as H
11+
import qualified Data.Text as T
12+
import GHC.Generics
13+
import Haskell.Ide.Engine.PluginDescriptor
14+
15+
-- ---------------------------------------------------------------------
16+
-- Specific response type
17+
18+
-- | Type Information, from the most precise to the most generic
19+
data TypeInfo = TypeInfo { results :: [TypeResult] }
20+
deriving (Show,Read,Eq,Ord,Generic)
21+
22+
-- | One type result from ghc-mod
23+
data TypeResult = TypeResult
24+
{ trStart :: (Int,Int) -- ^ start line/column
25+
, trEnd :: (Int,Int) -- ^ end line/column
26+
, trText :: T.Text -- ^ type text
27+
} deriving (Show,Read,Eq,Ord,Generic)
28+
29+
-- | Result of refactoring
30+
data RefactorResult = RefactorResult
31+
{ rrDiffs :: [HieDiff]
32+
} deriving (Show,Eq,Generic)
33+
34+
-- ---------------------------------------------------------------------
35+
36+
-- | A diff between two files, typically the first one will be the one from the
37+
-- IDE, the second from the tool
38+
data HieDiff = HieDiff
39+
{ dFirst :: !FilePath
40+
, dSecond :: !FilePath
41+
, dDiff :: ![Diff (Int,T.Text)]
42+
} deriving (Show,Eq,Generic)
43+
44+
-- ---------------------------------------------------------------------
45+
-- JSON instances
46+
47+
instance ValidResponse TypeInfo where
48+
jsWrite (TypeInfo t) = H.fromList ["type_info" .= t]
49+
jsRead v = TypeInfo <$> v .: "type_info"
50+
51+
instance ToJSON TypeResult where
52+
toJSON (TypeResult s e t) =
53+
object [ "start" .= posToJSON s
54+
, "end" .= posToJSON e
55+
, "type" .= t
56+
]
57+
58+
instance FromJSON TypeResult where
59+
parseJSON (Object v) = TypeResult
60+
<$> (jsonToPos =<< (v .: "start"))
61+
<*> (jsonToPos =<< (v .: "end"))
62+
<*> v .: "type"
63+
parseJSON _ = empty
64+
65+
-- ---------------------------------------------------------------------
66+
67+
instance ValidResponse RefactorResult where
68+
jsWrite (RefactorResult t) = H.fromList ["refactor" .= t]
69+
jsRead v = RefactorResult <$> v .: "refactor"
70+
71+
instance ToJSON HieDiff where
72+
toJSON (HieDiff f s d) =
73+
object [ "first" .= toJSON f
74+
, "second" .= toJSON s
75+
, "diff" .= toJSON d
76+
]
77+
78+
instance FromJSON HieDiff where
79+
parseJSON (Object v) = HieDiff
80+
<$> (v .: "first")
81+
<*> (v .: "second")
82+
<*> (v .: "type")
83+
parseJSON _ = empty
84+
85+
instance ToJSON (Diff (Int,T.Text)) where
86+
toJSON (First v) = object [ "f" .= toJSON v ]
87+
toJSON (Second v) = object [ "s" .= toJSON v ]
88+
toJSON (Both v1 v2) = object [ "b" .= toJSON [ v1, v2 ] ]
89+
90+
instance FromJSON (Diff (Int,T.Text)) where
91+
parseJSON (Object v) = do
92+
mf <- fmap First <$> v .:? "f"
93+
ms <- fmap Second <$> v .:? "s"
94+
mbv <- v .:? "b"
95+
mb <- case mbv of
96+
Just [v1,v2] -> return $ Just (Both v1 v2)
97+
_ -> empty
98+
case mf <|> ms <|> mb of
99+
Just d -> return d
100+
_ -> empty
101+
parseJSON _ = empty

Diff for: ‎hie-plugin-api/hie-plugin-api.cabal

+3-1
Original file line numberDiff line numberDiff line change
@@ -14,13 +14,15 @@ cabal-version: >=1.10
1414
library
1515
exposed-modules: Haskell.Ide.Engine.PluginUtils
1616
Haskell.Ide.Engine.PluginDescriptor
17+
Haskell.Ide.Engine.SemanticTypes
1718
build-depends: base >= 4.7 && < 5
19+
, Diff
1820
, aeson
1921
, containers
20-
, unordered-containers
2122
, ghc
2223
, text
2324
, transformers
25+
, unordered-containers
2426
, vinyl >= 0.5 && < 0.6
2527
ghc-options: -Wall
2628
default-language: Haskell2010

Diff for: ‎stack.yaml

+1-3
Original file line numberDiff line numberDiff line change
@@ -8,9 +8,7 @@ packages:
88
- hie-ghc-mod
99
- hie-hare
1010
extra-deps:
11-
- logging-3.0.2
1211
- HaRe-0.8.2.1
12+
- logging-3.0.2
1313
- rosezipper-0.2
1414
- syz-0.2.0.0
15-
# - ghc-mod-5.4.0.0
16-
# - cabal-helper-0.6.1.0

Diff for: ‎test/GhcModPluginSpec.hs

+1
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import qualified Data.HashMap.Strict as H
99
import Haskell.Ide.Engine.Dispatcher
1010
import Haskell.Ide.Engine.Monad
1111
import Haskell.Ide.Engine.PluginDescriptor
12+
import Haskell.Ide.Engine.SemanticTypes
1213
import Haskell.Ide.Engine.Types
1314
import Haskell.Ide.GhcModPlugin
1415

0 commit comments

Comments
 (0)