packages feed

haskell-tools-demo 0.4.1.1 → 0.4.1.2

raw patch · 5 files changed

+50/−55 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

exe/Main.hs view
@@ -2,4 +2,5 @@ 
 import Language.Haskell.Tools.Demo
 
+main :: IO ()
 main = runFromCLI
haskell-tools-demo.cabal view
@@ -1,5 +1,5 @@ name:                haskell-tools-demo
-version:             0.4.1.1
+version:             0.4.1.2
 synopsis:            A web-based demo for Haskell-tools Refactor. 
 description:         Allows websocket clients to connect and performs refactorings on demand. The clients maintain a continous connection with the server, sending changes in the source files. When a refactor request is received, it performs the changes and sends the modified source files to the client.
 homepage:            https://github.com/haskell-tools/haskell-tools
src/Language/Haskell/Tools/ASTDebug.hs view
@@ -16,27 +16,23 @@ -- | A module for displaying the AST in a tree view.
 module Language.Haskell.Tools.ASTDebug where
 
-import GHC.Generics
 import Control.Reference
-import Control.Applicative
-import Data.Sequence as Seq
 import Data.Foldable
-import Data.Maybe
 import Data.List as List
-import SrcLoc
+import Data.Maybe
+import Data.Sequence as Seq
+import GHC.Generics
 import Outputable
+import SrcLoc
 
 import DynFlags as GHC
-import Name as GHC
 import Id as GHC
+import Name as GHC
 import RdrName as GHC
-import Unique as GHC
 import Type as GHC
+import Unique as GHC
 
 import Language.Haskell.Tools.AST
-import Language.Haskell.Tools.AST.FromGHC
-import Language.Haskell.Tools.Transform
---import Language.Haskell.Tools.Refactor.RangeDebug
 import Language.Haskell.Tools.AST.SemaInfoTypes
 
 
@@ -97,6 +93,7 @@                            []         -> Seq.empty
           debugTreeNode (TreeNode "" s) = astDebugElemJson s
           debugTreeNode (TreeNode (dropWhile (=='_') -> l) s) = astDebugElemJson (nodeName .- (("<span class='astlab'>" ++ l ++ "</span>: ") ++) $ s)
+          debugTreeNode (SimpleNode {}) = error "debugTreeNode: simple SimpleNode not allowed"
 
 astDebugElemJson :: AssocSema dom => TreeDebugNode dom -> Seq Char
 astDebugElemJson (TreeDebugNode name info children) 
@@ -119,14 +116,14 @@   toAssoc :: a -> [(String, String)]
 
 instance AssocSema dom => AssocData (SemanticInfoType dom) where
-  assocName s@(DefaultInfoType {}) = "NoSemanticInfo"
+  assocName (DefaultInfoType {}) = "NoSemanticInfo"
   assocName s@(NameInfoType {}) = assocName (semaInfoTypeName s)
   assocName s@(ExprInfoType {}) = assocName (semaInfoTypeExpr s)
   assocName s@(ImportInfoType {}) = assocName (semaInfoTypeImport s)
   assocName s@(ModuleInfoType {}) = assocName (semaInfoTypeModule s)
   assocName s@(ImplicitFieldInfoType {}) = assocName (semaInfoTypeImplicitFld s)
 
-  toAssoc s@(DefaultInfoType {}) = []
+  toAssoc (DefaultInfoType {}) = []
   toAssoc s@(NameInfoType {}) = toAssoc (semaInfoTypeName s)
   toAssoc s@(ExprInfoType {}) = toAssoc (semaInfoTypeExpr s)
   toAssoc s@(ImportInfoType {}) = toAssoc (semaInfoTypeImport s)
@@ -135,11 +132,11 @@ 
 
 instance AssocData ScopeInfo where
-  assocName si = "ScopeInfo"
+  assocName _ = "ScopeInfo"
   toAssoc si = [ ("namesInScope", inspectScope (semanticsScope si)) ]
 
 instance HasNameInfo' (NameInfo n) => AssocData (NameInfo n) where
-  assocName si = "NameInfo"
+  assocName _ = "NameInfo"
 
   toAssoc ni = [ ("name", maybe "<ambiguous>" inspect (semanticsName ni))
                , ("isDefined", show (semanticsDefining ni))
@@ -154,14 +151,14 @@                , ("namesInScope", inspectScope (semanticsScope ni)) 
                ]
 
