haskell-tools-demo 0.2.0.0 → 0.3.0.0
raw patch · 5 files changed
+426/−430 lines, 5 filesdep +haskell-tools-backend-ghcdep −haskell-tools-ast-fromghcdep −haskell-tools-ast-trfdep ~aesondep ~basedep ~bytestring
Dependencies added: haskell-tools-backend-ghc
Dependencies removed: haskell-tools-ast-fromghc, haskell-tools-ast-trf
Dependency ranges changed: aeson, base, bytestring, containers, directory, filepath, ghc, ghc-paths, haskell-tools-ast, haskell-tools-prettyprint, haskell-tools-refactor, http-types, references, transformers, wai, wai-websockets, warp, websockets
Files
- Language/Haskell/Tools/ASTDebug.hs +32/−42
- Language/Haskell/Tools/ASTDebug/Instances.hs +108/−108
- Language/Haskell/Tools/Demo.hs +262/−0
- Main.hs +2/−256
- haskell-tools-demo.cabal +22/−24
Language/Haskell/Tools/ASTDebug.hs view
@@ -34,10 +34,9 @@ import Language.Haskell.Tools.AST import Language.Haskell.Tools.AST.FromGHC -import Language.Haskell.Tools.AnnTrf.RangeToRangeTemplate -import Language.Haskell.Tools.AnnTrf.RangeTemplate -import Language.Haskell.Tools.AnnTrf.SourceTemplate +import Language.Haskell.Tools.Transform --import Language.Haskell.Tools.Refactor.RangeDebug +import Language.Haskell.Tools.AST.SemaInfoTypes data DebugNode dom = TreeNode { _nodeLabel :: String @@ -135,52 +134,43 @@ instance AssocData ScopeInfo where - assocName (ScopeInfo {}) = "ScopeInfo" - toAssoc (ScopeInfo locals) = [ ("namesInScope", inspectScope locals) ] + assocName si = "ScopeInfo" + toAssoc si = [ ("namesInScope", inspectScope (semanticsScope si)) ] -instance InspectableName n => AssocData (NameInfo n) where - assocName (NameInfo {}) = "NameInfo" - assocName (AmbiguousNameInfo {}) = "AmbiguousNameInfo" - assocName (ImplicitNameInfo {}) = "ImplicitNameInfo" +instance HasNameInfo' (NameInfo n) => AssocData (NameInfo n) where + assocName si = "NameInfo" - toAssoc (NameInfo locals defined nameInfo) = [ ("name", inspect nameInfo) - , ("isDefined", show defined) - , ("namesInScope", inspectScope locals) - ] - toAssoc (AmbiguousNameInfo locals defined name _) = [ ("name", inspect name) - , ("isDefined", show defined) - , ("namesInScope", inspectScope locals) - ] - toAssoc (ImplicitNameInfo locals defined name _) = [ ("name", name) - , ("isDefined", show defined) - , ("namesInScope", inspectScope locals) - ] + toAssoc ni = [ ("name", maybe "<ambiguous>" inspect (semanticsName ni)) + , ("isDefined", show (semanticsDefining ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) + ] + instance AssocData CNameInfo where - assocName (CNameInfo {}) = "CNameInfo" - toAssoc (CNameInfo locals defined nameInfo fixity) = [ ("name", inspect nameInfo) - , ("isDefined", show defined) - , ("fixity", maybe "" (showSDocUnsafe . ppr) fixity) - , ("namesInScope", inspectScope locals) - ] + assocName _ = "CNameInfo" + toAssoc ni = [ ("name", inspect (semanticsId ni)) + , ("isDefined", show (semanticsDefining ni)) + , ("fixity", maybe "" (showSDocUnsafe . ppr) (semanticsFixity ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) + ] -instance InspectableName n => AssocData (ModuleInfo n) where - assocName (ModuleInfo {}) = "ModuleInfo" - toAssoc (ModuleInfo mod isboot imps) = [ ("moduleName", showSDocUnsafe (ppr mod)) - , ("isBoot", show isboot) - , ("implicitImports", concat (intersperse ", " (map inspect imps))) - ] +instance (HasModuleInfo' (ModuleInfo n), InspectableName 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 InspectableName n => AssocData (ImportInfo n) where - assocName (ImportInfo {}) = "ImportInfo" - toAssoc (ImportInfo mod avail imported) = [ ("moduleName", showSDocUnsafe (ppr mod)) - , ("availableNames", concat (intersperse ", " (map inspect avail))) - , ("importedNames", concat (intersperse ", " (map inspect imported))) - ] +instance (HasImportInfo' (ImportInfo n), InspectableName 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)))) + ] instance AssocData ImplicitFieldInfo where - assocName (ImplicitFieldInfo {}) = "ImplicitFieldInfo" - toAssoc (ImplicitFieldInfo bnds) = [ ("bindings", concat (intersperse ", " (map (\(from,to) -> "(" ++ inspect from ++ " -> " ++ inspect to ++ ")") bnds))) - ] + assocName _ = "ImplicitFieldInfo" + toAssoc ifi = [ ("bindings", concat (intersperse ", " (map (\(from,to) -> "(" ++ inspect from ++ " -> " ++ inspect to ++ ")") (semanticsImplicitFlds ifi)))) + ] inspectScope :: InspectableName n => [[n]] -> String inspectScope = concat . intersperse " | " . map (concat . intersperse ", " . map inspect)
Language/Haskell/Tools/ASTDebug/Instances.hs view
@@ -16,142 +16,142 @@ import Language.Haskell.Tools.AST -- Annotations -instance {-# OVERLAPPING #-} (ASTDebug QualifiedName dom st) => ASTDebug (Ann QualifiedName) dom st where +instance {-# OVERLAPPING #-} (ASTDebug UQualifiedName dom st) => ASTDebug (Ann UQualifiedName) dom st where astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (NameInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e -instance {-# OVERLAPPING #-} (ASTDebug Expr dom st) => ASTDebug (Ann Expr) dom st where +instance {-# OVERLAPPING #-} (ASTDebug UExpr dom st) => ASTDebug (Ann UExpr) dom st where astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ExprInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e -instance {-# OVERLAPPING #-} (ASTDebug ImportDecl dom st) => ASTDebug (Ann ImportDecl) dom st where +instance {-# OVERLAPPING #-} (ASTDebug UImportDecl dom st) => ASTDebug (Ann UImportDecl) dom st where astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ImportInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e -instance {-# OVERLAPPING #-} (ASTDebug Module dom st) => ASTDebug (Ann Module) dom st where +instance {-# OVERLAPPING #-} (ASTDebug UModule dom st) => ASTDebug (Ann UModule) dom st where astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ModuleInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e -instance {-# OVERLAPPING #-} (ASTDebug FieldWildcard dom st) => ASTDebug (Ann FieldWildcard) dom st where +instance {-# OVERLAPPING #-} (ASTDebug UFieldWildcard dom st) => ASTDebug (Ann UFieldWildcard) dom st where astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= (ImplicitFieldInfoType (a ^. semanticInfo) (getRange (a ^. sourceInfo))) $ astDebug' e instance ASTDebug e dom st => ASTDebug (Ann e) dom st where astDebug' (Ann a e) = traversal&nodeSubtree&nodeInfo .= DefaultInfoType (getRange (a ^. sourceInfo)) $ astDebug' e -- FIXME: WHY do I have to write it separately? -instance {-# OVERLAPPING #-} (ASTDebug ImportDecl dom st) => ASTDebug (AnnList ImportDecl) dom st where - astDebug' (AnnList a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] +instance {-# OVERLAPPING #-} (ASTDebug UImportDecl dom st) => ASTDebug (AnnListG UImportDecl) dom st where + astDebug' (AnnListG a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] -instance (ASTDebug e dom st) => ASTDebug (AnnList e) dom st where - astDebug' (AnnList a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] +instance (ASTDebug e dom st) => ASTDebug (AnnListG e) dom st where + astDebug' (AnnListG a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] -instance (ASTDebug e dom st) => ASTDebug (AnnMaybe e) dom st where - astDebug' (AnnMaybe a e) = [TreeNode "" (TreeDebugNode "?" (DefaultInfoType (getRange (a ^. sourceInfo))) (maybe [] astDebug' e))] +instance (ASTDebug e dom st) => ASTDebug (AnnMaybeG e) dom st where + astDebug' (AnnMaybeG a e) = [TreeNode "" (TreeDebugNode "?" (DefaultInfoType (getRange (a ^. sourceInfo))) (maybe [] astDebug' e))] -- Modules -instance (Domain dom, SourceInfo st) => ASTDebug Module dom st -instance (Domain dom, SourceInfo st) => ASTDebug ModuleHead dom st -instance (Domain dom, SourceInfo st) => ASTDebug ExportSpecList dom st -instance (Domain dom, SourceInfo st) => ASTDebug ExportSpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug IESpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug SubSpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug ModulePragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug FilePragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportSpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportQualified dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportSource dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportSafe dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeNamespace dom st -instance (Domain dom, SourceInfo st) => ASTDebug ImportRenaming dom st +instance (Domain dom, SourceInfo st) => ASTDebug UModule dom st +instance (Domain dom, SourceInfo st) => ASTDebug UModuleHead dom st +instance (Domain dom, SourceInfo st) => ASTDebug UExportSpecs dom st +instance (Domain dom, SourceInfo st) => ASTDebug UExportSpec dom st +instance (Domain dom, SourceInfo st) => ASTDebug UIESpec dom st +instance (Domain dom, SourceInfo st) => ASTDebug USubSpec dom st +instance (Domain dom, SourceInfo st) => ASTDebug UModulePragma dom st +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 UImportQualified dom st +instance (Domain dom, SourceInfo st) => ASTDebug UImportSource dom st +instance (Domain dom, SourceInfo st) => ASTDebug UImportSafe dom st +instance (Domain dom, SourceInfo st) => ASTDebug UTypeNamespace dom st +instance (Domain dom, SourceInfo st) => ASTDebug UImportRenaming dom st -- Declarations -instance (Domain dom, SourceInfo st) => ASTDebug Decl dom st -instance (Domain dom, SourceInfo st) => ASTDebug ClassBody dom st -instance (Domain dom, SourceInfo st) => ASTDebug ClassElement dom st -instance (Domain dom, SourceInfo st) => ASTDebug DeclHead dom st -instance (Domain dom, SourceInfo st) => ASTDebug InstBody dom st -instance (Domain dom, SourceInfo st) => ASTDebug InstBodyDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug GadtConDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug GadtConType dom st -instance (Domain dom, SourceInfo st) => ASTDebug FieldWildcard dom st -instance (Domain dom, SourceInfo st) => ASTDebug FunDeps dom st -instance (Domain dom, SourceInfo st) => ASTDebug FunDep dom st -instance (Domain dom, SourceInfo st) => ASTDebug ConDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug FieldDecl dom st -instance (Domain dom, SourceInfo st) => ASTDebug Deriving dom st -instance (Domain dom, SourceInfo st) => ASTDebug InstanceRule dom st -instance (Domain dom, SourceInfo st) => ASTDebug InstanceHead dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeEqn dom st -instance (Domain dom, SourceInfo st) => ASTDebug KindConstraint dom st -instance (Domain dom, SourceInfo st) => ASTDebug TyVar dom st -instance (Domain dom, SourceInfo st) => ASTDebug Type dom st -instance (Domain dom, SourceInfo st) => ASTDebug Kind dom st -instance (Domain dom, SourceInfo st) => ASTDebug Context dom st -instance (Domain dom, SourceInfo st) => ASTDebug Assertion dom st -instance (Domain dom, SourceInfo st) => ASTDebug Expr dom st -instance (Domain dom, SourceInfo st) => ASTDebug (Stmt' Expr) dom st -instance (Domain dom, SourceInfo st) => ASTDebug (Stmt' Cmd) dom st -instance (Domain dom, SourceInfo st) => ASTDebug CompStmt dom st -instance (Domain dom, SourceInfo st) => ASTDebug ValueBind dom st -instance (Domain dom, SourceInfo st) => ASTDebug Pattern dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatternField dom st -instance (Domain dom, SourceInfo st) => ASTDebug Splice dom st +instance (Domain dom, SourceInfo st) => ASTDebug UDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug UClassBody dom st +instance (Domain dom, SourceInfo st) => ASTDebug UClassElement dom st +instance (Domain dom, SourceInfo st) => ASTDebug UDeclHead dom st +instance (Domain dom, SourceInfo st) => ASTDebug UInstBody dom st +instance (Domain dom, SourceInfo st) => ASTDebug UInstBodyDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug UGadtConDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug UGadtConType dom st +instance (Domain dom, SourceInfo st) => ASTDebug UFieldWildcard dom st +instance (Domain dom, SourceInfo st) => ASTDebug UFunDeps dom st +instance (Domain dom, SourceInfo st) => ASTDebug UFunDep dom st +instance (Domain dom, SourceInfo st) => ASTDebug UConDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug UFieldDecl dom st +instance (Domain dom, SourceInfo st) => ASTDebug UDeriving dom st +instance (Domain dom, SourceInfo st) => ASTDebug UInstanceRule dom st +instance (Domain dom, SourceInfo st) => ASTDebug UInstanceHead dom st +instance (Domain dom, SourceInfo st) => ASTDebug UTypeEqn dom st +instance (Domain dom, SourceInfo st) => ASTDebug UKindConstraint dom st +instance (Domain dom, SourceInfo st) => ASTDebug UTyVar dom st +instance (Domain dom, SourceInfo st) => ASTDebug UType dom st +instance (Domain dom, SourceInfo st) => ASTDebug UKind dom st +instance (Domain dom, SourceInfo st) => ASTDebug UContext dom st +instance (Domain dom, SourceInfo st) => ASTDebug UAssertion dom st +instance (Domain dom, SourceInfo st) => ASTDebug UExpr dom st +instance (Domain dom, SourceInfo st) => ASTDebug (UStmt' UExpr) dom st +instance (Domain dom, SourceInfo st) => ASTDebug (UStmt' UCmd) dom st +instance (Domain dom, SourceInfo st) => ASTDebug UCompStmt dom st +instance (Domain dom, SourceInfo st) => ASTDebug UValueBind dom st +instance (Domain dom, SourceInfo st) => ASTDebug UPattern dom st +instance (Domain dom, SourceInfo st) => ASTDebug UPatternField dom st +instance (Domain dom, SourceInfo st) => ASTDebug USplice dom st instance (Domain dom, SourceInfo st) => ASTDebug QQString dom st -instance (Domain dom, SourceInfo st) => ASTDebug Match dom st -instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (Alt' expr) dom st -instance (Domain dom, SourceInfo st) => ASTDebug Rhs dom st -instance (Domain dom, SourceInfo st) => ASTDebug GuardedRhs dom st -instance (Domain dom, SourceInfo st) => ASTDebug FieldUpdate dom st -instance (Domain dom, SourceInfo st) => ASTDebug Bracket dom st -instance (Domain dom, SourceInfo st) => ASTDebug TopLevelPragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug Rule dom st -instance (Domain dom, SourceInfo st) => ASTDebug AnnotationSubject dom st -instance (Domain dom, SourceInfo st) => ASTDebug MinimalFormula dom st -instance (Domain dom, SourceInfo st) => ASTDebug ExprPragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug SourceRange dom st +instance (Domain dom, SourceInfo st) => ASTDebug UMatch dom st +instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (UAlt' expr) dom st +instance (Domain dom, SourceInfo st) => ASTDebug URhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug UGuardedRhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug UFieldUpdate dom st +instance (Domain dom, SourceInfo st) => ASTDebug UBracket dom st +instance (Domain dom, SourceInfo st) => ASTDebug UTopLevelPragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug URule dom st +instance (Domain dom, SourceInfo st) => ASTDebug UAnnotationSubject dom st +instance (Domain dom, SourceInfo st) => ASTDebug UMinimalFormula dom st +instance (Domain dom, SourceInfo st) => ASTDebug UExprPragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug USourceRange dom st instance (Domain dom, SourceInfo st) => ASTDebug Number dom st -instance (Domain dom, SourceInfo st) => ASTDebug QuasiQuote dom st -instance (Domain dom, SourceInfo st) => ASTDebug RhsGuard dom st -instance (Domain dom, SourceInfo st) => ASTDebug LocalBind dom st -instance (Domain dom, SourceInfo st) => ASTDebug LocalBinds dom st -instance (Domain dom, SourceInfo st) => ASTDebug FixitySignature dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeSignature dom st -instance (Domain dom, SourceInfo st) => ASTDebug ListCompBody dom st -instance (Domain dom, SourceInfo st) => ASTDebug TupSecElem dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeFamily dom st -instance (Domain dom, SourceInfo st) => ASTDebug TypeFamilySpec dom st -instance (Domain dom, SourceInfo st) => ASTDebug InjectivityAnn dom st -instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (CaseRhs' expr) dom st -instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (GuardedCaseRhs' expr) dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatternSynonym dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatSynRhs dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatSynLhs dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatSynWhere dom st -instance (Domain dom, SourceInfo st) => ASTDebug PatternTypeSignature dom st -instance (Domain dom, SourceInfo st) => ASTDebug Role dom st -instance (Domain dom, SourceInfo st) => ASTDebug Cmd dom st -instance (Domain dom, SourceInfo st) => ASTDebug LanguageExtension dom st -instance (Domain dom, SourceInfo st) => ASTDebug MatchLhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug UQuasiQuote dom st +instance (Domain dom, SourceInfo st) => ASTDebug URhsGuard dom st +instance (Domain dom, SourceInfo st) => ASTDebug ULocalBind dom st +instance (Domain dom, SourceInfo st) => ASTDebug ULocalBinds dom st +instance (Domain dom, SourceInfo st) => ASTDebug UFixitySignature dom st +instance (Domain dom, SourceInfo st) => ASTDebug UTypeSignature dom st +instance (Domain dom, SourceInfo st) => ASTDebug UListCompBody dom st +instance (Domain dom, SourceInfo st) => ASTDebug UTupSecElem dom st +instance (Domain dom, SourceInfo st) => ASTDebug UTypeFamily dom st +instance (Domain dom, SourceInfo st) => ASTDebug UTypeFamilySpec dom st +instance (Domain dom, SourceInfo st) => ASTDebug UInjectivityAnn dom st +instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (UCaseRhs' expr) dom st +instance (Domain dom, SourceInfo st, ASTDebug expr dom st, Generic (expr dom st)) => ASTDebug (UGuardedCaseRhs' expr) dom st +instance (Domain dom, SourceInfo st) => ASTDebug UPatternSynonym dom st +instance (Domain dom, SourceInfo st) => ASTDebug UPatSynRhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug UPatSynLhs dom st +instance (Domain dom, SourceInfo st) => ASTDebug UPatSynWhere dom st +instance (Domain dom, SourceInfo st) => ASTDebug UPatternTypeSignature dom st +instance (Domain dom, SourceInfo st) => ASTDebug URole dom st +instance (Domain dom, SourceInfo st) => ASTDebug UCmd dom st +instance (Domain dom, SourceInfo st) => ASTDebug ULanguageExtension dom st +instance (Domain dom, SourceInfo st) => ASTDebug UMatchLhs dom st --- Literal -instance (Domain dom, SourceInfo st) => ASTDebug Literal dom st -instance (Domain dom, SourceInfo st, ASTDebug k dom st, Generic (k dom st)) => ASTDebug (Promoted k) dom st +-- ULiteral +instance (Domain dom, SourceInfo st) => ASTDebug ULiteral dom st +instance (Domain dom, SourceInfo st, ASTDebug k dom st, Generic (k dom st)) => ASTDebug (UPromoted k) dom st -- Base -instance (Domain dom, SourceInfo st) => ASTDebug Operator dom st -instance (Domain dom, SourceInfo st) => ASTDebug Name dom st -instance (Domain dom, SourceInfo st) => ASTDebug QualifiedName dom st -instance (Domain dom, SourceInfo st) => ASTDebug ModuleName dom st -instance (Domain dom, SourceInfo st) => ASTDebug UnqualName dom st -instance (Domain dom, SourceInfo st) => ASTDebug StringNode dom st -instance (Domain dom, SourceInfo st) => ASTDebug DataOrNewtypeKeyword dom st -instance (Domain dom, SourceInfo st) => ASTDebug DoKind dom st +instance (Domain dom, SourceInfo st) => ASTDebug UOperator dom st +instance (Domain dom, SourceInfo st) => ASTDebug UName dom st +instance (Domain dom, SourceInfo st) => ASTDebug UQualifiedName dom st +instance (Domain dom, SourceInfo st) => ASTDebug UModuleName dom st +instance (Domain dom, SourceInfo st) => ASTDebug UNamePart dom st +instance (Domain dom, SourceInfo st) => ASTDebug UStringNode dom st +instance (Domain dom, SourceInfo st) => ASTDebug UDataOrNewtypeKeyword dom st +instance (Domain dom, SourceInfo st) => ASTDebug UDoKind dom st instance (Domain dom, SourceInfo st) => ASTDebug TypeKeyword dom st -instance (Domain dom, SourceInfo st) => ASTDebug OverlapPragma dom st -instance (Domain dom, SourceInfo st) => ASTDebug CallConv dom st -instance (Domain dom, SourceInfo st) => ASTDebug ArrowAppl dom st -instance (Domain dom, SourceInfo st) => ASTDebug Safety dom st -instance (Domain dom, SourceInfo st) => ASTDebug ConlikeAnnot dom st +instance (Domain dom, SourceInfo st) => ASTDebug UOverlapPragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug UCallConv dom st +instance (Domain dom, SourceInfo st) => ASTDebug UArrowAppl dom st +instance (Domain dom, SourceInfo st) => ASTDebug USafety dom st +instance (Domain dom, SourceInfo st) => ASTDebug UConlikeAnnot dom st instance (Domain dom, SourceInfo st) => ASTDebug Assoc dom st instance (Domain dom, SourceInfo st) => ASTDebug Precedence dom st instance (Domain dom, SourceInfo st) => ASTDebug LineNumber dom st -instance (Domain dom, SourceInfo st) => ASTDebug PhaseControl dom st +instance (Domain dom, SourceInfo st) => ASTDebug UPhaseControl dom st instance (Domain dom, SourceInfo st) => ASTDebug PhaseNumber dom st instance (Domain dom, SourceInfo st) => ASTDebug PhaseInvert dom st
+ Language/Haskell/Tools/Demo.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE OverloadedStrings + , DeriveGeneric + , TypeApplications + , TupleSections + , ScopedTypeVariables + , LambdaCase + , TemplateHaskell + #-} + +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.Exception +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 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 Data.Maybe +import Control.Monad +import Control.Monad.State +import Control.Concurrent.MVar +import Control.Monad.IO.Class +import System.Environment + +import GHC hiding (loadModule) +import Bag (bagToList) +import SrcLoc (realSrcSpanStart) +import ErrUtils (errMsgSpan) +import DynFlags (gopt_set) +import GHC.Paths ( libdir ) +import GhcMonad (GhcMonad(..), Session(..), reflectGhc) +import HscTypes (SourceError, srcErrorMessages) +import FastString (unpackFS) + +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.PrettyPrint + +type ClientId = Int + +data RefactorSessionState + = RefactorSessionState { _refSessMods :: Map.Map (String, String, IsBoot) (UnnamedModule IdDom) + , _actualMod :: Maybe (String, String, IsBoot) + } + +makeReferences ''RefactorSessionState + +initSession :: RefactorSessionState +initSession = RefactorSessionState Map.empty Nothing + +runFromCLI :: IO () +runFromCLI = getArgs >>= runDemo + +runDemo :: [String] -> IO () +runDemo args = do + wd <- case args of [dir] -> return dir + [] -> return "." + counter <- newMVar [] + let settings = setPort 8206 $ setTimeout 20 $ defaultSettings + runSettings settings (app counter wd) + +-- | The application that is evoked for each incoming request +app :: MVar [Int] -> FilePath -> Application +app sessions wd = websocketsOr defaultConnectionOptions wsApp backupApp + where + wsApp :: ServerApp + wsApp conn = do + conn <- acceptRequest conn + newind <- modifyMVar sessions (\sess -> let smallest = head (filter (not . (`elem` sess)) [0..]) + in return (smallest : sess, smallest)) + ghcSess <- initGhcSession (userDir wd newind) + state <- newMVar initSession + serverLoop newind ghcSess state conn + + serverLoop :: Int -> Session -> MVar RefactorSessionState -> Connection -> IO () + serverLoop sessId ghcSess state conn = + do Text msg <- receiveDataMessage conn + respondTo wd sessId ghcSess state (sendTextData conn) msg + serverLoop sessId ghcSess state conn + `catch` \(e :: ConnectionException) -> do + modifyMVar_ sessions (return . delete sessId) + liftIO $ removeDirectoryIfPresent (userDir wd sessId) + + backupApp :: Application + backupApp req 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 + Nothing -> next $ encode $ ErrorMessage "WRONG MESSAGE FORMAT" + Just req -> handleErrors wd req (next . encode) + $ do resp <- modifyMVar state (\st -> swap <$> reflectGhc (runStateT (updateClient (userDir wd id) req) st) ghcSess) + case resp of Just respMsg -> next $ encode respMsg + Nothing -> return () + +-- | 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 (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 + mod <- lift $ getModSummary (GHC.mkModuleName name) >>= parseTyped + modify $ refSessMods .- Map.insert (dir, name, NormalHs) mod + return Nothing +updateClient dir (ModuleDeleted name) = do + lift $ removeTarget (TargetModule (GHC.mkModuleName name)) + modify $ refSessMods .- Map.delete (dir, name, NormalHs) + return Nothing +updateClient dir (InitialProject modules) = do + -- clean the workspace to remove source files from earlier sessions + liftIO $ removeDirectoryIfPresent dir + liftIO $ createDirectoryIfMissing True dir + 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 + mod <- lift $ getModSummary (GHC.mkModuleName modName) >>= parseTyped + modify $ refSessMods .- Map.insert (dir, modName, NormalHs) mod + return Nothing +updateClient _ (PerformRefactoring "UpdateAST" modName _ _) = do + mod <- gets (find ((modName ==) . (\(_,m,_) -> m) . fst) . Map.assocs . (^. refSessMods)) + case mod of Just (_,m) -> return $ Just $ ASTViewContent $ astDebug m + Nothing -> return $ Just $ ErrorMessage "The module is not found" +updateClient _ (PerformRefactoring "TestErrorLogging" _ _ _) = error "This is a test" +updateClient dir (PerformRefactoring refact modName selection args) = do + mod <- gets (find ((modName ==) . (\(_,m,_) -> m) . fst) . Map.assocs . (^. refSessMods)) + allModules <- gets (map moduleNameAndContent . Map.assocs . (^. refSessMods)) + let command = analyzeCommand (toFileName dir modName) refact (selection:args) + liftIO $ putStrLn $ (toFileName dir modName) + liftIO $ putStrLn $ maybe "" (show . getRange . snd) mod + case mod of Just m -> do res <- lift $ performCommand command (moduleNameAndContent m) allModules + case res of + Left err -> return $ Just $ ErrorMessage err + Right diff -> do applyChanges diff + return $ Just $ RefactorChanges (map trfDiff diff) + Nothing -> return $ Just $ ErrorMessage "The module is not found" + where trfDiff (ContentChanged (name,cont)) = (name, Just (prettyPrint cont)) + trfDiff (ModuleRemoved name) = (name, Nothing) + + applyChanges + = mapM_ $ \case + ContentChanged (n,m) -> do + liftIO $ withBinaryFile (toFileName dir n) WriteMode (`hPutStr` prettyPrint m) + w <- gets (find ((n ==) . (\(_,m,_) -> m)) . Map.keys . (^. refSessMods)) + newm <- lift $ (parseTyped =<< loadModule dir n) + modify $ refSessMods .- Map.insert (dir, n, NormalHs) newm + ModuleRemoved mod -> do + liftIO $ removeFile (toFileName dir mod) + modify $ refSessMods .- Map.delete (dir, mod, NormalHs) + +createFileForModule :: FilePath -> String -> String -> IO () +createFileForModule dir name newContent = do + let fname = toFileName dir name + createDirectoryIfMissing True (takeDirectory fname) + withBinaryFile fname WriteMode (`hPutStr` newContent) + +removeDirectoryIfPresent :: FilePath -> IO () +removeDirectoryIfPresent dir = removeDirectoryRecursive dir `catch` \e -> if isDoesNotExistError e then return () else throwIO e + +moduleNameAndContent :: ((String,String,IsBoot), mod) -> (String, mod) +moduleNameAndContent ((_,name,_), mod) = (name, mod) + +dataDirs :: FilePath -> FilePath +dataDirs wd = normalise $ wd </> "demoSources" + +userDir :: FilePath -> ClientId -> FilePath +userDir wd id = dataDirs wd </> show id + +initGhcSession :: FilePath -> IO Session +initGhcSession workingDir = Session <$> (newIORef =<< runGhc (Just libdir) (do + dflags <- getSessionDynFlags + -- don't generate any code + setSessionDynFlags + $ flip gopt_set Opt_KeepRawTokenStream + $ flip gopt_set Opt_NoHsMain + $ dflags { importPaths = [workingDir] + , hscTarget = HscAsm -- needed for static pointers + , ghcLink = LinkInMemory + , ghcMode = CompManager + } + getSession)) + +handleErrors :: FilePath -> ClientMessage -> (ResponseMsg -> IO ()) -> IO () -> IO () +handleErrors wd req next io = io `catch` (next <=< handleException) + where handleException :: SomeException -> IO ResponseMsg + handleException e + | Just (se :: SourceError) <- fromException e + = return $ CompilationProblem (concatMap (\msg -> showMsg msg ++ "\n\n") $ bagToList $ srcErrorMessages se) + | Just (ae :: AsyncException) <- fromException e = throw ae + | Just (ge :: GhcException) <- fromException e = return $ ErrorMessage $ show ge + | otherwise = do logToFile wd (show e) req + return $ ErrorMessage (showInternalError e) + + showMsg msg = showSpan (errMsgSpan msg) ++ "\n" ++ show msg + showSpan (RealSrcSpan sp) = showFileName (srcLocFile (realSrcSpanStart sp)) ++ " " ++ show (srcLocLine (realSrcSpanStart sp)) ++ ":" ++ show (srcLocCol (realSrcSpanStart sp)) + showSpan _ = "" + + showFileName = joinPath . drop 2 . splitPath . makeRelative wd . unpackFS + + showInternalError :: SomeException -> String + showInternalError e = "An internal error happened. The report has been sent to the developers. " ++ show e + +logToFile :: FilePath -> String -> ClientMessage -> IO () +logToFile wd err input = do + let msg = err ++ "\n with input: " ++ show input + withFile logFile AppendMode $ \handle -> do + size <- hFileSize handle + when (size < logSizeLimit) $ hPutStrLn handle ("\n### " ++ msg) + `catch` \e -> print ("The error message cannot be logged because: " + ++ show (e :: IOException) ++ "\nHere is the message:\n" ++ msg) + where logFile = wd </> "error-log.txt" + logSizeLimit = 100 * 1024 * 1024 -- 100 MB + +data ClientMessage + = KeepAlive + | InitialProject { initialModules :: [(String,String)] } + | PerformRefactoring { refactoring :: String + , moduleName :: String + , editorSelection :: String + , details :: [String] + } + | ModuleChanged { moduleName :: String + , newContent :: String + } + | ModuleDeleted { moduleName :: String } + deriving (Eq, Show, Generic) + +instance ToJSON ClientMessage +instance FromJSON ClientMessage + +data ResponseMsg + = RefactorChanges { moduleChanges :: [(String, Maybe String)] } + | ASTViewContent { astContent :: String } + | ErrorMessage { errorMsg :: String } + | CompilationProblem { errorMsg :: String } + deriving (Eq, Show, Generic) + +instance ToJSON ResponseMsg +instance FromJSON ResponseMsg
Main.hs view
@@ -1,259 +1,5 @@-{-# LANGUAGE OverloadedStrings - , DeriveGeneric - , TypeApplications - , TupleSections - , ScopedTypeVariables - , LambdaCase - , TemplateHaskell - #-} - module Main where -import Network.WebSockets -import Network.Wai.Handler.WebSockets -import Network.Wai.Handler.Warp -import Network.Wai -import Network.HTTP.Types -import Control.Exception -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 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 Data.Maybe -import Control.Monad -import Control.Monad.State -import Control.Concurrent.MVar -import Control.Monad.IO.Class -import System.Environment - -import GHC hiding (loadModule) -import Bag (bagToList) -import SrcLoc (realSrcSpanStart) -import ErrUtils (errMsgSpan) -import DynFlags (gopt_set) -import GHC.Paths ( libdir ) -import GhcMonad (GhcMonad(..), Session(..), reflectGhc) -import HscTypes (SourceError, srcErrorMessages) -import FastString (unpackFS) - -import Control.Reference - -import Language.Haskell.Tools.AST -import Language.Haskell.Tools.Refactor -import Language.Haskell.Tools.Refactor.RefactorBase -import Language.Haskell.Tools.ASTDebug -import Language.Haskell.Tools.ASTDebug.Instances -import Language.Haskell.Tools.PrettyPrint - -type ClientId = Int - -data RefactorSessionState - = RefactorSessionState { _refSessMods :: Map.Map (String, String, IsBoot) (UnnamedModule IdDom) - , _actualMod :: Maybe (String, String, IsBoot) - } - -makeReferences ''RefactorSessionState - -initSession :: RefactorSessionState -initSession = RefactorSessionState Map.empty Nothing - -main :: IO () -main = do - args <- getArgs - wd <- case args of [dir] -> return dir - [] -> return "." - counter <- newMVar [] - let settings = setPort 8206 $ setTimeout 20 $ defaultSettings - runSettings settings (app counter wd) - --- | The application that is evoked for each incoming request -app :: MVar [Int] -> FilePath -> Application -app sessions wd = websocketsOr defaultConnectionOptions wsApp backupApp - where - wsApp :: ServerApp - wsApp conn = do - conn <- acceptRequest conn - newind <- modifyMVar sessions (\sess -> let smallest = head (filter (not . (`elem` sess)) [0..]) - in return (smallest : sess, smallest)) - ghcSess <- initGhcSession (userDir wd newind) - state <- newMVar initSession - serverLoop newind ghcSess state conn - - serverLoop :: Int -> Session -> MVar RefactorSessionState -> Connection -> IO () - serverLoop sessId ghcSess state conn = - do Text msg <- receiveDataMessage conn - respondTo wd sessId ghcSess state (sendTextData conn) msg - serverLoop sessId ghcSess state conn - `catch` \(e :: ConnectionException) -> do - modifyMVar_ sessions (return . delete sessId) - liftIO $ removeDirectoryIfPresent (userDir wd sessId) - - backupApp :: Application - backupApp req 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 - Nothing -> next $ encode $ ErrorMessage "WRONG MESSAGE FORMAT" - Just req -> handleErrors wd req (next . encode) - $ do resp <- modifyMVar state (\st -> swap <$> reflectGhc (runStateT (updateClient (userDir wd id) req) st) ghcSess) - case resp of Just respMsg -> next $ encode respMsg - Nothing -> return () - --- | 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 (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 (mkModuleName name)) True Nothing) - lift $ load LoadAllTargets - mod <- lift $ getModSummary (mkModuleName name) >>= parseTyped - modify $ refSessMods .- Map.insert (dir, name, NormalHs) mod - return Nothing -updateClient dir (ModuleDeleted name) = do - lift $ removeTarget (TargetModule (mkModuleName name)) - modify $ refSessMods .- Map.delete (dir, name, NormalHs) - return Nothing -updateClient dir (InitialProject modules) = do - -- clean the workspace to remove source files from earlier sessions - liftIO $ removeDirectoryIfPresent dir - liftIO $ createDirectoryIfMissing True dir - liftIO $ forM modules $ \(mod, cont) -> do - withBinaryFile (toFileName dir mod) WriteMode (`hPutStr` cont) - lift $ setTargets (map ((\modName -> Target (TargetModule (mkModuleName modName)) True Nothing) . fst) modules) - lift $ load LoadAllTargets - forM (map fst modules) $ \modName -> do - mod <- lift $ getModSummary (mkModuleName modName) >>= parseTyped - modify $ refSessMods .- Map.insert (dir, modName, NormalHs) mod - return Nothing -updateClient _ (PerformRefactoring "UpdateAST" modName _ _) = do - mod <- gets (find ((modName ==) . (\(_,m,_) -> m) . fst) . Map.assocs . (^. refSessMods)) - case mod of Just (_,m) -> return $ Just $ ASTViewContent $ astDebug m - Nothing -> return $ Just $ ErrorMessage "The module is not found" -updateClient _ (PerformRefactoring "TestErrorLogging" _ _ _) = error "This is a test" -updateClient dir (PerformRefactoring refact modName selection args) = do - mod <- gets (find ((modName ==) . (\(_,m,_) -> m) . fst) . Map.assocs . (^. refSessMods)) - allModules <- gets (map moduleNameAndContent . Map.assocs . (^. refSessMods)) - let command = analyzeCommand (toFileName dir modName) refact (selection:args) - liftIO $ putStrLn $ (toFileName dir modName) - liftIO $ putStrLn $ maybe "" (show . getRange . (^. annotation&sourceInfo) . snd) mod - case mod of Just m -> do res <- lift $ performCommand command (moduleNameAndContent m) allModules - case res of - Left err -> return $ Just $ ErrorMessage err - Right diff -> do applyChanges diff - return $ Just $ RefactorChanges (map trfDiff diff) - Nothing -> return $ Just $ ErrorMessage "The module is not found" - where trfDiff (ContentChanged (name,cont)) = (name, Just (prettyPrint cont)) - trfDiff (ModuleRemoved name) = (name, Nothing) - - applyChanges - = mapM_ $ \case - ContentChanged (n,m) -> do - liftIO $ withBinaryFile (toFileName dir n) WriteMode (`hPutStr` prettyPrint m) - w <- gets (find ((n ==) . (\(_,m,_) -> m)) . Map.keys . (^. refSessMods)) - newm <- lift $ (parseTyped =<< loadModule dir n) - modify $ refSessMods .- Map.insert (dir, n, NormalHs) newm - ModuleRemoved mod -> do - liftIO $ removeFile (toFileName dir mod) - modify $ refSessMods .- Map.delete (dir, mod, NormalHs) - -createFileForModule :: FilePath -> String -> String -> IO () -createFileForModule dir name newContent = do - let fname = toFileName dir name - createDirectoryIfMissing True (takeDirectory fname) - withBinaryFile fname WriteMode (`hPutStr` newContent) - -removeDirectoryIfPresent :: FilePath -> IO () -removeDirectoryIfPresent dir = removeDirectoryRecursive dir `catch` \e -> if isDoesNotExistError e then return () else throwIO e - -moduleNameAndContent :: ((String,String,IsBoot), mod) -> (String, mod) -moduleNameAndContent ((_,name,_), mod) = (name, mod) - -dataDirs :: FilePath -> FilePath -dataDirs wd = normalise $ wd </> "demoSources" - -userDir :: FilePath -> ClientId -> FilePath -userDir wd id = dataDirs wd </> show id - -initGhcSession :: FilePath -> IO Session -initGhcSession workingDir = Session <$> (newIORef =<< runGhc (Just libdir) (do - dflags <- getSessionDynFlags - -- don't generate any code - setSessionDynFlags - $ flip gopt_set Opt_KeepRawTokenStream - $ flip gopt_set Opt_NoHsMain - $ dflags { importPaths = [workingDir] - , hscTarget = HscAsm -- needed for static pointers - , ghcLink = LinkInMemory - , ghcMode = CompManager - } - getSession)) - -handleErrors :: FilePath -> ClientMessage -> (ResponseMsg -> IO ()) -> IO () -> IO () -handleErrors wd req next io = io `catch` (next <=< handleException) - where handleException :: SomeException -> IO ResponseMsg - handleException e - | Just (se :: SourceError) <- fromException e - = return $ CompilationProblem (concatMap (\msg -> showMsg msg ++ "\n\n") $ bagToList $ srcErrorMessages se) - | Just (ae :: AsyncException) <- fromException e = throw ae - | Just (ge :: GhcException) <- fromException e = return $ ErrorMessage $ show ge - | otherwise = do logToFile wd (show e) req - return $ ErrorMessage (showInternalError e) - - showMsg msg = showSpan (errMsgSpan msg) ++ "\n" ++ show msg - showSpan (RealSrcSpan sp) = showFileName (srcLocFile (realSrcSpanStart sp)) ++ " " ++ show (srcLocLine (realSrcSpanStart sp)) ++ ":" ++ show (srcLocCol (realSrcSpanStart sp)) - showSpan _ = "" - - showFileName = joinPath . drop 2 . splitPath . makeRelative wd . unpackFS - - showInternalError :: SomeException -> String - showInternalError e = "An internal error happened. The report has been sent to the developers. " ++ show e - -logToFile :: FilePath -> String -> ClientMessage -> IO () -logToFile wd err input = do - let msg = err ++ "\n with input: " ++ show input - withFile logFile AppendMode $ \handle -> do - size <- hFileSize handle - when (size < logSizeLimit) $ hPutStrLn handle ("\n### " ++ msg) - `catch` \e -> print ("The error message cannot be logged because: " - ++ show (e :: IOException) ++ "\nHere is the message:\n" ++ msg) - where logFile = wd </> "error-log.txt" - logSizeLimit = 100 * 1024 * 1024 -- 100 MB - -data ClientMessage - = KeepAlive - | InitialProject { initialModules :: [(String,String)] } - | PerformRefactoring { refactoring :: String - , moduleName :: String - , editorSelection :: String - , details :: [String] - } - | ModuleChanged { moduleName :: String - , newContent :: String - } - | ModuleDeleted { moduleName :: String } - deriving (Eq, Show, Generic) - -instance ToJSON ClientMessage -instance FromJSON ClientMessage - -data ResponseMsg - = RefactorChanges { moduleChanges :: [(String, Maybe String)] } - | ASTViewContent { astContent :: String } - | ErrorMessage { errorMsg :: String } - | CompilationProblem { errorMsg :: String } - deriving (Eq, Show, Generic) +import Language.Haskell.Tools.Demo -instance ToJSON ResponseMsg -instance FromJSON ResponseMsg +main = runFromCLI
haskell-tools-demo.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-demo -version: 0.2.0.0 +version: 0.3.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 @@ -15,29 +15,27 @@ main-is: Main.hs other-modules: Language.Haskell.Tools.ASTDebug , Language.Haskell.Tools.ASTDebug.Instances + , Language.Haskell.Tools.Demo ghc-options: -with-rtsopts=-M1500m - build-depends: base >=4.8 && <5.0 - , ghc >=7.10 && <8.1 - , mtl >=2.2 && <2.3 - , transformers >= 0.4 - , references >= 0.3.1 - , directory >= 1.2.6 - , ghc-paths >= 0.1.0 - , containers >= 0.5.7 - , http-types >= 0.9.1 - , warp >= 3.2.8 - , wai >= 3.2.1 - , websockets >= 0.9.6.1 && < 1.0 - , wai-websockets >= 3.0.1 - , aeson >= 0.10.0 - , bytestring - , filepath - , haskell-tools-ast >=0.2 && <0.3 - , haskell-tools-ast-fromghc >=0.2 && <0.3 - , haskell-tools-ast-trf >=0.2 && <0.3 - , haskell-tools-prettyprint >=0.2 && <0.3 - , haskell-tools-refactor >=0.2 && <0.3 - - + build-depends: base >= 4.9 && < 4.10 + , mtl >= 2.2 && < 2.3 + , transformers >= 0.5 && < 0.6 + , directory >= 1.2 && < 1.3 + , containers >= 0.5 && < 0.6 + , aeson >= 0.11 && < 0.12 + , bytestring >= 0.10 && < 0.11 + , http-types >= 0.9 && < 0.10 + , warp >= 3.2 && < 3.3 + , wai >= 3.2 && < 3.3 + , websockets >= 0.9 && < 0.10 + , wai-websockets >= 3.0 && < 3.1 + , references >= 0.3 && < 0.4 + , ghc >= 8.0 && < 8.1 + , ghc-paths >= 0.1 && < 0.2 + , filepath >= 1.4 && < 1.5 + , haskell-tools-ast >= 0.3 && < 0.4 + , haskell-tools-backend-ghc >= 0.3 && < 0.4 + , haskell-tools-prettyprint >= 0.3 && < 0.4 + , haskell-tools-refactor >= 0.3 && < 0.4 default-language: Haskell2010