diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Haskell-Tools is Copyright (c) Boldizsár Németh, 2016, all rights reserved, +and is distributed as free software under the following license. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +- Redistributions of source code must retain the above copyright +notice, this list of conditions, and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions, and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- The names of the copyright holders may not be used to endorse or +promote products derived from this software without specific prior +written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/Haskell/Tools/ASTDebug.hs b/Language/Haskell/Tools/ASTDebug.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/ASTDebug.hs @@ -0,0 +1,237 @@ +{-# 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.AnnTrf.RangeToRangeTemplate +import Language.Haskell.Tools.AnnTrf.RangeTemplate +import Language.Haskell.Tools.AnnTrf.SourceTemplate +--import Language.Haskell.Tools.Refactor.RangeDebug + + +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 .- (("" ++ l ++ ": ") ++) $ 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 = "
" ++ l ++ ": " ++ tail (init (show v)) ++ "
" + showSema info = "
" ++ assocName info ++ "
" + ++ concatMap (\(l,i) -> "
" ++ l ++ ": " ++ i ++ "
") (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 (ScopeInfo {}) = "ScopeInfo" + toAssoc (ScopeInfo locals) = [ ("namesInScope", inspectScope locals) ] + +instance InspectableName n => AssocData (NameInfo n) where + assocName (NameInfo {}) = "NameInfo" + assocName (AmbiguousNameInfo {}) = "AmbiguousNameInfo" + assocName (ImplicitNameInfo {}) = "ImplicitNameInfo" + + 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) + ] +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) + ] + +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 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 AssocData ImplicitFieldInfo where + assocName (ImplicitFieldInfo {}) = "ImplicitFieldInfo" + toAssoc (ImplicitFieldInfo bnds) = [ ("bindings", concat (intersperse ", " (map (\(from,to) -> "(" ++ inspect from ++ " -> " ++ inspect to ++ ")") bnds))) + ] + +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 diff --git a/Language/Haskell/Tools/ASTDebug/Instances.hs b/Language/Haskell/Tools/ASTDebug/Instances.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/ASTDebug/Instances.hs @@ -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 QualifiedName dom st) => ASTDebug (Ann QualifiedName) 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 + 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 + 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 + 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 + 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 (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 (AnnMaybe e) dom st where + astDebug' (AnnMaybe 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 + +-- 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 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 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 + +-- 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 + +-- 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 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 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 PhaseNumber dom st +instance (Domain dom, SourceInfo st) => ASTDebug PhaseInvert dom st diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,259 @@ +{-# 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) + +instance ToJSON ResponseMsg +instance FromJSON ResponseMsg diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-tools-demo.cabal b/haskell-tools-demo.cabal new file mode 100644 --- /dev/null +++ b/haskell-tools-demo.cabal @@ -0,0 +1,43 @@ +name: haskell-tools-demo +version: 0.2.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 +license: BSD3 +license-file: LICENSE +author: Zoltán Kelemen +maintainer: kelemzol@elte.hu +category: Language +build-type: Simple +cabal-version: >=1.10 + +executable haskell-tools-demo + main-is: Main.hs + other-modules: Language.Haskell.Tools.ASTDebug + , Language.Haskell.Tools.ASTDebug.Instances + 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 + + + default-language: Haskell2010