haskell-tools-demo 0.3.0.1 → 0.4.0.0
raw patch · 10 files changed
+818/−662 lines, 10 filesdep +HUnitdep +haskell-tools-demodep +networkdep ~filepathdep ~haskell-tools-astdep ~haskell-tools-backend-ghcnew-component:exe:ht-demo
Dependencies added: HUnit, haskell-tools-demo, network, tasty, tasty-hunit
Dependency ranges changed: filepath, haskell-tools-ast, haskell-tools-backend-ghc, haskell-tools-prettyprint, haskell-tools-refactor
Files
- Language/Haskell/Tools/ASTDebug.hs +0/−227
- Language/Haskell/Tools/ASTDebug/Instances.hs +0/−157
- Language/Haskell/Tools/Demo.hs +0/−262
- Main.hs +0/−5
- exe/Main.hs +5/−0
- haskell-tools-demo.cabal +36/−11
- src/Language/Haskell/Tools/ASTDebug.hs +236/−0
- src/Language/Haskell/Tools/ASTDebug/Instances.hs +157/−0
- src/Language/Haskell/Tools/Demo.hs +262/−0
- test/Main.hs +122/−0
− Language/Haskell/Tools/ASTDebug.hs
@@ -1,227 +0,0 @@-{-# LANGUAGE TypeOperators - , DefaultSignatures - , StandaloneDeriving - , FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - , TemplateHaskell - , OverloadedStrings - , ConstraintKinds - , LambdaCase - , ViewPatterns - , ScopedTypeVariables - , UndecidableInstances - #-} --- | 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 Outputable - -import DynFlags as GHC -import Name as GHC -import Id as GHC -import RdrName 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 - - -data DebugNode dom = TreeNode { _nodeLabel :: String - , _nodeSubtree :: TreeDebugNode dom - } - | SimpleNode { _nodeLabel :: String - , _nodeValue :: String - } - -deriving instance Domain dom => Show (DebugNode dom) - -data TreeDebugNode dom - = TreeDebugNode { _nodeName :: String - , _nodeInfo :: SemanticInfoType dom - , _children :: [DebugNode dom] - } - -deriving instance Domain dom => Show (TreeDebugNode dom) - -data SemanticInfoType dom - = DefaultInfoType { semaInfoTypeRng :: SrcSpan - } - | NameInfoType { semaInfoTypeName :: SemanticInfo' dom SameInfoNameCls - , semaInfoTypeRng :: SrcSpan - } - | ExprInfoType { semaInfoTypeExpr :: SemanticInfo' dom SameInfoExprCls - , semaInfoTypeRng :: SrcSpan - } - | ImportInfoType { semaInfoTypeImport :: SemanticInfo' dom SameInfoImportCls - , semaInfoTypeRng :: SrcSpan - } - | ModuleInfoType { semaInfoTypeModule :: SemanticInfo' dom SameInfoModuleCls - , semaInfoTypeRng :: SrcSpan - } - | ImplicitFieldInfoType { semaInfoTypeImplicitFld :: SemanticInfo' dom SameInfoWildcardCls - , semaInfoTypeRng :: SrcSpan - } - - -deriving instance Domain dom => Show (SemanticInfoType dom) - -makeReferences ''DebugNode -makeReferences ''TreeDebugNode - -type AssocSema dom = ( AssocData (SemanticInfo' dom SameInfoModuleCls), AssocData (SemanticInfo' dom SameInfoImportCls) - , AssocData (SemanticInfo' dom SameInfoNameCls), AssocData (SemanticInfo' dom SameInfoExprCls) - , AssocData (SemanticInfo' dom SameInfoWildcardCls) ) - -astDebug :: (ASTDebug e dom st, AssocSema dom) => e dom st -> String -astDebug ast = toList (astDebugToJson (astDebug' ast)) - -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 - first:rest -> first >< foldl (><) Seq.empty (fmap (fromList ", " ><) (fromList rest)) - [] -> Seq.empty - debugTreeNode (TreeNode "" s) = astDebugElemJson s - debugTreeNode (TreeNode (dropWhile (=='_') -> l) s) = astDebugElemJson (nodeName .- (("<span class='astlab'>" ++ l ++ "</span>: ") ++) $ s) - -astDebugElemJson :: AssocSema dom => TreeDebugNode dom -> Seq Char -astDebugElemJson (TreeDebugNode name info children) - = fromList "{ \"text\" : \"" >< fromList name - >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" - >< fromList (shortShowSpan (semaInfoTypeRng info)) - >< fromList "\", \"data-elems\" : \"" - >< foldl (><) Seq.empty dataElems - >< fromList "\", \"data-sema\" : \"" - >< fromList (showSema info) - >< 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) - -class AssocData a where - assocName :: a -> String - toAssoc :: a -> [(String, String)] - -instance AssocSema dom => AssocData (SemanticInfoType dom) where - assocName s@(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 s@(NameInfoType {}) = toAssoc (semaInfoTypeName s) - toAssoc s@(ExprInfoType {}) = toAssoc (semaInfoTypeExpr s) - toAssoc s@(ImportInfoType {}) = toAssoc (semaInfoTypeImport s) - toAssoc s@(ModuleInfoType {}) = toAssoc (semaInfoTypeModule s) - toAssoc s@(ImplicitFieldInfoType {}) = toAssoc (semaInfoTypeImplicitFld s) - - -instance AssocData ScopeInfo where - assocName si = "ScopeInfo" - toAssoc si = [ ("namesInScope", inspectScope (semanticsScope si)) ] - -instance HasNameInfo' (NameInfo n) => AssocData (NameInfo n) where - assocName si = "NameInfo" - - toAssoc ni = [ ("name", maybe "<ambiguous>" inspect (semanticsName ni)) - , ("isDefined", show (semanticsDefining 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)) - ] - -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 (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" - 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) - -class InspectableName n where - inspect :: n -> String - -instance InspectableName GHC.Name where - inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "]" - -instance InspectableName GHC.RdrName where - inspect name = showSDocUnsafe (ppr name) - -instance InspectableName GHC.Id where - inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "] :: " ++ showSDocOneLine unsafeGlobalDynFlags (ppr (idType name)) - -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 - gAstDebug :: f p -> [DebugNode dom] - -instance GAstDebug V1 dom where - gAstDebug _ = error "GAstDebug V1" - -instance GAstDebug U1 dom where - 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 ++ 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))] - -instance (GAstDebug f dom, Selector s) => GAstDebug (M1 S s f) dom where - gAstDebug s@(M1 x) = traversal&nodeLabel .= selName s $ gAstDebug x - --- don't have to do anything with datatype metainfo -instance GAstDebug f dom => GAstDebug (M1 D t f) dom where - gAstDebug (M1 x) = gAstDebug x
− Language/Haskell/Tools/ASTDebug/Instances.hs
@@ -1,157 +0,0 @@-{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , StandaloneDeriving - , DeriveGeneric - , UndecidableInstances - , TypeFamilies - #-} -module Language.Haskell.Tools.ASTDebug.Instances where - -import Language.Haskell.Tools.ASTDebug - -import GHC.Generics -import Control.Reference - -import Language.Haskell.Tools.AST - --- Annotations -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 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 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 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 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 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 (AnnListG e) dom st where - astDebug' (AnnListG a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] - -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 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 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 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 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 - --- 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 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 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 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
@@ -1,262 +0,0 @@-{-# 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
@@ -1,5 +0,0 @@-module Main where - -import Language.Haskell.Tools.Demo - -main = runFromCLI
+ exe/Main.hs view
@@ -0,0 +1,5 @@+module Main where + +import Language.Haskell.Tools.Demo + +main = runFromCLI
haskell-tools-demo.cabal view
@@ -1,5 +1,5 @@ name: haskell-tools-demo -version: 0.3.0.1 +version: 0.4.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 @@ -11,13 +11,12 @@ build-type: Simple cabal-version: >=1.10 -executable haskell-tools-demo - main-is: Main.hs +library + hs-source-dirs: src + ghc-options: -O2 + exposed-modules: Language.Haskell.Tools.Demo other-modules: Language.Haskell.Tools.ASTDebug , Language.Haskell.Tools.ASTDebug.Instances - , Language.Haskell.Tools.Demo - ghc-options: -with-rtsopts=-M1500m - build-depends: base >= 4.9 && < 4.10 , mtl >= 2.2 && < 2.3 , transformers >= 0.5 && < 0.6 @@ -34,8 +33,34 @@ , 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+ , haskell-tools-ast >= 0.4 && < 0.5 + , haskell-tools-backend-ghc >= 0.4 && < 0.5 + , haskell-tools-prettyprint >= 0.4 && < 0.5 + , haskell-tools-refactor >= 0.4 && < 0.5 + default-language: Haskell2010 + +executable ht-demo + main-is: Main.hs + hs-source-dirs: exe + ghc-options: -with-rtsopts=-M1500m -O2 + build-depends: base >= 4.9 && < 4.10 + , haskell-tools-demo >= 0.4 && < 0.5 + default-language: Haskell2010 + +test-suite haskell-tools-demo-tests + type: exitcode-stdio-1.0 + ghc-options: -with-rtsopts=-M2g -O2 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.9 && < 4.10 + , HUnit >= 1.3 && < 1.4 + , tasty >= 0.11 && < 0.12 + , tasty-hunit >= 0.9 && < 0.10 + , directory >= 1.2 && < 1.3 + , filepath >= 1.4 && < 2.0 + , bytestring >= 0.10 && < 0.11 + , network >= 2.6 && < 2.7 + , websockets >= 0.9 && < 0.10 + , aeson >= 0.11 && < 0.12 + , haskell-tools-demo >= 0.4 && < 0.5 + default-language: Haskell2010
+ src/Language/Haskell/Tools/ASTDebug.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE TypeOperators + , DefaultSignatures + , StandaloneDeriving + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , TypeFamilies + , TemplateHaskell + , OverloadedStrings + , ConstraintKinds + , LambdaCase + , ViewPatterns + , ScopedTypeVariables + , UndecidableInstances + #-} +-- | 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 Outputable + +import DynFlags as GHC +import Name as GHC +import Id as GHC +import RdrName as GHC +import Unique as GHC +import Type 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 + + +data DebugNode dom = TreeNode { _nodeLabel :: String + , _nodeSubtree :: TreeDebugNode dom + } + | SimpleNode { _nodeLabel :: String + , _nodeValue :: String + } + +deriving instance Domain dom => Show (DebugNode dom) + +data TreeDebugNode dom + = TreeDebugNode { _nodeName :: String + , _nodeInfo :: SemanticInfoType dom + , _children :: [DebugNode dom] + } + +deriving instance Domain dom => Show (TreeDebugNode dom) + +data SemanticInfoType dom + = DefaultInfoType { semaInfoTypeRng :: SrcSpan + } + | NameInfoType { semaInfoTypeName :: SemanticInfo' dom SameInfoNameCls + , semaInfoTypeRng :: SrcSpan + } + | ExprInfoType { semaInfoTypeExpr :: SemanticInfo' dom SameInfoExprCls + , semaInfoTypeRng :: SrcSpan + } + | ImportInfoType { semaInfoTypeImport :: SemanticInfo' dom SameInfoImportCls + , semaInfoTypeRng :: SrcSpan + } + | ModuleInfoType { semaInfoTypeModule :: SemanticInfo' dom SameInfoModuleCls + , semaInfoTypeRng :: SrcSpan + } + | ImplicitFieldInfoType { semaInfoTypeImplicitFld :: SemanticInfo' dom SameInfoWildcardCls + , semaInfoTypeRng :: SrcSpan + } + + +deriving instance Domain dom => Show (SemanticInfoType dom) + +makeReferences ''DebugNode +makeReferences ''TreeDebugNode + +type AssocSema dom = ( AssocData (SemanticInfo' dom SameInfoModuleCls), AssocData (SemanticInfo' dom SameInfoImportCls) + , AssocData (SemanticInfo' dom SameInfoNameCls), AssocData (SemanticInfo' dom SameInfoExprCls) + , AssocData (SemanticInfo' dom SameInfoWildcardCls) ) + +astDebug :: (ASTDebug e dom st, AssocSema dom) => e dom st -> String +astDebug ast = toList (astDebugToJson (astDebug' ast)) + +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 + first:rest -> first >< foldl (><) Seq.empty (fmap (fromList ", " ><) (fromList rest)) + [] -> Seq.empty + debugTreeNode (TreeNode "" s) = astDebugElemJson s + debugTreeNode (TreeNode (dropWhile (=='_') -> l) s) = astDebugElemJson (nodeName .- (("<span class='astlab'>" ++ l ++ "</span>: ") ++) $ s) + +astDebugElemJson :: AssocSema dom => TreeDebugNode dom -> Seq Char +astDebugElemJson (TreeDebugNode name info children) + = fromList "{ \"text\" : \"" >< fromList name + >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" + >< fromList (shortShowSpan (semaInfoTypeRng info)) + >< fromList "\", \"data-elems\" : \"" + >< foldl (><) Seq.empty dataElems + >< fromList "\", \"data-sema\" : \"" + >< fromList (showSema info) + >< 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) + +class AssocData a where + assocName :: a -> String + toAssoc :: a -> [(String, String)] + +instance AssocSema dom => AssocData (SemanticInfoType dom) where + assocName s@(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 s@(NameInfoType {}) = toAssoc (semaInfoTypeName s) + toAssoc s@(ExprInfoType {}) = toAssoc (semaInfoTypeExpr s) + toAssoc s@(ImportInfoType {}) = toAssoc (semaInfoTypeImport s) + toAssoc s@(ModuleInfoType {}) = toAssoc (semaInfoTypeModule s) + toAssoc s@(ImplicitFieldInfoType {}) = toAssoc (semaInfoTypeImplicitFld s) + + +instance AssocData ScopeInfo where + assocName si = "ScopeInfo" + toAssoc si = [ ("namesInScope", inspectScope (semanticsScope si)) ] + +instance HasNameInfo' (NameInfo n) => AssocData (NameInfo n) where + assocName si = "NameInfo" + + toAssoc ni = [ ("name", maybe "<ambiguous>" inspect (semanticsName ni)) + , ("isDefined", show (semanticsDefining 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)) + ] + +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 (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" + 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) + +class InspectableName n where + inspect :: n -> String + +instance InspectableName GHC.Name where + inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "]" + +instance InspectableName GHC.RdrName where + inspect name = showSDocUnsafe (ppr name) + +instance InspectableName GHC.Id where + inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "] :: " ++ showSDocOneLine unsafeGlobalDynFlags (ppr (idType name)) ++ " (" ++ addendum ++ ")" + where addendum = concat $ intersperse "," $ map (\v -> showSDocUnsafe (ppr v) ++ "[" ++ show (getUnique v) ++ "]") (getTVs (idType name)) + +getTVs :: GHC.Type -> [GHC.Var] +getTVs t + | Just tv <- getTyVar_maybe t = [tv] + | Just (op, arg) <- splitAppTy_maybe t = getTVs op `union` getTVs arg + | Just (_, t') <- splitForAllTy_maybe t = getTVs t' + | otherwise = [] + +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 + gAstDebug :: f p -> [DebugNode dom] + +instance GAstDebug V1 dom where + gAstDebug _ = error "GAstDebug V1" + +instance GAstDebug U1 dom where + 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 ++ 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))] + +instance (GAstDebug f dom, Selector s) => GAstDebug (M1 S s f) dom where + gAstDebug s@(M1 x) = traversal&nodeLabel .= selName s $ gAstDebug x + +-- don't have to do anything with datatype metainfo +instance GAstDebug f dom => GAstDebug (M1 D t f) dom where + gAstDebug (M1 x) = gAstDebug x
+ src/Language/Haskell/Tools/ASTDebug/Instances.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , StandaloneDeriving + , DeriveGeneric + , UndecidableInstances + , TypeFamilies + #-} +module Language.Haskell.Tools.ASTDebug.Instances where + +import Language.Haskell.Tools.ASTDebug + +import GHC.Generics +import Control.Reference + +import Language.Haskell.Tools.AST + +-- Annotations +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 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 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 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 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 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 (AnnListG e) dom st where + astDebug' (AnnListG a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] + +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 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 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 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 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 + +-- 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 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 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 UPhaseControl dom st +instance (Domain dom, SourceInfo st) => ASTDebug PhaseNumber dom st +instance (Domain dom, SourceInfo st) => ASTDebug PhaseInvert dom st
+ src/Language/Haskell/Tools/Demo.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE OverloadedStrings + , DeriveGeneric + , TypeApplications + , TupleSections + , ScopedTypeVariables + , LambdaCase + , TemplateHaskell + , PatternGuards + , FlexibleContexts + #-} + +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.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 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) + , _isDisconnecting :: Bool + } + +makeReferences ''RefactorSessionState + +initSession :: RefactorSessionState +initSession = RefactorSessionState Map.empty Nothing False + +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 + currState <- readMVar state + if currState ^. isDisconnecting + then sendClose conn ("" :: ByteString) + else 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: " ++ show (BS.unpack mess)) + 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 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 + 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 (filter ((modName /=) . (^. sfkModuleName) . fst) . map moduleNameAndContent . Map.assocs . (^. refSessMods)) + let command = analyzeCommand refact (selection:args) + 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 (key,cont)) = (key ^. sfkModuleName, Just (prettyPrint cont)) + trfDiff (ModuleCreated name mod _) = (name, Just (prettyPrint mod)) + trfDiff (ModuleRemoved name) = (name, Nothing) + + applyChanges + = mapM_ $ \case + ModuleCreated n m _ -> writeModule n m + ContentChanged (n,m) -> writeModule (n ^. sfkModuleName) m + ModuleRemoved mod -> do + liftIO $ removeFile (toFileName dir mod) + modify $ refSessMods .- Map.delete (dir, mod, NormalHs) + + writeModule 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 + +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) -> (SourceFileKey, mod) +moduleNameAndContent ((_,name,isBoot), mod) = (SourceFileKey isBoot 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) (initGhcFlagsForTest >> useDirs [workingDir] >> 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 } + | Disconnect + deriving (Show, Generic) + +instance FromJSON ClientMessage + +data ResponseMsg + = RefactorChanges { moduleChanges :: [(String, Maybe String)] } + | ASTViewContent { astContent :: String } + | ErrorMessage { errorMsg :: String } + | CompilationProblem { errorMsg :: String } + | Disconnected + deriving (Show, Generic) + +instance ToJSON ResponseMsg
+ test/Main.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE StandaloneDeriving, LambdaCase #-} +module Main where + +import Test.Tasty +import Test.Tasty.HUnit +import System.Exit +import System.Directory +import System.FilePath +import Control.Monad +import Control.Exception +import Control.Concurrent +import Control.Concurrent.MVar +import Network.WebSockets +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.List as List +import Data.Aeson +import Data.Maybe +import System.IO +import System.Directory + +import Debug.Trace + +import Language.Haskell.Tools.Demo + +main :: IO () +main = do -- create one daemon process for the whole testing session + -- with separate processes it is not a problem + threadId <- forkIO $ runDemo [] + defaultMain allTests + killThread threadId + +allTests :: TestTree +allTests + = localOption (mkTimeout ({- 10s -} 1000 * 1000 * 10)) + $ testGroup "daemon-tests" + [ testGroup "simple-tests" $ map makeDemoTest simpleTests + , testGroup "loading-tests" $ map makeDemoTest loadingTests + , testGroup "refactor-tests" $ map makeDemoTest refactorTests + , astViewTest + ] + +simpleTests :: [(String, [ClientMessage], [ResponseMsg])] +simpleTests = + [ ( "empty-test", [], [] ) + , ( "keep-alive", [KeepAlive], [] ) + ] + +loadingTests :: [(String, [ClientMessage], [ResponseMsg])] +loadingTests = + [ ( "one-module" + , [InitialProject [("A", "module A where\n\na = ()")]] + , [] ) + , ( "multi-modules" + , [InitialProject [("A", "module A where\n\na = ()"), ("B", "module B where\n\nimport A\n\nb = a")]] + , [] ) + , ( "multi-modules-wrong-order" + , [InitialProject [("B", "module B where\n\nimport A\n\nb = a"), ("A", "module A where\n\na = ()")]] + , [] ) + , ( "multi-modules-added-later" + , [ InitialProject [("A", "module A where\n\na = ()")] + , ModuleChanged "B" "module B where\n\nimport A\n\nb = a" ] + , [] ) + , ( "comp-problem" + , [InitialProject [("A", "module A where\n\na = noSuchVar")]] + , [CompilationProblem "A.hs 3:5\nVariable not in scope: noSuchVar\n\n"] ) + ] + +refactorTests :: [(String, [ClientMessage], [ResponseMsg])] +refactorTests = + [ ( "simple-refactor" + , [ InitialProject [("A", "module A where\n\na = ()")] + , PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["x"] ] + , [ RefactorChanges [("A", Just "module A where\n\nx = ()")] ] ) + , ( "multi-module-refactor" + , [ InitialProject [("A", "module A where\n\na = ()"), ("B", "module B where\n\nimport A\n\nb = a")] + , PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["x"] ] + , [ RefactorChanges [("A", Just "module A where\n\nx = ()"), ("B", Just "module B where\n\nimport A\n\nb = x")] ] ) + , ( "rename-module" + , [ InitialProject [("A", "module A where\n\na = ()")] + , PerformRefactoring "RenameDefinition" "A" "1:8-1:9" ["AA"] ] + , [ RefactorChanges [("AA", Just "module AA where\n\na = ()"), ("A", Nothing)] ] ) + , ( "change-module" + , [ InitialProject [("A", "module A where\n\na = ()")] + , ModuleChanged "A" "module A where\n\n\na = ()" + , PerformRefactoring "RenameDefinition" "A" "4:1-4:2" ["x"] ] + , [ RefactorChanges [("A", Just "module A where\n\n\nx = ()")] ] ) + , ( "removed-module" + , [ InitialProject [("A", "module A where\n\na = ()"), ("B", "module B where\n\nimport A\n\nb = a")] + , ModuleDeleted "B" + , PerformRefactoring "RenameDefinition" "A" "3:1-3:2" ["x"] ] + , [ RefactorChanges [("A", Just "module A where\n\nx = ()")] ] ) + ] + +makeDemoTest :: (String, [ClientMessage], [ResponseMsg]) -> TestTree +makeDemoTest (label, input, expected) = testCase label $ do + actual <- communicateWithDemo input + assertEqual "" expected actual + +astViewTest :: TestTree +astViewTest = testCase "ast-view-test" $ do + actual <- communicateWithDemo [ InitialProject [("A", "module A where\n\na = ()")] + , PerformRefactoring "UpdateAST" "A" "1:1" [] ] + assertBool "The response must be a simple ASTViewContent message" + $ case actual of [ ASTViewContent _ ] -> True + _ -> False + +communicateWithDemo :: [ClientMessage] -> IO [ResponseMsg] +communicateWithDemo msgs = runClient "127.0.0.1" 8206 "/" $ \conn -> do + mapM (sendTextData conn . encode) (msgs ++ [Disconnect]) + receiveAllResponses conn + +receiveAllResponses :: Connection -> IO [ResponseMsg] +receiveAllResponses conn = do + Text mess <- receiveDataMessage conn + let decoded = decode mess + case decoded of Just Disconnected -> return [] + Just other -> (other :) <$> receiveAllResponses conn + _ -> error ("Unrecognized response: " ++ BS.unpack mess) + +deriving instance Eq ResponseMsg +instance FromJSON ResponseMsg +instance ToJSON ClientMessage