haskell-tools-demo 0.7.0.2 → 0.8.0.0
raw patch · 3 files changed
+52/−48 lines, 3 filesdep ~haskell-tools-astdep ~haskell-tools-backend-ghcdep ~haskell-tools-demo
Dependency ranges changed: haskell-tools-ast, haskell-tools-backend-ghc, haskell-tools-demo, haskell-tools-prettyprint, haskell-tools-refactor
Files
- haskell-tools-demo.cabal +7/−7
- src/Language/Haskell/Tools/ASTDebug.hs +36/−33
- src/Language/Haskell/Tools/Demo.hs +9/−8
haskell-tools-demo.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-demo -version: 0.7.0.2 +version: 0.8.0.0 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 @@ -32,10 +32,10 @@ , ghc >= 8.0.2 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , filepath >= 1.4 && < 1.5 - , haskell-tools-ast >= 0.7 && < 0.8 - , haskell-tools-backend-ghc >= 0.7 && < 0.8 - , haskell-tools-prettyprint >= 0.7 && < 0.8 - , haskell-tools-refactor >= 0.7 && < 0.8 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-backend-ghc >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 + , haskell-tools-refactor >= 0.8 && < 0.9 default-language: Haskell2010 executable ht-demo @@ -43,7 +43,7 @@ hs-source-dirs: exe ghc-options: -with-rtsopts=-M1500m build-depends: base >= 4.9 && < 4.10 - , haskell-tools-demo >= 0.7 && < 0.8 + , haskell-tools-demo >= 0.8 && < 0.9 default-language: Haskell2010 test-suite haskell-tools-demo-tests @@ -61,5 +61,5 @@ , network >= 2.6 && < 2.7 , websockets >= 0.10 && < 0.11 , aeson >= 1.0 && < 1.3 - , haskell-tools-demo >= 0.7 && < 0.8 + , haskell-tools-demo >= 0.8 && < 0.9 default-language: Haskell2010
src/Language/Haskell/Tools/ASTDebug.hs view
@@ -53,11 +53,11 @@ deriving instance Domain dom => Show (TreeDebugNode dom) -data SemanticInfoType dom - = DefaultInfoType { semaInfoTypeRng :: SrcSpan +data SemanticInfoType dom + = DefaultInfoType { semaInfoTypeRng :: SrcSpan } | NameInfoType { semaInfoTypeName :: SemanticInfo' dom SameInfoNameCls - , semaInfoTypeRng :: SrcSpan + , semaInfoTypeRng :: SrcSpan } | ExprInfoType { semaInfoTypeExpr :: SemanticInfo' dom SameInfoExprCls , semaInfoTypeRng :: SrcSpan @@ -88,7 +88,7 @@ astDebugToJson :: AssocSema dom => [DebugNode dom] -> Seq Char astDebugToJson nodes = fromList "[ " >< childrenJson >< fromList " ]" where treeNodes = List.filter (\case TreeNode {} -> True; _ -> False) nodes - childrenJson = case map debugTreeNode treeNodes of + childrenJson = case map debugTreeNode treeNodes of first:rest -> first >< foldl (><) Seq.empty (fmap (fromList ", " ><) (fromList rest)) [] -> Seq.empty debugTreeNode (TreeNode "" s) = astDebugElemJson s @@ -96,20 +96,20 @@ debugTreeNode (SimpleNode {}) = error "debugTreeNode: simple SimpleNode not allowed" astDebugElemJson :: AssocSema dom => TreeDebugNode dom -> Seq Char -astDebugElemJson (TreeDebugNode name info children) - = fromList "{ \"text\" : \"" >< fromList name - >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" +astDebugElemJson (TreeDebugNode name info children) + = fromList "{ \"text\" : \"" >< fromList name + >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" >< fromList (shortShowSpan (semaInfoTypeRng info)) - >< fromList "\", \"data-elems\" : \"" + >< fromList "\", \"data-elems\" : \"" >< foldl (><) Seq.empty dataElems - >< fromList "\", \"data-sema\" : \"" + >< fromList "\", \"data-sema\" : \"" >< fromList (showSema info) - >< fromList "\" }, \"children\" : " + >< fromList "\" }, \"children\" : " >< astDebugToJson children >< fromList " }" where dataElems = catMaybes (map (\case SimpleNode l v -> Just (fromList (formatScalarElem l v)); _ -> Nothing) children) formatScalarElem l v = "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ tail (init (show v)) ++ "</div>" - showSema info = "<div class='semaname'>" ++ assocName info ++ "</div>" - ++ concatMap (\(l,i) -> "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ i ++ "</div>") (toAssoc info) + showSema info = "<div class='semaname'>" ++ assocName info ++ "</div>" + ++ concatMap (\(l,i) -> "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ i ++ "</div>") (toAssoc info) class AssocData a where assocName :: a -> String @@ -140,15 +140,15 @@ toAssoc ni = [ ("name", maybe "<ambiguous>" inspect (semanticsName ni)) , ("isDefined", show (semanticsDefining ni)) - , ("namesInScope", inspectScope (semanticsScope ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) ] instance AssocData CNameInfo where assocName _ = "CNameInfo" toAssoc ni = [ ("name", inspect (semanticsId ni)) , ("isDefined", show (semanticsDefining ni)) - , ("fixity", maybe "" (showSDocUnsafe . ppr) (semanticsFixity ni)) - , ("namesInScope", inspectScope (semanticsScope ni)) + , ("fixity", maybe "" (showSDocUnsafe . ppr) (semanticsFixity ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) ] instance (HasModuleInfo' (ModuleInfo n)) => AssocData (ModuleInfo n) where @@ -157,25 +157,28 @@ , ("isBoot", show (isBootModule mi)) , ("implicitImports", concat (intersperse ", " (map inspect (semanticsImplicitImports mi)))) ] - + instance (HasImportInfo' (ImportInfo n)) => AssocData (ImportInfo n) where assocName _ = "ImportInfo" - toAssoc ii = [ ("moduleName", showSDocUnsafe (ppr (semanticsImportedModule ii))) - , ("availableNames", concat (intersperse ", " (map inspect (semanticsAvailable ii)))) - , ("importedNames", concat (intersperse ", " (map inspect (semanticsImported ii)))) - ] - + toAssoc ii = [ ("moduleName", showSDocUnsafe (ppr (semanticsImportedModule ii))) + , ("availableNames", concat (intersperse ", " (map inspect (semanticsAvailable ii)))) + , ("importedNames", concat (intersperse ", " (map inspect (semanticsImported ii)))) + ] + instance AssocData ImplicitFieldInfo where assocName _ = "ImplicitFieldInfo" toAssoc ifi = [ ("bindings", concat (intersperse ", " (map (\(from,to) -> "(" ++ inspect from ++ " -> " ++ inspect to ++ ")") (semanticsImplicitFlds ifi)))) - ] + ] -inspectScope :: InspectableName n => [[n]] -> String +inspectScope :: InspectableName n => [[(n, Maybe [UsageSpec])]] -> String inspectScope = concat . intersperse " | " . map (concat . intersperse ", " . map inspect) class InspectableName n where inspect :: n -> String +instance InspectableName n => InspectableName (n, Maybe [UsageSpec]) where + inspect (n,usage) = inspect n ++ showSDocUnsafe (ppr usage) + instance InspectableName GHC.Name where inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "]" @@ -193,35 +196,35 @@ | Just (_, t') <- splitForAllTy_maybe t = getTVs t' | otherwise = [] -class (Domain dom, SourceInfo st) +class (Domain dom, SourceInfo st) => ASTDebug e dom st where astDebug' :: e dom st -> [DebugNode dom] default astDebug' :: (GAstDebug (Rep (e dom st)) dom, Generic (e dom st)) => e dom st -> [DebugNode dom] astDebug' = gAstDebug . from -class GAstDebug f dom where +class GAstDebug f dom where gAstDebug :: f p -> [DebugNode dom] - + instance GAstDebug V1 dom where gAstDebug _ = error "GAstDebug V1" - + instance GAstDebug U1 dom where - gAstDebug U1 = [] - + gAstDebug U1 = [] + instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :+: g) dom where gAstDebug (L1 x) = gAstDebug x gAstDebug (R1 x) = gAstDebug x - + instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :*: g) dom where - gAstDebug (x :*: y) + gAstDebug (x :*: y) = gAstDebug x ++ gAstDebug y instance {-# OVERLAPPING #-} ASTDebug e dom st => GAstDebug (K1 i (e dom st)) dom where gAstDebug (K1 x) = astDebug' x - + instance {-# OVERLAPPABLE #-} Show x => GAstDebug (K1 i x) dom where gAstDebug (K1 x) = [SimpleNode "" (show x)] - + instance (GAstDebug f dom, Constructor c) => GAstDebug (M1 C c f) dom where gAstDebug c@(M1 x) = [TreeNode "" (TreeDebugNode (conName c) undefined (gAstDebug x))]
src/Language/Haskell/Tools/Demo.hs view
@@ -52,13 +52,13 @@ import Language.Haskell.Tools.PrettyPrint import Language.Haskell.Tools.Refactor.Perform import Language.Haskell.Tools.Refactor.Prepare -import Language.Haskell.Tools.Refactor.RefactorBase +import Language.Haskell.Tools.Refactor.RefactorBase hiding (initSession) type ClientId = Int data RefactorSessionState - = RefactorSessionState { _refSessMods :: Map.Map (String, String, IsBoot) (UnnamedModule IdDom) - , _actualMod :: Maybe (String, String, IsBoot) + = RefactorSessionState { _refSessMods :: Map.Map (String, String, FilePath) (UnnamedModule IdDom) + , _actualMod :: Maybe (String, String, FilePath) , _isDisconnecting :: Bool } @@ -129,7 +129,7 @@ return Nothing updateClient dir (ModuleDeleted name) = do lift $ removeTarget (TargetModule (GHC.mkModuleName name)) - modify $ refSessMods .- Map.delete (dir, name, NormalHs) + modify $ refSessMods .- Map.delete (dir, name, dir </> moduleSourceFile name) return Nothing updateClient dir (InitialProject modules) = do -- clean the workspace to remove source files from earlier sessions @@ -170,7 +170,7 @@ writeModule (n ^. sfkModuleName) m ModuleRemoved mod -> do liftIO $ removeFile (toFileName dir mod) - modify $ refSessMods .- Map.delete (dir, mod, NormalHs) + modify $ refSessMods .- Map.delete (dir, mod, dir </> moduleSourceFile mod) lift $ removeTarget (TargetModule (GHC.mkModuleName mod)) reloadAllMods dir @@ -178,11 +178,12 @@ reloadAllMods :: FilePath -> StateT RefactorSessionState Ghc () reloadAllMods dir = do + wd <- liftIO getCurrentDirectory void $ lift $ load LoadAllTargets targets <- lift getTargets forM_ (map ((\case (TargetModule n) -> n) . targetId) targets) $ \modName -> do - mod <- lift $ getModSummary modName >>= parseTyped - modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, NormalHs) mod + mod <- lift $ getModSummary modName >>= parseTyped wd + modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, dir </> moduleSourceFile (GHC.moduleNameString modName)) mod createFileForModule :: FilePath -> String -> String -> IO () createFileForModule dir name newContent = do @@ -193,7 +194,7 @@ removeDirectoryIfPresent :: FilePath -> IO () removeDirectoryIfPresent dir = removeDirectoryRecursive dir `catch` \e -> if isDoesNotExistError e then return () else throwIO e -moduleNameAndContent :: ((String,String,IsBoot), mod) -> (SourceFileKey, mod) +moduleNameAndContent :: ((String,String,FilePath), mod) -> (SourceFileKey, mod) moduleNameAndContent ((_,name,isBoot), mod) = (SourceFileKey isBoot name, mod) dataDirs :: FilePath -> FilePath