-instance (HasModuleInfo' (ModuleInfo n), InspectableName n) => AssocData (ModuleInfo n) where
+instance (HasModuleInfo' (ModuleInfo n)) => AssocData (ModuleInfo n) where
   assocName _ = "ModuleInfo"
   toAssoc mi = [ ("moduleName", showSDocUnsafe (ppr (semanticsModule mi)))
                , ("isBoot", show (isBootModule mi))
                , ("implicitImports", concat (intersperse ", " (map inspect (semanticsImplicitImports mi))))
                ]
   
-instance (HasImportInfo' (ImportInfo n), InspectableName n) => AssocData (ImportInfo n) where
+instance (HasImportInfo' (ImportInfo n)) => AssocData (ImportInfo n) where
   assocName _ = "ImportInfo"
   toAssoc ii = [ ("moduleName", showSDocUnsafe (ppr (semanticsImportedModule ii))) 
                , ("availableNames", concat (intersperse ", " (map inspect (semanticsAvailable ii))))
src/Language/Haskell/Tools/ASTDebug/Instances.hs view
@@ -10,8 +10,8 @@ 
 import Language.Haskell.Tools.ASTDebug
 
-import GHC.Generics
 import Control.Reference
+import GHC.Generics (Generic(..))
 
 import Language.Haskell.Tools.AST
 
@@ -55,6 +55,7 @@ instance (Domain dom, SourceInfo st) => ASTDebug UFilePragma dom st
 instance (Domain dom, SourceInfo st) => ASTDebug UImportDecl dom st
 instance (Domain dom, SourceInfo st) => ASTDebug UImportSpec dom st
+instance (Domain dom, SourceInfo st) => ASTDebug UImportModifier dom st
 instance (Domain dom, SourceInfo st) => ASTDebug UImportQualified dom st
 instance (Domain dom, SourceInfo st) => ASTDebug UImportSource dom st
 instance (Domain dom, SourceInfo st) => ASTDebug UImportSafe dom st
src/Language/Haskell/Tools/Demo.hs view
@@ -11,52 +11,48 @@ 
 module Language.Haskell.Tools.Demo where
 
-import Network.WebSockets
-import Network.Wai.Handler.WebSockets
-import Network.Wai.Handler.Warp
-import Network.Wai
-import Network.HTTP.Types
+import Control.Concurrent.MVar
 import Control.Exception
+import Control.Monad
+import Control.Monad.State
 import Data.Aeson hiding ((.=))
-import Data.Map (Map, (!), member, insert)
-import qualified Data.Map as Map
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as BS
-import GHC.Generics
-
-import System.IO
-import System.IO.Error
-import System.FilePath
-import System.Directory
 import Data.IORef
 import Data.List hiding (insert)
-import Data.Tuple
+import qualified Data.Map as Map
 import Data.Maybe
-import Control.Monad
-import Control.Monad.State
-import Control.Concurrent.MVar
-import Control.Monad.IO.Class
+import Data.Tuple
+import GHC.Generics
+import Network.HTTP.Types
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.Wai.Handler.WebSockets
+import Network.WebSockets
+import System.Directory
 import System.Environment
+import System.FilePath
+import System.IO
+import System.IO.Error
 
-import GHC hiding (loadModule)
 import Bag (bagToList)
-import SrcLoc (realSrcSpanStart)
 import ErrUtils (errMsgSpan)
-import DynFlags (gopt_set)
+import FastString (unpackFS)
+import GHC hiding (loadModule)
 import GHC.Paths ( libdir )
 import GhcMonad (GhcMonad(..), Session(..), reflectGhc)
 import HscTypes (SourceError, srcErrorMessages)
-import FastString (unpackFS)
+import SrcLoc (realSrcSpanStart)
 
 import Control.Reference
 
 import Language.Haskell.Tools.AST
-import Language.Haskell.Tools.Refactor.Prepare
-import Language.Haskell.Tools.Refactor.Perform
-import Language.Haskell.Tools.Refactor.RefactorBase
 import Language.Haskell.Tools.ASTDebug
-import Language.Haskell.Tools.ASTDebug.Instances
+import Language.Haskell.Tools.ASTDebug.Instances ()
 import Language.Haskell.Tools.PrettyPrint
+import Language.Haskell.Tools.Refactor.Perform
+import Language.Haskell.Tools.Refactor.Prepare
+import Language.Haskell.Tools.Refactor.RefactorBase
 
 type ClientId = Int
 
@@ -76,7 +72,7 @@ 
 runDemo :: [String] -> IO ()
 runDemo args = do
-  wd <- case args of [dir] -> return dir
+  wd <- case args of dir:_ -> return dir
                      [] -> return "."
   counter <- newMVar []
   let settings = setPort 8206 $ setTimeout 20 $ defaultSettings 
@@ -103,12 +99,12 @@            if currState ^. isDisconnecting 
              then sendClose conn ("" :: ByteString)
              else serverLoop sessId ghcSess state conn
-      `catch` \(e :: ConnectionException) -> do 
+      `catch` \(_ :: ConnectionException) -> do 
                  modifyMVar_ sessions (return . delete sessId)
                  liftIO $ removeDirectoryIfPresent (userDir wd sessId)
 
     backupApp :: Application
-    backupApp req respond = respond $ responseLBS status400 [] "Not a WebSocket request"
+    backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"
 
 respondTo :: FilePath -> Int -> Session -> MVar RefactorSessionState -> (ByteString -> IO ()) -> ByteString -> IO ()
 respondTo wd id ghcSess state next mess = case decode mess of
@@ -120,15 +116,15 @@ 
 -- | This function does the real job of acting upon client messages in a stateful environment of a client
 updateClient :: FilePath -> ClientMessage -> StateT RefactorSessionState Ghc (Maybe ResponseMsg)
-updateClient dir KeepAlive = return Nothing
-updateClient dir Disconnect = do modify $ isDisconnecting .= True
-                                 return $ Just Disconnected
+updateClient _ KeepAlive = return Nothing
+updateClient _ Disconnect = do modify $ isDisconnecting .= True
+                               return $ Just Disconnected
 updateClient dir (ModuleChanged name newContent) = do
     liftIO $ createFileForModule dir name newContent
     targets <- lift getTargets
     when (isNothing . find ((\case (TargetModule n) -> GHC.moduleNameString n == name; _ -> False) . targetId) $ targets)
       $ lift $ addTarget (Target (TargetModule (GHC.mkModuleName name)) True Nothing)
-    lift $ load LoadAllTargets
+    void $ lift $ load LoadAllTargets
     mod <- lift $ getModSummary (GHC.mkModuleName name) >>= parseTyped
     modify $ refSessMods .- Map.insert (dir, name, NormalHs) mod
     return Nothing
@@ -140,11 +136,11 @@     -- clean the workspace to remove source files from earlier sessions
     liftIO $ removeDirectoryIfPresent dir
     liftIO $ createDirectoryIfMissing True dir
-    liftIO $ forM modules $ \(mod, cont) -> do
+    liftIO $ forM_ modules $ \(mod, cont) -> do
       withBinaryFile (toFileName dir mod) WriteMode (`hPutStr` cont)
     lift $ setTargets (map ((\modName -> Target (TargetModule (GHC.mkModuleName modName)) True Nothing) . fst) modules)
-    lift $ load LoadAllTargets
-    forM (map fst modules) $ \modName -> do
+    void $ lift $ load LoadAllTargets
+    forM_ (map fst modules) $ \modName -> do
       mod <- lift $ getModSummary (GHC.mkModuleName modName) >>= parseTyped
       modify $ refSessMods .- Map.insert (dir, modName, NormalHs) mod
     return Nothing
@@ -177,7 +173,7 @@ 
         writeModule n m = do
           liftIO $ withBinaryFile (toFileName dir n) WriteMode (`hPutStr` prettyPrint m)
-          w <- gets (find ((n ==) . (\(_,m,_) -> m)) . Map.keys . (^. refSessMods))
+          void $ gets (find ((n ==) . (\(_,m,_) -> m)) . Map.keys . (^. refSessMods))
           newm <- lift $ (parseTyped =<< loadModule dir n)
           modify $ refSessMods .- Map.insert (dir, n, NormalHs) newm