diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..31a6d78 --- /dev/null +++ b/.gitignore @@ -0,0 +1,10 @@ +*.swp +dist/ + +# cabal sandbox +.cabal-sandbox/ +cabal.sandbox.config + +# stack sandbox +.stack-work/ + diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..b4d78e6 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,28 @@ +sudo: true +language: haskell +cache: + directories: + - "$HOME/.stack" + - "$TRAVIS_BUILD_DIR/.stack-work" +matrix: + include: + - env: BUILD=stack ARGS="" + addons: + apt: + packages: + - libgtk2.0-dev + - libgtk-3-dev + - libgtksourceview-3.0-dev + - happy + - alex + +before_install: +- curl -sSL https://get.haskellstack.org/ | sh + +install: + - stack -j 2 setup --no-terminal + - stack -j 2 build --only-snapshot --no-terminal + +script: + - stack -j 2 build --no-terminal + - stack -j 2 test --no-terminal diff --git a/CHANGES b/CHANGES index 7f1bc7a..d88b999 100644 --- a/CHANGES +++ b/CHANGES @@ -1,11 +1,29 @@ // release history with features and fixed and open bugs +new features implemented in master branch but not part of the latest release +- - - + +0.5 +* new language: Haskell core (edit high level Haskell and see the core ast) + +0.4.1 +* distinguish between source positions and spans + +0.4 +* allowed jumping from text location to corresponding tree (and back) +* removed dependency on glade, now using gtk3 +* manual parser selection in language menu + +0.3 +* removed dynamical extension of languages. The library (see astview.cabal) offers + statically all known languages. + 0.2.1 * removed dependency on astview-utils 0.2 * splitted up state data type -* extended parsers to languages +* extended parsers to languages 0.1.5 * a particular attribute for parsers to specify syntax hightlighting diff --git a/INSTALL b/INSTALL deleted file mode 100644 index 9f2d347..0000000 --- a/INSTALL +++ /dev/null @@ -1,48 +0,0 @@ -Installation and Configuration ------------------------------- - - -Dependencies ------------- - -Astview depends on a number of packages: - - * hint, the haskell interpreter, allows to load custom parsers at - startup. - * gtk2hs, the haskell-bindings to the GTK GUI framework - * syb, the 'scrap-your-boilerplate' approach to generic - programming - - -For details see file 'astview.cabal' and the documentation of gtk2hs -(especially for required system-libraries like gtksourceview) - -The parsers that are initally configured require the packages - - * parsec - * haskell-src-exts - - -Installation ------------- - -We use a custom build to generate HTML-documentation. The custom -Setup.hs needs the package hscolour. You have to install it via - - cabal install hscolour - -To install astview, just run 'cabal install' in the astview-directory. - -To launch astview, just issue the command 'astview' in your -'.cabal/bin' directory. - - -Configuration -------------- - -To add custom parsers, you have to edit the file -~/.cabal/share/astview-a.b/Parsers.hs and conform to the signatures of -the exported function. The parsers have to generate haskell terms -which are fully (i.e. all used types) in the Data class. - -... detailed instructions will follow ... diff --git a/LICENSE b/LICENSE index 6819de0..3e03a9f 100644 --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,4 @@ -astview: View abstract syntax trees for your custom languages and -parsers in a graphical (GTK+) application. - -Copyright (C) 2009 Sebastian Menge and Pascal Hof +Copyright (C) 2009-2015 Sebastian Menge and Pascal Hof Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/README b/README deleted file mode 100644 index 1f97492..0000000 --- a/README +++ /dev/null @@ -1,11 +0,0 @@ -Astview is a graphical viewer for abstract syntax trees. It is -implemented on the basis of scrap-your-boilerplate (i.e. data2tree) -and works with all parsers that generate trees that are instances of -the Data.Data class. Custom parsers can be dynamically loaded (via -package hint) at startup. - -Copyright (c) Pascal Hof and Sebastian Menge - - -Details on installation and configuration of custom parsers can be -found in INSTALL diff --git a/README.md b/README.md new file mode 100644 index 0000000..6e7f07e --- /dev/null +++ b/README.md @@ -0,0 +1,65 @@ + + + +# Astview - Documentation [![Build Status](https://travis-ci.org/pascalh/Astview.png?branch=master)](https://travis-ci.org/pascalh/Astview) + +Astview (short for "abstract syntax tree view") is a little desktop program to be used by people that want +to investigate syntax trees, e.g. students and lecturers in compiler +construction courses. +The program evolved as a case study in datatype-generic programming and +building graphical user interfaces in Haskell. + +![Demo](preview.gif) + +Astview is under continuous development. The sources can be found at [Github](https://github.com/pascalh/Astview). + +Developer documentation is located in the [wiki](https://github.com/pascalh/Astview/wiki/Deveoloper-guide). + +## User guide + +### Installing astview + +First of all download the sources of astview, which can be easily achieved by + +```Bash +git clone https://github.com/pascalh/Astview +``` + +To install astview, just run `stack install` in the astview-directory. + +### Using Astview + +You can open astview directly with a file by giving the filename at the command line: + +```Bash +astview path/to/mysource.hs +``` +or simply start `astview` without arguments and open a file directly via the file menu. + +#### Basic text editor functionality + +The menu file offers the functionality to work with files. +Saving a edited file works as usual: Ctrl-S saves, Save-As has to be done via the menu. +After changing a file in astviews source editor, a star appears in the title bar next to the +filename to indicate that the file has been changed. + +Cut-and-Paste functionality works as usual (Ctrl-C/V/X), allowing to copy-paste source code around. +The correspondent menu items can be found in menu `Edit`. You can use Ctrl-P to reparse the source code and refresh the tree (the shortcut is not displayed in the menu but works anyway). + +#### Language and parser selection + +Astview can be easily extended by new languages (see [dev documentation](https://github.com/pascalh/Astview/wiki/Deveoloper-guide)). Every language +can be associated with file extensions, which for example enables astview to directly apply the parser for +Haskell if a file with extension ```hs``` is being opened. This automatic +parser selection can be turned off by selecting a specific parser +in the menu ```Language```. + +#### Source location specific functionality + +If the current language supports source locations, one can jump from a selected text position in the source editor to the associated position in the abstract syntax tree by clicking on `Navigate/>>>`. + +The menu entry `Navigate/<<<` highlights the corresponding interval in the source editor for the recently selected subtree. + +#### Flattening lists + +One note on the representation of Haskells lists in the tree: By default lists in the abstract syntax tree are flattened, which means that they are displayed as a `n`-ary tuple where `n` is the length of the list. If you like to see the exact Haskell term displayed in the tree view with all of its nested applications of the cons operator, you can disable flattening in menu `Edit`. diff --git a/Setup.hs b/Setup.hs old mode 100755 new mode 100644 index 7b65046..7b7b313 --- a/Setup.hs +++ b/Setup.hs @@ -1,89 +1,4 @@ -#!/usr/bin/runhaskell - -import Distribution.Simple -import Distribution.Simple.Setup (ConfigFlags (..)) -import Distribution.PackageDescription (emptyHookedBuildInfo,HookedBuildInfo(..)) -import Language.Haskell.HsColour (hscolour,Output(CSS)) -import Language.Haskell.HsColour.Colourise (defaultColourPrefs) -import Control.Monad -import Data.Maybe -import Data.List +import Distribution.Simple(defaultMain) main :: IO () -main = defaultMainWithHooks hooks - -hooks :: UserHooks -hooks = simpleUserHooks { preConf = myPreConf } - --- read template file with markers, call replaceOrEcho for each marker -myPreConf :: Args -> ConfigFlags -> IO HookedBuildInfo -myPreConf _ _ = do - putStr "Generating custom html documentation... " - -- file <- readFile "data/astview-tmpl.html" - replaced <- mapM replaceOrEcho . lines =<< readFile "data/astview-tmpl.html" - - putStrLn " done." - writeFile "data/astview.html" (unlines . concat $ replaced) - return emptyHookedBuildInfo - --- echoes the current line, or, if mymatch succeeds: --- replaces the line with colourized haskell code. -replaceOrEcho :: String -> IO [String] -replaceOrEcho s = - if not $ match s - then return [s] - else do - putStr $ (extract s)++" " - file <- readFile ("data/"++(extract s)++".hs.txt") - let replacement = lines $ hscolour - CSS - defaultColourPrefs - False - True - (extract s) - False - file - return ([""] - ++ replacement - ++ [""]) - - --- interface that delegates to various implementations: - --- recognizes Template marker of the form "%%asdf%%" -match :: String -> Bool -match = match0 "%%" - ---extracts the filename from the marker -extract :: String -> String -extract = extract1 "%%" - --------- Implementations -------------- - -match0 :: String -> String -> Bool -match0 p s = take 2 s == p && take 2 (reverse s) == p - -match1 :: String -> String -> Bool -match1 p = liftM2 (&&) - (help p) - (help p . reverse) - where help q = (q ==) . (take (length q)) - -match2 :: String -> String -> Bool -match2 p s = p `isSuffixOf` s && (reverse p) `isPrefixOf` s - -extract1 :: String -> String -> String -extract1 p s = let remainder = (drop (length p) s) in reverse (drop (length p) (reverse remainder) ) - -extract2 :: String -> String -> String -extract2 p s = reverse (drop (length p) (reverse (drop (length p) s))) - - -extract3 :: String -> String -> String -extract3 p s = reverse . drop (length p) $ reverse $ drop (length p) s - - -extract4 :: String -> String -extract4 = help . reverse . help - where help :: String -> String - help = fromJust . (stripPrefix "%%%") +main = defaultMain diff --git a/TODO b/TODO deleted file mode 100644 index 3d34913..0000000 --- a/TODO +++ /dev/null @@ -1,27 +0,0 @@ -user-interface bugs: - * shortcut Ctrl-P visible in Menu (pending) - * open all subtrees - -code improvements: - * Add module descriptions (haddock) - * GTK dialogs with response - * make use of a string substitution package in Setup.hs - to create documentations (e.g. Text.Template) - -feature requests: - * Split function (String -> Tree String) in two functions: - - parse :: String -> a - - toTree :: a -> Tree String - * support jumping to a node in tree by cursor position for - all languages - * srcloc :: Maybe (Either ParsedFile ParsedError-> (Int,Int)) - * load additional parsers at runtime (user-triggered, open file) - * show subtree when subtree is collapsed - * generate and load bnfc-parser at runtime - * generate pdf/png graphs from trees or terms - * define/parse/toTree generically (using generic read) - -misc: - * adjust readme and html documentation to new data types - -bugs: diff --git a/astview.cabal b/astview.cabal index e74c3b5..5433ab7 100755 --- a/astview.cabal +++ b/astview.cabal @@ -1,69 +1,110 @@ Name: astview -Version: 0.2.1 -License: BSD4 +Version: 0.5 +License: MIT License-File: LICENSE -Author: - Pascal Hof , +Author: + Pascal Hof , Sebastian Menge -Maintainer: Sebastian Menge -Synopsis: A GTK-based abstract syntax tree viewer for custom +Maintainer: Pascal Hof +Synopsis: A GTK-based abstract syntax tree viewer for custom languages and parsers -Description: - Astview is a graphical viewer for abstract - syntax trees. It is implemented on the basis - of scrap-your-boilerplate (i.e. data2tree) - and works with all parsers that generate trees - that are instances of the Data.Data class. - Custom parsers can be dynamically loaded - (via package hint) at startup. - . - For installation you need gtk2hs and hscolour before. - The latter will not be automatically installed by - cabal since it is used by Setup.hs. +Description: + Astview is a graphical viewer for abstract + syntax trees. It is implemented on the basis + of scrap-your-boilerplate (i.e. data2tree) + and works with all parsers that generate trees + that are instances of the Data.Data class. +Homepage: https://github.com/pascalh/Astview Category: Language -Cabal-Version: >= 1.2 -Build-Type: Custom -Data-Files: - data/astview.glade - data/Langs/Haskell.hs - data/Langs/Expr.hs - data/Langs/Languages.hs - data/astview.html - data/astview-tmpl.html - data/style.css - data/LICENSE.unwrapped - data/EX1.hs.txt - data/EX2.hs.txt - data/EX3.hs.txt - data/EX4.hs.txt +Cabal-Version: >= 1.8 +Build-Type: Simple +Tested-with: GHC==7.10.1 +Data-Files: data/astview.xml, + data/menu.xml, + LICENSE + +Source-repository head + type: git + location: https://github.com/pascalh/Astview + Library - Hs-Source-Dirs: src + GHC-Options: -Wall + -fno-warn-unused-do-bind + -fno-warn-wrong-do-bind + -fno-warn-hi-shadowing + -fno-warn-name-shadowing + Hs-Source-Dirs: src/core Exposed-Modules: Language.Astview.Language + Language.Astview.SmallestSrcLocContainingCursor Language.Astview.DataTree + Language.Astview.Languages + Other-Modules: Language.Astview.Languages.Haskell + Language.Astview.Languages.HaskellCore + Language.Astview.Languages.Python + Build-Depends: base >= 4.6.0.0 + , containers == 0.5.* + , QuickCheck >= 2.6 + , haskell-src-exts >= 1.13.5 + , language-python + , syb >= 0.3.7 + , syz + , ghc + , ghc-paths == 0.1.* + extensions: FlexibleInstances, + DeriveDataTypeable, + RankNTypes Executable astview - Hs-Source-Dirs: src + Hs-Source-Dirs: src/gui Main-is: Main.hs - GHC-Options: -Wall -fno-warn-unused-do-bind -fno-warn-wrong-do-bind - Other-Modules: Language.Astview.GUI, - Language.Astview.Registry - + GHC-Options: -Wall + -fno-warn-unused-do-bind + -fno-warn-wrong-do-bind + -fno-warn-hi-shadowing + -fno-warn-name-shadowing + Other-Modules: Language.Astview.Gui.Actions + Language.Astview.Gui.GtkActions + Language.Astview.Gui.Init + Language.Astview.Gui.Menu + Language.Astview.Gui.Types Build-Depends: base - , filepath - , bytestring - , Glob + , astview + , filepath >= 1.3 + , bytestring >= 0.10.0.0 + , Glob >= 0.7.2 , containers - , syb - , hint - , glib - , gtk - , glade - , gtksourceview2 - , directory - , mtl - , process - , hscolour - , haskell-src-exts >= 1.9.0 - , parsec + , QuickCheck + , glib >= 0.13 + , gtk3 >= 0.13 + , gtksourceview3 >= 0.13 + , directory >= 1.2.0.0 + , mtl >=2.1.2 + , fclabels >= 2.0.0.5 + + extensions: TemplateHaskell + , TypeOperators + , ScopedTypeVariables + , OverloadedStrings + , DoAndIfThenElse + , CPP + +test-suite basic + type: exitcode-stdio-1.0 + Hs-Source-Dirs: test + main-is: Main.hs + Other-Modules: DataTree + SmallestSrcLocContainingCursor + SourceLocation + build-depends: base, + astview, + containers, + syb, + control-monad-omega >= 0.3, + tasty, + tasty-hunit, + tasty-quickcheck, + QuickCheck + extensions: DeriveDataTypeable, + DeriveFunctor diff --git a/data/EX1.hs.txt b/data/EX1.hs.txt deleted file mode 100644 index 5060d57..0000000 --- a/data/EX1.hs.txt +++ /dev/null @@ -1,4 +0,0 @@ -data Parser - = Parser { name :: String - , exts :: [String] - , tree :: String -> Tree String} diff --git a/data/EX2.hs.txt b/data/EX2.hs.txt deleted file mode 100644 index 102ea59..0000000 --- a/data/EX2.hs.txt +++ /dev/null @@ -1,12 +0,0 @@ -haskell :: Parser -haskell = Parser "Haskell" [".hs"] buildTreeHaskell - -buildTreeHaskell :: String -> Tree String -buildTreeHaskell s = case parseHaskell s of - Right ast -> flat $ data2tree (ast::HsModule) - Left ParseError -> Node "ParseError" [] - -parseHaskell :: (Data a) => String -> Either ParseError a -parseHaskell s = case parseModule s of - ParseOk p -> unsafeCoerce $ Right p - _ -> Left ParseError diff --git a/data/EX3.hs.txt b/data/EX3.hs.txt deleted file mode 100644 index f773f47..0000000 --- a/data/EX3.hs.txt +++ /dev/null @@ -1,2 +0,0 @@ -parsers :: [Parser] -parsers = haskell:stdParserData diff --git a/data/EX4.hs.txt b/data/EX4.hs.txt deleted file mode 100644 index 88d2056..0000000 --- a/data/EX4.hs.txt +++ /dev/null @@ -1,25 +0,0 @@ -user@host:path$ cd ~/.cabal/share/astview-0.2/data -user@host:~/.cabal/share/astview-0.2/data$ ghci Parsers.hs - --- ghci package-messages stripped - -*Parsers> :info Parser -data Parser - = Parser {name :: !String, - exts :: [String], - tree :: String -> Tree String} - --- show all registered parsers -*Parsers> map name parsers -["Haskell","CSV","Expr","Java","IsoPascal","C","Glade","List"] - --- get haskell parser -*Parsers> let haskell = head parsers - --- build a sample tree of strings -*Parsers> let sample = tree haskell "main = putStrLn \"Hello World\"" - --- draw the tree -*Parsers> putStrLn $ Data.Tree.drawTree sample - --- lengthy output follows diff --git a/data/HigherOrderParse.hs b/data/HigherOrderParse.hs deleted file mode 100644 index f3af93b..0000000 --- a/data/HigherOrderParse.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -module HigherOrderParse where - -import Data.Tree - --- |Adapter class for various error types such as BNFCs ErrM etc. --- b is the given polymorphic errortype (e.g. ErrM Program) whose --- parameter is a, thus we require that b -> a. Then a is the right --- result of Either. -class Result b a | b -> a where - from :: b -> Either String a - -instance Result (Maybe a) a where - from (Just a) = Right a - from Nothing = Left "Parse error" - -instance (Show b) => Result (Either b a) a where - from (Right a) = Right a - from (Left e ) = Left $ show e - --- |higher-order build tree -buildTreeGen :: (Result b a) - => (String -> b) -- ^ some parsefunction that results in - -- an instance of Result - -> (a -> Tree String) -- ^ some generic data2tree function - -> String -- ^ some input - -> Tree String -- ^ resulting tree -buildTreeGen parse data2tree s = - case (from $ parse s) of - Right ast -> data2tree ast - Left err -> Node ("Parse Failed: "++err) [] - diff --git a/data/LICENSE.unwrapped b/data/LICENSE.unwrapped deleted file mode 100644 index bf21344..0000000 --- a/data/LICENSE.unwrapped +++ /dev/null @@ -1,9 +0,0 @@ -astview: View abstract syntax trees for your custom languages and parsers in a graphical (GTK+) application. - -Copyright (C) 2009 Sebastian Menge and Pascal Hof - -Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the ``Software''), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHOR(s) BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/data/Langs/Expr.hs b/data/Langs/Expr.hs deleted file mode 100644 index e68768f..0000000 --- a/data/Langs/Expr.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Expr where - --- container -import Data.Tree (Tree(Node,rootLabel)) - --- syb -import Data.Generics (Data) - -import Language.Astview.DataTree (data2tree) - --- local imports -import Language.Astview.Language - --- Parsec (CSV Parser) -import Text.ParserCombinators.Parsec as Parsec - -import Data.Generics hiding (Infix) -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language (javaStyle) -import Text.ParserCombinators.Parsec.Expr - -expr = - Language - "Expr" - [] - [".expr"] - parseExpr - (data2tree::Expr -> Tree String) - Nothing - Nothing - -parseExpr :: String -> Either Error Expr -parseExpr s = case Parsec.parse lexedExpr "unknown" s of - Right p -> Right p - _ -> Left Err - - - --- ------------ a parsec parser ---------------------- - --- a very tiny expr language deriving data -data Expr = Add Expr Expr - | Sub Expr Expr - | I Integer deriving (Show,Data,Typeable) - -runLex :: Show a => Parsec.Parser a -> String -> IO () -runLex p input - = parseTest (do{ whiteSpace - ; x <- p - ; eof - ; return x - }) input - -lexedExpr = do { whiteSpace - ; x <- expr' - ; eof - ; return x - } - -expr' :: Parsec.Parser Expr -expr' = buildExpressionParser table subexpr "expression" - -subexpr = parens expr' - <|> myint - "subexpr" - -myint = do {n <- natural; return (I n) } - -table = [[op "+" Add AssocLeft, op "-" Sub AssocLeft]] - where - op s f assoc - = Infix (do{ reservedOp s; return f}) assoc - - -lexer :: P.TokenParser () -lexer = P.makeTokenParser - (javaStyle { P.reservedOpNames = ["+","-"] }) - -whiteSpace = P.whiteSpace lexer -lexeme = P.lexeme lexer -symbol = P.symbol lexer -natural = P.natural lexer -parens = P.parens lexer -semi = P.semi lexer -identifier= P.identifier lexer -reserved = P.reserved lexer -reservedOp= P.reservedOp lexer - diff --git a/data/Langs/Haskell.hs b/data/Langs/Haskell.hs deleted file mode 100644 index c84f87f..0000000 --- a/data/Langs/Haskell.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Haskell where - --- container -import Data.Tree (Tree(Node,rootLabel)) - --- local imports -import Language.Astview.Language - -import Language.Haskell.Exts -import Language.Haskell.Exts.Parser -import Language.Haskell.Exts.Syntax - -import Language.Astview.DataTree (data2tree) - -haskellexts = Language - "Haskell" - "Haskell" - [".hs",".lhs"] - parHaskell - (data2tree::Module->Tree String) - (Just toSrcLoc) - Nothing - -parHaskell :: String -> Either Error Module -parHaskell s = - case parseFileContents s of - ParseOk t -> Right t - ParseFailed (SrcLoc _ l c) m -> - Left $ ErrLocation (SrcLocation l c) m - - -toSrcLoc :: Tree String -> [SrcLocation] -toSrcLoc (Node "SrcLoc" cs) = - [SrcLocation (read (to 1)::Int) (read (to 2):: Int)] - where to = rootLabel . (cs !!) -toSrcLoc _ = [] diff --git a/data/Langs/Languages.hs b/data/Langs/Languages.hs deleted file mode 100644 index 7801057..0000000 --- a/data/Langs/Languages.hs +++ /dev/null @@ -1,34 +0,0 @@ -{- - -This File exports the list of known parsers for astview. -You can extend the list with your own parsers as proposed with the -CustomParsers.hs module and the concatenation of the list. - -Beware, this file will be overwritten when updating the package. - --} - -module Languages where - --- container -import Data.Tree (Tree(..)) - --- -- local imports -import Language.Astview.Language - -import Haskell -- requires haskell-src-exts -import Expr -- requires parsec - --- | Main export for dynamic interpretation by astview -languages :: [Language] -languages = [haskellexts,expr] - -{- --- -------------------------------------------------------- - --- | Define a custom parser -linesAndWords :: Parser -linesAndWords = Parser "Lines and Words" [] [".law"] buildTreeLaw - -buildTreeLaw = buildTreeGen (Just . map words . lines) data2tree --} diff --git a/data/Term2tree.hs b/data/Term2tree.hs deleted file mode 100644 index da0e660..0000000 --- a/data/Term2tree.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverlappingInstances #-} - -module Term2tree (data2tree) where - -import Generics.MultiRec.Base -import Generics.MultiRec.HFunctor -import Generics.MultiRec.Constructor -import Generics.MultiRec.TH -import qualified Data.Tree as DT -import Data.Traversable --- import ListOf - -data Tree = Node String [Tree] deriving (Show) - -data2tree :: forall phi ix. (Fam phi, Data2Tree phi (PF phi)) => phi ix -> ix -> DT.Tree String -data2tree p = tree2tree . data2tree' p - -tree2tree :: Tree -> DT.Tree String -tree2tree (Node s ts) = DT.Node s (map tree2tree ts) - -data2tree' :: forall phi ix. (Fam phi, Data2Tree phi (PF phi)) => phi ix -> ix -> Tree -data2tree' p x = head $ hData2Tree p (\p' (I0 x') -> [data2tree' p' x']) (from p x) - -class Data2Tree (phi :: * -> *) (f :: (* -> *) -> * -> *) where - hData2Tree :: phi ix -> (forall ix. phi ix -> r ix -> [Tree]) -> f r ix -> [Tree] - -instance (Constructor c, Data2Tree phi f) => Data2Tree phi (C c f) where - hData2Tree p r cx@(C f) = [Node (conName cx) (hData2Tree p r f)] - -instance (Data2Tree phi f, Data2Tree phi g) => Data2Tree phi (f :+: g) where - hData2Tree p r (L f) = hData2Tree p r f - hData2Tree p r (R f) = hData2Tree p r f - --- instance (Data2Tree phi f) => Data2Tree phi (ListOf f) where --- -- hData2Tree p r (ListOf frxs) = [Node "ListOf" (hData2Tree p r (head frxs))] --- hData2Tree p r (ListOf frxs) = [Node "ListOf" (concatMap (hData2Tree p r) frxs)] - - -instance (Show x) => Data2Tree phi (K x) where - hData2Tree _ _ (K x) = [Node (show x) []] - -instance Data2Tree phi (K String) where - hData2Tree _ _ (K s) = [Node s []] - -instance Data2Tree phi U where - hData2Tree _ _ _ = [] - -instance (Data2Tree phi f, Data2Tree phi g) => Data2Tree phi (f :*: g) where - hData2Tree p r (f :*: g) = hData2Tree p r f ++ hData2Tree p r g - -instance (El phi ix) => Data2Tree phi (I ix) where - hData2Tree p r (I x) = r proof x - -instance (Data2Tree phi f) => Data2Tree phi (f :>: ix) where - hData2Tree p r (Tag f) = hData2Tree p r f - - diff --git a/data/astview-tmpl.html b/data/astview-tmpl.html deleted file mode 100644 index 82d301f..0000000 --- a/data/astview-tmpl.html +++ /dev/null @@ -1,110 +0,0 @@ - - - - - - astview - Documentation - - - - - - -

Astview - Documentation

- -

Astview is a little desktop program to be used by people that want -to investigate syntax trees, e.g. students and lecturers in compiler -construction courses. Given a parse function p :: String -> -a, where a is a member of haskell's Data -typeclass, astview can show syntax trees in a standard tree -widget.

- -

The program evolved as a case study in a) generic programming and -b) building graphical user interfaces in haskell.

- - - -

User Guide

-

Working with source files

-

We tried to make the user interface as common as possible by -following the -GNOME human interface guidelines closely. You can open a file by -giving the filename at the CLI: -

astview .../path/to/mysource.hs
-or simply open it via the file menu. The file's extension will -determine the parser automaticall. When there are multiple parsers for -one extension, the first one will be taken. Launching astview without -any files will enable the "lines and words"-parser. Saving works as -expected: Ctrl-S saves, Save-As has to be done via the menu. When the -file was changed, the usual star appears in the title bar, next to the -filename.

- -

Cut-and-Paste functionality works as usual (Ctrl-C/P/X), allowing -to copy-paste source code to or from other programs.

- -

Astview uses the same syntax-higlighting sourceview widget as -GNOME's standard editor gedit, so any language recognized there will -be highlighted by astview. For syntax-highlighting, the language is -determined by the name of the parser.

- -

Choosing Parsers

-

As noted above, the parser is chosen automatically when opening a -file. When editing source code, one can change the parser using the -parser menu issuing an immediate reparse. Ctrl-P reparses the source -at any time.

- -

Adding Custom Parsers

-

Astview loads the available parsers at runtime using the -GHC-API wrapper hint. In this section we show how to add custom parsers.

- -

A parser is described by a 3-tuple

- -%%EX1%% - -

The name> of the parser is shown in the parser menu and is -used to determine syntax highlighting. The list of extensions -exts is used to determine the parser when opening a file. -Finally - the magic bit of the whole tool - the buildTree function -constructs a tree of Strings (Data.Tree String) from a haskell value. -Each node of this tree denotes a constructor. This tree can be -constructed using the data2tree function from the SYB approach to -generic programming (TODO: ref), which is delivered with astview. -Here is an example:

- -%%EX2%% - -

You can simply put such a parser into the file

-
~/.cabal/share/astview-0.2/data/Parsers.hs
-

which exports a list of all parsers:

- -%%EX3%% - -

Here, the predefined list of parsers stdParserData is -extended with the new haskell-parser.

- -

If your Parser needs additional modules, these modules have either -be exposed to GHC's package-management, or have to exist as -source-file under the data-Directory of astview. Remember that these -modules are linked in at runtime!

- -

To test your parser consider the following ghci-session:

- -%%EX4%% - -

If drawString works for your sourcecode, astview will -too, since ghci uses the parsers in interpreted mode just as astview -does.

- -describe background, especially unsafeCast, describe hin - -

Developer Notes

-

Notes for Developers, Short Module descriptions, references to -haddock (include haddock !?), code conventions, history, GTK -things

diff --git a/data/astview.glade b/data/astview.glade deleted file mode 100644 index 3cc98c6..0000000 --- a/data/astview.glade +++ /dev/null @@ -1,559 +0,0 @@ - - - - - - True - astview - 600 - 400 - - - True - 4 - vertical - 4 - - - True - - - True - _File - True - - - True - - - gtk-new - True - True - True - - - - - Parse - True - False - - - True - gtk-refresh - - - - - - - gtk-open - True - True - True - - - - - gtk-save - True - True - True - - - - - gtk-save-as - True - True - True - - - - - Add relation (srcView) - True - False - - - - - Add relation - True - False - - - - - True - - - - - gtk-quit - True - True - True - - - - - - - - - True - _Edit - True - - - True - - - gtk-cut - True - True - True - - - - - gtk-copy - True - True - True - - - - - gtk-paste - True - True - True - - - - - gtk-delete - True - True - True - - - - - Print Path - True - False - - - True - gtk-file - - - - - - - Jump to SrcLoc - True - False - - - True - gtk-file - - - - - - - - - - - True - _Left - True - - - True - - - gtk-new - True - True - True - - - - - Parse - True - False - - - True - gtk-refresh - - - - - - - gtk-open - True - True - True - - - - - gtk-save - True - True - True - - - - - gtk-save-as - True - True - True - - - - - Print path - True - False - - - True - gtk-missing-image - - - - - - - Jump to src loc - True - False - - - True - gtk-refresh - - - - - - - - - - - True - _Right - True - - - True - - - gtk-new - True - True - True - - - - - Parse - True - False - - - True - gtk-refresh - - - - - - - gtk-open - True - True - True - - - - - gtk-save - True - True - True - - - - - gtk-save-as - True - True - True - - - - - Print path - True - False - - - True - gtk-refresh - - - - - - - Jump to src loc - True - False - - - True - gtk-refresh - - - - - - - - - - - True - _Help - True - - - True - - - gtk-help - True - True - True - - - - - gtk-about - True - True - True - - - - - - - - - False - 0 - - - - - True - True - - - True - True - vertical - - - True - True - automatic - automatic - - - - - - False - True - - - - - 400 - 500 - True - True - 4 - automatic - automatic - in - - - True - True - True - - - - - True - True - - - - - 0 - - - - - True - True - vertical - 1 - - - True - True - automatic - automatic - - - - - - False - True - - - - - 400 - 500 - True - True - 4 - automatic - automatic - in - - - True - True - True - - - - - True - True - - - - - 1 - - - - - True - True - automatic - automatic - - - True - True - - - - - 2 - - - - - 1 - - - - - - - 5 - True - dialog-information - dialog - astview - 0.1 - Copyright © 2009 Sebastian Menge and Pascal Hof - a graphical syntax tree viewer - http://ls10-www.cs.tu-dortmund.de - Lehrstuhl fuer Software-Technologie - astview: View abstract syntax trees for your custom languages and -parsers in a graphical (GTK+) application. - -Copyright (c) 2009 Sebastian Menge and Pascal Hof - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -``Software''), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHOR(s) BE LIABLE FOR ANY CLAIM, DAMAGES OR -OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, -ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR -OTHER DEALINGS IN THE SOFTWARE. - Sebastian Menge <sebastian.menge@uni-dortmund.de> -Pascal Hof <pascal.hof@uni-dortmund.de> - Haddock: Sebastian Menge <sebastian.menge@uni-dortmund.de> - - True - - - True - vertical - 2 - - - True - True - end - - - False - False - end - 0 - - - - - - diff --git a/data/astview.html b/data/astview.html deleted file mode 100644 index 2aa1dc1..0000000 --- a/data/astview.html +++ /dev/null @@ -1,161 +0,0 @@ - - - - - - astview - Documentation - - - - - - -

Astview - Documentation

- -

Astview is a little desktop program to be used by people that want -to investigate syntax trees, e.g. students and lecturers in compiler -construction courses. Given a parse function p :: String -> -a, where a is a member of haskell's Data -typeclass, astview can show syntax trees in a standard tree -widget.

- -

The program evolved as a case study in a) generic programming and -b) building graphical user interfaces in haskell.

- - - -

User Guide

-

Working with source files

-

We tried to make the user interface as common as possible by -following the -GNOME human interface guidelines closely. You can open a file by -giving the filename at the CLI: -

astview .../path/to/mysource.hs
-or simply open it via the file menu. The file's extension will -determine the parser automaticall. When there are multiple parsers for -one extension, the first one will be taken. Launching astview without -any files will enable the "lines and words"-parser. Saving works as -expected: Ctrl-S saves, Save-As has to be done via the menu. When the -file was changed, the usual star appears in the title bar, next to the -filename.

- -

Cut-and-Paste functionality works as usual (Ctrl-C/P/X), allowing -to copy-paste source code to or from other programs.

- -

Astview uses the same syntax-higlighting sourceview widget as -GNOME's standard editor gedit, so any language recognized there will -be highlighted by astview. For syntax-highlighting, the language is -determined by the name of the parser.

- -

Choosing Parsers

-

As noted above, the parser is chosen automatically when opening a -file. When editing source code, one can change the parser using the -parser menu issuing an immediate reparse. Ctrl-P reparses the source -at any time.

- -

Adding Custom Parsers

-

Astview loads the available parsers at runtime using the -GHC-API wrapper hint. In this section we show how to add custom parsers.

- -

A parser is described by a 3-tuple

- - -
data Parser 
-  = Parser { name :: String
-           , exts :: [String]
-           , tree :: String -> Tree String}
-
- - -

The name> of the parser is shown in the parser menu and is -used to determine syntax highlighting. The list of extensions -exts is used to determine the parser when opening a file. -Finally - the magic bit of the whole tool - the buildTree function -constructs a tree of Strings (Data.Tree String) from a haskell value. -Each node of this tree denotes a constructor. This tree can be -constructed using the data2tree function from the SYB approach to -generic programming (TODO: ref), which is delivered with astview. -Here is an example:

- - -
haskell :: Parser
-haskell =  Parser "Haskell" [".hs"] buildTreeHaskell
-
-buildTreeHaskell :: String -> Tree String
-buildTreeHaskell s = case parseHaskell s of
-     Right ast -> flat $ data2tree (ast::HsModule)
-     Left ParseError -> Node "ParseError" []
-
-parseHaskell :: (Data a) => String -> Either ParseError a
-parseHaskell s = case parseModule s of
-  ParseOk p -> unsafeCoerce $ Right p
-  _         -> Left ParseError
-
- - -

You can simply put such a parser into the file

-
~/.cabal/share/astview-0.2/data/Parsers.hs
-

which exports a list of all parsers:

- - -
parsers :: [Parser]
-parsers = haskell:stdParserData
-
- - -

Here, the predefined list of parsers stdParserData is -extended with the new haskell-parser.

- -

If your Parser needs additional modules, these modules have either -be exposed to GHC's package-management, or have to exist as -source-file under the data-Directory of astview. Remember that these -modules are linked in at runtime!

- -

To test your parser consider the following ghci-session:

- - -
user@host:path$ cd ~/.cabal/share/astview-0.2/data
-user@host:~/.cabal/share/astview-0.2/data$ ghci Parsers.hs
-
--- ghci package-messages stripped
-
-*Parsers> :info Parser
-data Parser
-  = Parser {name :: !String,
-            exts :: [String],
-            tree :: String -> Tree String}
-
--- show all registered parsers
-*Parsers> map name parsers                                            
-["Haskell","CSV","Expr","Java","IsoPascal","C","Glade","List"]
-
--- get haskell parser
-*Parsers> let haskell = head parsers                                 
-
--- build a sample tree of strings
-*Parsers> let sample = tree haskell "main = putStrLn \"Hello World\""
-
--- draw the tree
-*Parsers> putStrLn $ Data.Tree.drawTree sample
-
--- lengthy output follows
-
- - -

If drawString works for your sourcecode, astview will -too, since ghci uses the parsers in interpreted mode just as astview -does.

- -describe background, especially unsafeCast, describe hin - -

Developer Notes

-

Notes for Developers, Short Module descriptions, references to -haddock (include haddock !?), code conventions, history, GTK -things

diff --git a/data/astview.xml b/data/astview.xml new file mode 100644 index 0000000..5dff37f --- /dev/null +++ b/data/astview.xml @@ -0,0 +1,71 @@ + + + + + + True + False + astview + 600 + 400 + + + True + False + vertical + 4 + + + + + + True + False + 2 + True + + + True + True + + + + + + True + True + 0 + + + + + True + True + + + True + True + True + + + + + + + + False + True + 1 + + + + + True + True + 1 + + + + + + diff --git a/data/menu.xml b/data/menu.xml new file mode 100644 index 0000000..f1f6d9b --- /dev/null +++ b/data/menu.xml @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/data/style.css b/data/style.css deleted file mode 100644 index 49b1083..0000000 --- a/data/style.css +++ /dev/null @@ -1,151 +0,0 @@ -body { - font-family:sans-serif; - font-size:12pt; - color:#000000; - margin-top:20px; - margin-left:10%; - margin-right:10%; - padding:0px 20px 0px 20px; -} - -p { - text-align: justify; -} - -h1 { - font-size:20pt; - font-weight:bold; - padding:0px 0px 0px 0px; - margin:0px 5px 5px 0px; - color:#0E3292; -} - -h2 { - font-size:16pt; - font-weight:bold; - margin:15px 5px 3px 0px; - color:#0E3292; -} - -h3 { - font-size:14pt; - margin:15px 5px 3px 0px; - color:#0E3292; -} - -hr { - border:1px; - border-style: solid; -} - -input { - border-width:1px; - border-style:solid; - color:#000000; - padding-left:3px; - padding-right:3px; - background-color:#ffffff; - border-color:#9a9a9a; - margin:1px; -} - -form { - padding:8px 0px 5px 0px; -} - -/********* Alles was wir nicht benutzen erstmal auskommentieren. - - -table{ - font-family:sans-serif; - font-size:11pt; - width:700px; - border:0px; - margin:15px 0px 15px 0px; - border-collapse:collapse; -} - - - -div.title { - position:relative; - top:3px; - left:115px; - width:600px; - height:50px; -} - - - -div.important { - position:absolute; - left:550px; - top:105px; - width:220px; - border-style:solid; - padding:5px; - border-color:#bbbbbb; - border-width:1px; - background-color:#f0f1f2; -} - - -div.alert { - color:#FE0202; -} - -div.disclaimer { - font-size:9pt; - padding-top:2px; - padding-right:10px; - color:#666666; - text-align:right; - border-style:solid; - border-color:#bbbbbb; - border-width:1px 0px 0px 0px; -} - - - - -a { - color:#000000; - border-width:0px 0px 1px 0px; - border-color:#777777; -} - -a.image { - border-width:0px 0px 0px 0px; -} - -a:hover { - color:#20acee; -} - - -ul,ol { - margin: 2px 0px 0px 0px; -} - - -table.table{ - margin:5px 0px 5px 0px; -} - -table[class=table] td{ - border-style:solid; - border-width:1px; - margin:0px 0px 0px 0px; - padding:1px 1px 1px 1px; - border-collapse:collapse; -} -img { - border-width:0px; -} -*/ - -.hs-keyglyph, .hs-layout {color: red;} -.hs-keyword {color: blue;} -.hs-comment, .hs-comment a {color: green;} -.hs-str, .hs-chr {color: teal;} -.hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {} diff --git a/preview.gif b/preview.gif new file mode 100644 index 0000000..0b155ba Binary files /dev/null and b/preview.gif differ diff --git a/src/Language/Astview/DataTree.hs b/src/Language/Astview/DataTree.hs deleted file mode 100644 index e9bc22c..0000000 --- a/src/Language/Astview/DataTree.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-| This module contains datatype-generic functions to gain a 'Tree' 'String' -out of an arbitrary term. --} -module Language.Astview.DataTree where - --- syb -import Data.Generics (Data - ,extQ - ,gmapQ - ,showConstr - ,toConstr) - --- containers -import Data.Tree (Tree(Node,rootLabel)) - --- |Trealise Data to Tree (from SYB 2, sec. 3.4 ) -data2tree :: Data a => a -> Tree String -data2tree = gdefault `extQ` atString - where - atString x = Node x [] - gdefault x = Node (showConstr $ toConstr x) (gmapQ data2tree x) - - --- |try to flatten degenerated trees (lists of cons). NOT WORKING YET! -flat :: Tree String -> Tree String -flat = id -- do nothing, see commentary below - - - - - -{- -- - - -flat (Node a xs) = Node a xs --(flat <$> (children False =<< xs)) - --- use a boolean marker to notice whether we are inside a list (True) --- or should start a new list, then recurse -children :: Bool -> Tree String -> [Tree String] -children False (Node "(:)" [left,right]) = [Node ("ListOf"++(rootLabel left)) (left:(children True right)) ] -children True (Node "(:)" [left,Node "[]" []]) = [left] -children True (Node "(:)" [left,right]) = left:(children True right) -children _ (Node a xs) - | null xs = [Node a []] - |otherwise = [Node a xs] -children x y = error ("No pattern match for children " ++ show x ++ " " ++ (drawTree y)) --} diff --git a/src/Language/Astview/GUI.hs b/src/Language/Astview/GUI.hs deleted file mode 100644 index c33d834..0000000 --- a/src/Language/Astview/GUI.hs +++ /dev/null @@ -1,139 +0,0 @@ -{- contains the main GUI functions - - - -} -module Language.Astview.GUI where - --- guiactions -import Language.Astview.GUIData -import Language.Astview.GUIActions - --- base -import Control.Monad.Trans (liftIO) -import Data.IORef --- filepath -import System.FilePath (()) - --- gtk -import Graphics.UI.Gtk hiding (Language) - --- glade -import Graphics.UI.Gtk.Glade - --- gtksourceview -import Graphics.UI.Gtk.SourceView - --- astview-utils -import Language.Astview.Language - --- generated on-the-fly by cabal -import Paths_astview (getDataFileName) - --- | initiates aststate -buildAststate :: Options -> [Language] -> IO (IORef AstState) -buildAststate opt langs = do - -- GTK init - initGUI - - -- load GladeXML - Just xml <- xmlNew =<< getDataFileName ("data" "astview.glade") - - -- get or create widgets - win <- xmlGetWidget xml castToWindow "mainWindow" - treeviewL <- xmlGetWidget xml castToTreeView "treeviewLeft" - treeviewR <- xmlGetWidget xml castToTreeView "treeviewRight" - - tbL <- buildSourceView opt - =<< xmlGetWidget xml castToScrolledWindow "swSourceLeft" - - tbR <- buildSourceView opt - =<< xmlGetWidget xml castToScrolledWindow "swSourceRight" - - tvConfig <- xmlGetWidget xml castToTextView "tvConfig" - - dialogAbout <-xmlGetWidget xml castToAboutDialog "dlgAbout" - - -- build compound datatype - let g = GUI win - (treeviewL,treeviewR) - (tbL,tbR) - tvConfig - dialogAbout - st = State - { cFile = (unsavedDoc,unsavedDoc) - , textchanged = (False,False) - , cursor = (CursorP 0 0,CursorP 0 0) - , languages = langs - , config = Configuration [] - , configFile = unsavedDoc - } - - r <- newIORef $ AstState st g opt - - hooks r - - -- get all menuitems from xml and register guiactions to them - mapM_ (registerMenuAction xml r) menuActions - - return r - --- ------------------------------------------------------------------- --- ** some helper functions --- ------------------------------------------------------------------- - --- |builds combobox label for a language -buildLabel :: Language -> String -buildLabel l = - name l - ++ " [" - ++ concatMap (" "++) (exts l) - ++ "]" - --- | setup the GtkSourceView and add it to the ScrollPane. return the --- underlying textbuffer -buildSourceView :: Options -> ScrolledWindow -> IO SourceBuffer -buildSourceView opt sw = do - sourceBuffer <- sourceBufferNew Nothing - sourceBufferSetHighlightSyntax sourceBuffer True - sourceView <- sourceViewNewWithBuffer sourceBuffer - sourceViewSetShowLineNumbers sourceView True - sourceViewSetHighlightCurrentLine sourceView True - srcfont <- fontDescriptionFromString $ - font opt ++" "++show (fsize opt) - widgetModifyFont sourceView (Just srcfont) - containerAdd sw sourceView - return sourceBuffer - --- | registers one GUIAction with a MenuItem -registerMenuAction - :: GladeXML -> IORef AstState - -> (String,AstAction ()) -> IO (ConnectId MenuItem) -registerMenuAction xml ref (gtkId,action) = do - item <- xmlGetWidget xml castToMenuItem gtkId - onActivateLeaf item $ action ref - --- | adds actions to some widgets -hooks :: AstAction (ConnectId Window) -hooks ref = do - g <- getGui ref - -- textbuffer - onBufferChanged (fst $ sb g) $ do - actionBufferChanged L ref - cp <- getCursorPosition L ref - setCursor L cp ref - onBufferChanged (snd $ sb g) $ do - actionBufferChanged R ref - cp <- getCursorPosition R ref - setCursor R cp ref - - -- ctrl+p to reparse - window g `on` keyPressEvent $ tryEvent $ do - [Control] <- eventModifier - "p" <- eventKeyName - liftIO $ actionReparseAll ref - - dlgAbout g `onResponse` (const $ widgetHide $ dlgAbout g) - - window g `on` deleteEvent $ tryEvent $ liftIO $ actionQuit ref - - -- window - onDestroy (window g) mainQuit diff --git a/src/Language/Astview/GUIActions.hs b/src/Language/Astview/GUIActions.hs deleted file mode 100644 index efbc0a5..0000000 --- a/src/Language/Astview/GUIActions.hs +++ /dev/null @@ -1,582 +0,0 @@ -{- contains the GUIActions connected to menuItems - - - -} - -module Language.Astview.GUIActions where - --- gui data types -import Language.Astview.GUIData - --- base -import Prelude hiding (writeFile) -import Data.Maybe(fromJust,isJust) -import Data.List (find) -import Control.Monad (when) -import Data.Char (toLower) --- io -import System.IO (withFile,IOMode(..),hPutStr,hClose) - --- filepath -import System.FilePath ((),takeExtension,takeFileName) - --- bytestring -import qualified Data.ByteString.Char8 as BS (hGetContents,unpack) - --- containers -import Data.Tree ( Tree(Node) ) - --- gtk -import Graphics.UI.Gtk hiding (Language,get,response) - --- gtksourceview -import Graphics.UI.Gtk.SourceView - --- commands -import System.Cmd (rawSystem) - --- astview-utils -import Language.Astview.Language hiding (line,row) - --- generated on-the-fly by cabal -import Paths_astview (getDataFileName,getDataDir) - --- |suffix of window title -suffix :: String -suffix = " - astview" - --- |unsaved document -unsavedDoc :: String -unsavedDoc = "Unsaved document" - --- | a list of pairs of gtk-ids and GUIActions -menuActions :: [(String,AstAction ())] -menuActions = - [("mNew",actionEmptyGUI) - ,("mParseAll",actionReparseAll) - ,("mOpenConfig",actionOpenConfig) - ,("mSaveConfig", actionSaveConfig) - ,("mAddRelation",actionAddRelation) - ,("mAddRelationSrcView",actionAddRelationSrc) - ,("mSaveAsConfig",actionSaveAsConfig) - ,("mOpenLeft",actionDlgOpenRun L) - ,("mParseLeft",actionReparse L) - ,("mParseRight",actionReparse R) - ,("mOpenRight",actionDlgOpenRun R) - ,("mParseAll",actionReparseAll) - ,("mSaveLeft",actionSave L) - ,("mSaveRight",actionSave R) - ,("mPathLeft",actionShowPath L) - ,("mPathRight",actionShowPath R) - --,("mCut",actionCutSource) - --,("mCopy",actionCopySource) - --,("mPaste",actionPasteSource) - --,("mDelete",actionDeleteSource) - ,("mSrcLocLeft",actionJumpToSrcLoc L) - ,("mSrcLocRight",actionJumpToSrcLoc R) - ,("mAbout",actionAbout) - ,("mShowHelp",actionHelp) - ,("mQuit",actionQuit) - ] - - - - --- ------------------------------------------------------------------- --- * filemenu menu actions --- ------------------------------------------------------------------- - -clearTreeView :: TreeView -> IO () -clearTreeView t = do - c <- treeViewGetColumn t 0 - case c of - Just col-> treeViewRemoveColumn t col - Nothing -> return undefined - return () - --- | resets the GUI, -actionEmptyGUI :: AstAction () -actionEmptyGUI ref = do - g <- getGui ref - mapM_ clearTreeView =<< getTreeViews ref - mapM_ (\s -> textBufferSetText s []) =<< getSourceBuffers ref - windowSetTitle (window g) (unsavedDoc++suffix) - -actionOpenConfig :: AstAction () -actionOpenConfig ref = do - dia <- fileChooserDialogNew - (Just "astview") - Nothing - FileChooserActionOpen - [] - dialogAddButton dia stockCancel ResponseCancel - dialogAddButton dia stockOpen ResponseOk - - widgetShowAll dia - response <- dialogRun dia - case response of - ResponseCancel -> return () - ResponseOk -> - whenJustM - (fileChooserGetFilename dia) $ - \file -> do - contents <- readFile file - setConfiguration (readConfig contents) ref - setConfigFile file ref - buffer <- textViewGetBuffer =<< fmap tvConf (getGui ref) - textBufferSetText buffer contents - _ -> return () - widgetHide dia - --- | updates the sourceview with a given file, chooses a language by --- extension and parses the file -actionLoadHeadless :: Area -> FilePath -> AstAction () -actionLoadHeadless area file ref = do - setcFile area file ref - s <- getAstState ref - - windowSetTitle - (window $ gui s) - (takeFileName file ++ suffix) - contents <- withFile - file ReadMode (fmap BS.unpack . BS.hGetContents) - buffer <- getSourceBuffer area ref - textBufferSetText buffer contents - deleteStar area ref - whenJustM - (getLanguage area ref) $ - \l -> actionParse area l ref >> return () - --- |tries to find a language based on the extension of --- current file name -getLanguage :: Area -> AstAction (Maybe Language) -getLanguage area ref = do - file <- getFile area ref - langs <- getLangs ref - return $ find (elem (takeExtension file) . exts) langs - --- | parses the contents of the sourceview with the selected language -actionParse :: Area -> Language -> AstAction (Tree String) -actionParse a l@(Language _ _ _ p to _ _) ref = do - buffer <- getSourceBuffer a ref - view <- getTreeView a ref - sourceBufferSetHighlightSyntax buffer True - setupSyntaxHighlighting buffer l - plain <- getText buffer - clearTreeView view - let eitherTree = fmap to (p plain) - - -- error handling - case eitherTree of - Left (ErrLocation (SrcLocation line _) _) -> do - iter <- textBufferGetStartIter buffer - textIterSetLine iter (line-1) - textBufferPlaceCursor buffer iter - _ -> return () - - let t = case eitherTree of - Right ast -> ast - Left Err -> Node "Parse error" [] - Left (ErrMessage m) -> Node m [] - Left (ErrLocation (SrcLocation line row) _) -> - Node ("Parse error at:"++show line ++":"++show row) [] - - model <- treeStoreNew [t] - treeViewSetModel view model - col <- treeViewColumnNew - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes - col - renderer - model - (\row -> [ cellText := row ] ) - treeViewAppendColumn view col - return t - -setupSyntaxHighlighting :: SourceBuffer -> Language -> IO () -setupSyntaxHighlighting buffer language = do - langManager <- sourceLanguageManagerGetDefault - maybeLang <- sourceLanguageManagerGetLanguage - langManager - (map toLower $ syntax language) - case maybeLang of - Just lang -> do - sourceBufferSetHighlightSyntax buffer True - sourceBufferSetLanguage buffer (Just lang) - Nothing -> sourceBufferSetHighlightSyntax buffer False - --- |saves a file -actionSave :: Area -> AstAction () -actionSave a ref = do - url <- getFile a ref - text <- getText =<< getSourceBuffer a ref - actionSaveWorker a text url ref - --- |saves current file if a file is active or calls "save as"-dialog -actionSaveWorker :: Area -> String -> FilePath -> AstAction () -actionSaveWorker a plain file ref = - case file of - "Unsaved document" -> actionDlgSaveRun a ref - _ -> do - deleteStar a ref - writeFile file plain - --- |saves a configuration file -actionSaveConfig :: AstAction () -actionSaveConfig ref = do - cf <- getConfigFile ref - case cf of - "Unsaved document" -> actionSaveAsConfig ref - _ -> writeFile cf =<< getText =<< - textViewGetBuffer =<< getTvConf ref - -actionSaveAsConfig :: AstAction () -actionSaveAsConfig ref = do - dia <- fileChooserDialogNew - (Just "astview") - Nothing - FileChooserActionSave - [] - dialogAddButton dia stockCancel ResponseCancel - dialogAddButton dia stockOpen ResponseOk - - widgetShowAll dia - response <- dialogRun dia - case response of - ResponseCancel -> return () - ResponseOk -> do - maybeFile <- fileChooserGetFilename dia - case maybeFile of - Nothing-> return () - Just file -> do - writeFile file =<< getText =<< - textViewGetBuffer =<< getTvConf ref - _ -> return () - widgetHide dia - - --- |removes @*@ from window title if existing and updates state -deleteStar :: Area -> AstAction () -deleteStar a ref = do - w <- getWindow ref - t <- windowGetTitle w - setChanged a False ref - when (head t == '*') - (windowSetTitle w (tail t)) - --- ------------------------------------------------------------------- --- ** editmenu menu actions --- ------------------------------------------------------------------- - --- |moves selected source to clipboard (cut) -actionCutSource :: AstAction () -actionCutSource ref = do - sbs <- getSourceBuffers ref - mapM_ actionCopySource sbs - mapM_ actionDeleteSource sbs - return () - --- |copies selected source to clipboard -actionCopySource :: SourceBuffer -> IO () -actionCopySource tb = do - (start,end) <- textBufferGetSelectionBounds tb - clipBoard <- clipboardGet selectionClipboard - clipboardSetText - clipBoard - =<< textBufferGetText tb start end True - --- |pastes text from clipboard at current cursor position -actionPasteSource :: SourceBuffer -> IO () -actionPasteSource tb = do - clipBoard <- clipboardGet selectionClipboard - clipboardRequestText clipBoard (insertAt tb) where - insertAt :: SourceBuffer -> Maybe String -> IO () - insertAt buffer m = whenJust m (textBufferInsertAtCursor buffer) - --- |deletes selected source -actionDeleteSource :: SourceBuffer -> IO () -actionDeleteSource tb = - textBufferDeleteSelection tb False False >> return () - -actionAddRelationSrc :: AstAction () -actionAddRelationSrc ref = do - p1 <- fmap trans $ actionGetSrcLoc L ref - p2 <- fmap trans $ actionGetSrcLoc R ref - if null p1 || null p2 - then putStrLn "at least one empty path occured" - else do - fl <- getFile L ref - fr <- getFile R ref - let r = Relation (Elem p1 fl) (Elem p2 fr) - addRelation r ref - - tb <- textViewGetBuffer =<< getTvConf ref - t <- getText tb - textBufferSetText tb (t++"\n"++show r) - return () - --- |returns the current cursor position in a source view. --- return type: (line,row) -getCursorPosition :: Area -> AstAction CursorP -getCursorPosition a ref = do - (iter,_) <- textBufferGetSelectionBounds =<< getSourceBuffer a ref - l <- textIterGetLine iter - r <- textIterGetLineOffset iter - return $ CursorP (l+1) (r+1) - --- | -actionJumpToSrcLoc :: Area -> AstAction () -actionJumpToSrcLoc a ref = do - treePath <- actionGetSrcLoc a ref - when (not $ null treePath) (selectPath treePath a ref) - --- |returns the position in tree which is associated with the --- current selected source location. -actionGetSrcLoc :: Area -> AstAction TreePath -actionGetSrcLoc a ref = do - (CursorP l r) <- getCursorPosition a ref - - -- reparse and set cursor in treeview - maybeLang <- getLanguage a ref - case maybeLang of - Nothing -> return [] - Just lang -> do - t <- actionParse a lang ref - let sl = sourceLocations lang t - case find (\(SrcLocation x y,_) ->(l==x &&r==y)) sl of - Just (_,p) -> return p - Nothing -> - -- jump to src loc of given line if no exact matching found - case find (\(SrcLocation x _,_) ->l==x) sl of - Just (_,p) -> return p - Nothing -> return [] - --- |select tree path in area. -selectPath :: TreePath -> Area -> AstAction () -selectPath p a ref = do - view <- getTreeView a ref - treeViewExpandToPath view p - treeViewSetCursor view p Nothing - --- |returns all source locations and paths to source --- locations in current tree -sourceLocations :: Language -> Tree String -> [(SrcLocation,TreePath)] -sourceLocations lang = getSourceLocations lang . calcPaths [0] - where - calcPaths :: [Int] -> Tree String -> Tree (String,TreePath) - calcPaths curPath (Node l cs) = - let paths = zipWith (\p e->p++[e]) (repeat curPath) [0,1..] in - Node (l,curPath) (zipWith (\subtree p -> calcPaths p subtree) cs paths) - --- |a helper function for 'sourceLocations' -getSourceLocations :: Language - -> Tree (String,TreePath) - -> [(SrcLocation,TreePath)] -getSourceLocations l t@(Node (_,p) cs) = - case srcLoc l of - Just f -> - let xs = f $ fmap fst t in - case xs of - [] -> concatMap (getSourceLocations l) cs - (x:_) -> [(x,p)] - Nothing -> [] - - --- ------------------------------------------------------------------- --- ** helpmenu menu actions --- ------------------------------------------------------------------- - --- |opens help in firefox -actionHelp :: AstAction () -actionHelp _ = do - helpfile <- getDataFileName ("data" "astview.html") - dir <- getDataDir - rawSystem "firefox" [dir helpfile] - return () - --- | launches info dialog -actionAbout :: AstAction () -actionAbout ref = do - dlg <- fmap dlgAbout (getGui ref) - aboutDialogSetUrlHook (\_ -> return ()) - licensefile <- getDataFileName ("data" "LICENSE.unwrapped") - contents <- withFile licensefile ReadMode (fmap BS.unpack . BS.hGetContents) - aboutDialogSetWrapLicense dlg True - aboutDialogSetLicense dlg (Just contents) - widgetShow dlg - --- ------------------------------------------------------------------- --- ** other actions --- ------------------------------------------------------------------- - --- | adds '*' to window title if file changed and sets state -actionBufferChanged :: Area -> AstAction () -actionBufferChanged area ref = do - w <- fmap window (getGui ref) - setChanged area True ref - t <- windowGetTitle w - when (head t /= '*') (windowSetTitle w ('*':t)) - --- | destroys window widget -actionQuit :: AstAction () -actionQuit ref = do - changedL <- getChanged L ref - changedR <- getChanged R ref - when changedL $ actionQuitWorker L ref - when changedR $ actionQuitWorker R ref - w <- fmap window (getGui ref) - widgetDestroy w - -actionQuitWorker :: Area -> AstAction () -actionQuitWorker a ref = do - dia <- dialogNew - dialogAddButton dia stockYes ResponseYes - dialogAddButton dia stockNo ResponseNo - dialogAddButton dia stockCancel ResponseCancel - contain <- dialogGetUpper dia - - windowSetTitle dia "astview" - containerSetBorderWidth dia 2 - file <- getFile a ref - lbl <- labelNew - (Just $ "Save changes to document \""++ - takeFileName file ++ - "\" before closing?") - boxPackStartDefaults contain lbl - - widgetShowAll dia - response <- dialogRun dia - case response of - ResponseYes -> actionSave a ref - _ -> return () - widgetHide dia - - --- | launches open dialog -actionDlgOpenRun :: Area -> AstAction () -actionDlgOpenRun a ref = do - dia <- fileChooserDialogNew - (Just "astview") - Nothing - FileChooserActionOpen - [] - dialogAddButton dia stockCancel ResponseCancel - dialogAddButton dia stockOpen ResponseOk - - widgetShowAll dia - response <- dialogRun dia - case response of - ResponseCancel -> return () - ResponseOk -> - whenJustM - (fileChooserGetFilename dia) $ - \file -> actionLoadHeadless a file ref - _ -> return () - widgetHide dia - --- | launches save dialog -actionDlgSaveRun :: Area -> AstAction () -actionDlgSaveRun a ref = do - dia <- fileChooserDialogNew - (Just "astview") - Nothing - FileChooserActionSave - [] - dialogAddButton dia stockCancel ResponseCancel - dialogAddButton dia stockOpen ResponseOk - - widgetShowAll dia - response <- dialogRun dia - case response of - ResponseCancel -> return () - ResponseOk -> do - maybeFile <- fileChooserGetFilename dia - case maybeFile of - Nothing-> return () - Just file -> do - g <- getGui ref - setChanged a False ref - writeFile file =<< getText =<< getSourceBuffer a ref - windowSetTitle - (window g) - (takeFileName file++suffix) - _ -> return () - widgetHide dia - -actionReparseAll :: AstAction () -actionReparseAll ref = actionReparse L ref >> actionReparse R ref - - --- |applies current parser to current sourcebuffer -actionReparse :: Area -> AstAction () -actionReparse a ref = do - whenJustM (getLanguage a ref) $ - \l -> actionParse a l ref >> return () - --- |prints the current selected path to console -actionShowPath :: Area -> AstAction () -actionShowPath a ref = do - p <- actionGetPath a ref - if null p - then return () - else print (tail p) - - - -actionAddRelation :: AstAction () -actionAddRelation ref = do - pl <- actionGetPath L ref - pr <- actionGetPath R ref - fl <- getFile L ref - fr <- getFile R ref - let r = Relation (Elem pl fl) (Elem pr fr) - addRelation r ref - - tb <- textViewGetBuffer =<< getTvConf ref - t <- getText tb - textBufferSetText tb (t++"\n"++show r) - return () - -actionGetPath :: Area -> AstAction [Direction] -actionGetPath a ref = do - s <- treeSelectionGetSelectedRows - =<< treeViewGetSelection =<< getTreeView a ref - if null s - then return [] - else - let p = head s in - if null p - then return [] - else return $ trans (tail p) where - --- |transforms gtk2hs path representation to direction -trans :: [Int] -> [Direction] -trans (x:xs) = D : replicate x Ri ++ trans xs -trans [] = [] - --- ------------------------------------------------------------------- --- ** Helpers --- ------------------------------------------------------------------- - --- |similar to @when@ -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenJust m action = - when (isJust m) ((action.fromJust) m) - --- |similar to @whenJust@, but value is inside a monad -whenJustM :: Monad m => m(Maybe a) -> (a -> m ()) -> m () -whenJustM val action = do - m <- val - when (isJust m) ((action.fromJust) m) - --- | helper for various text-processing actions -getText :: TextBufferClass c => c -> IO String -getText tb = do - start <- textBufferGetStartIter tb - end <- textBufferGetEndIter tb - textBufferGetText tb start end True - --- |safe function to write files -writeFile :: FilePath -> String -> IO () -writeFile f str = withFile f WriteMode (\h -> hPutStr h str >> hClose h) - diff --git a/src/Language/Astview/GUIData.hs b/src/Language/Astview/GUIData.hs deleted file mode 100644 index 256ca56..0000000 --- a/src/Language/Astview/GUIData.hs +++ /dev/null @@ -1,219 +0,0 @@ -{- contains the GUI data types - - - -} -module Language.Astview.GUIData where - -import Data.IORef - --- gtksourceview -import Graphics.UI.Gtk hiding (Language,get) -import Graphics.UI.Gtk.SourceView (SourceBuffer) - -import Language.Astview.Language (Language) - -type AstAction a = IORef AstState -> IO a - --- |union of intern program state and gui -data AstState = AstState - { state :: State -- ^ intern program state - , gui :: GUI -- ^ gtk data types - , options :: Options -- ^ global program options - } - --- |data type for global options -data Options = Options - { font :: String -- ^ font name of textbuffer - , fsize :: Int -- ^ font size of textbuffer - } - --- |data type for the intern program state -data State = State - { cFile :: (String,String) -- ^ current file - , textchanged :: (Bool,Bool) -- ^ true if file changed - , cursor :: (CursorP,CursorP) -- ^ last active cursor position - , languages :: [Language] -- ^ known languages - , config :: Configuration -- ^ current configuration - , configFile :: FilePath -- ^ path of current configuraton file - } - --- |main gui data type, contains gtk components -data GUI = GUI - { window :: Window -- ^ main window - , tv :: (TreeView,TreeView) -- ^ treeview - , sb :: (SourceBuffer,SourceBuffer) -- ^ sourceview - , tvConf :: TextView -- ^ text view showing the config file - , dlgAbout :: AboutDialog -- ^ about dialog - } - -data CursorP = CursorP - { cursorLine :: Int - , cursorRow :: Int - } - --- |indicator data type for both areas -data Area = L -- ^ left area - | R -- ^ right area - --- |a configuration contains of relatons between nodes -data Configuration = Configuration - { relations :: [Relation] - } - --- |data type to specify binary relations between nodes -data Relation = Relation - { element1 :: Elem -- ^ first relation element - , element2 :: Elem -- ^ second relation element - } - --- |an element of the relation -data Elem = Elem - { path :: [Direction] -- ^ path in ast to a node - , filepath :: FilePath -- ^ file containing the ast - } - --- |data type to specify paths in trees, a path has the type --- > [Direction] -data Direction - = D -- ^ go down one level to the leftmost child - | Ri -- ^ stay at the same level and go to the right - --- * parser of data type configuration - -readConfig :: String -> Configuration -readConfig = Configuration . map readRelation . lines - -readRelation :: String -> Relation -readRelation s = - let e1 = takeWhile (/=' ') s in - let e2 = drop (1+length e1) s in - Relation (readElem e1) (readElem e2) - -readElem :: String -> Elem -readElem s = - let (p,fp) = span (/='@') s in - Elem (map readDirection p) (tail fp) - -readDirection :: Char -> Direction -readDirection 'r' = Ri -readDirection 'd' = D -readDirection _ = error "direction r or d expected" - - --- * getter functions - -getConfigFile :: IORef AstState -> IO FilePath -getConfigFile = fmap (configFile . state) . readIORef - -getTvConf :: IORef AstState -> IO TextView -getTvConf = fmap (tvConf . gui) . readIORef - -getSourceBuffer :: Area -> IORef AstState -> IO SourceBuffer -getSourceBuffer a r = do - let sel = case a of - L -> fst - R -> snd - fmap (sel . sb . gui) $ readIORef r - -getTreeViews :: IORef AstState -> IO [TreeView] -getTreeViews r = do - t1 <- fmap (fst . tv . gui) $ readIORef r - t2 <- fmap (snd . tv . gui) $ readIORef r - return [t1,t2] - -getTreeView :: Area -> IORef AstState -> IO TreeView -getTreeView L = fmap (fst . tv . gui) . readIORef -getTreeView R = fmap (snd . tv . gui) . readIORef - -getSourceBuffers :: IORef AstState -> IO [SourceBuffer] -getSourceBuffers r = do - s1 <- fmap (fst . sb . gui) $ readIORef r - s2 <- fmap (snd . sb . gui) $ readIORef r - return [s1,s2] - -getAstState :: IORef AstState -> IO AstState -getAstState = readIORef - --- |returns gui data type -getGui :: IORef AstState -> IO GUI -getGui = fmap gui . readIORef - -getState :: IORef AstState -> IO State -getState = fmap state . readIORef - -getLangs :: IORef AstState -> IO [Language] -getLangs = fmap (languages . state) . readIORef - -getChanged :: Area -> IORef AstState -> IO Bool -getChanged L = fmap (fst . textchanged . state) . readIORef -getChanged R = fmap (snd . textchanged . state) . readIORef - -getCursor :: Area -> IORef AstState -> IO CursorP -getCursor L = fmap (fst . cursor . state) . readIORef -getCursor R = fmap (snd . cursor . state) . readIORef - -getFile :: Area -> IORef AstState -> IO String -getFile L = fmap (fst . cFile . state) . readIORef -getFile R = fmap (snd . cFile . state) . readIORef - -getWindow :: IORef AstState -> IO Window -getWindow = fmap (window . gui) . readIORef - --- * setter functions - -setCursor :: Area -> CursorP -> IORef AstState -> IO () -setCursor a cp r = modifyIORef r (m a) where - m :: Area -> AstState -> AstState - m L s@(AstState (State f c (_,cR) ls co cf) _ _) = - s { state = State f c (cp,cR) ls co cf} - m R s@(AstState (State f c (cL,_) ls co cf) _ _) = - s { state = State f c (cL,cp) ls co cf} - -setcFile :: Area -> FilePath -> IORef AstState -> IO () -setcFile a file r = modifyIORef r (m a) where - m :: Area -> AstState -> AstState - m L s@(AstState (State (_,cR) cp c ls co cf) _ _) = - s { state = State (file,cR) cp c ls co cf} - m R s@(AstState (State (cL,_) cp c ls co cf) _ _) = - s { state = State (cL,file) cp c ls co cf} - -setChanged :: Area -> Bool -> IORef AstState -> IO () -setChanged a b r = modifyIORef r (m a) where - m :: Area -> AstState -> AstState - m L s@(AstState (State f (_,c) cp ls co cf) _ _) = - s { state = State f (b,c) cp ls co cf} - m R s@(AstState (State f (c,_) cp ls co cf) _ _) = - s { state = State f (c,b) cp ls co cf} - - -setConfiguration :: Configuration -> IORef AstState -> IO () -setConfiguration c r = modifyIORef r m where - m :: AstState -> AstState - m s@(AstState (State f cc cp ls _ cf) _ _) = - s { state = State f cc cp ls c cf} - -setConfigFile :: FilePath -> IORef AstState -> IO () -setConfigFile fp r = modifyIORef r m where - m :: AstState -> AstState - m s@(AstState (State f cc cp ls c _) _ _) = - s { state = State f cc cp ls c fp} - --- * misc transformations - -addRelation :: Relation -> IORef AstState -> IO () -addRelation r ref = modifyIORef ref m where - m :: AstState -> AstState - m s@(AstState (State f cc cp ls (Configuration rs) fp) _ _) = - s { state = State f cc cp ls (Configuration $ rs++[r]) fp} - --- instances - -instance Show Relation where - show (Relation e1 e2) = show e1 ++" "++ show e2 - -instance Show Elem where - show (Elem p file) = show p ++ "@" ++ file - -instance Show Direction where - show D = "d" - show Ri = "r" - diff --git a/src/Language/Astview/Language.hs b/src/Language/Astview/Language.hs deleted file mode 100644 index 833b9c8..0000000 --- a/src/Language/Astview/Language.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE ExistentialQuantification , DeriveDataTypeable #-} - -{-| -This module offers the main data type 'Language'. For every language, whose -files shall be processed by astview, a value of the data type 'Language' has -to be defined. Store the file to the data folder and add it to the cabal file. --} -module Language.Astview.Language where - -import Data.Generics (Typeable) -import Data.Tree (Tree(..)) - --- |datatype for one language. Some parsers support source locations --- which enables us to connect locations in text area with locations --- in a tree. Selector function @srcLoc@ supports extracting source --- locations from a subtree (@srcLoc@ will be mapped over the whole --- tree). @srcLoc@ returns @Nothing@ if current tree does not specify --- any src loc. Function @adjustSrcLoc@ offers the ability to adjust --- src locs in abstract data type to our zero point (line 1, row 0) -data Language = forall a s . Language - { name :: String -- ^ language name - , syntax :: String -- ^ syntax highlighter name - , exts :: [String] - -- ^ file extentions which should be associated with this language - , parse :: String -> Either Error a -- ^ parse function - , toTree :: a -> Tree String -- ^ how to get a 'Tree' 'String'? - , srcLoc :: Maybe (Tree String -> [SrcLocation]) - -- ^ selector function for source locations (if supported) - , adjustSrcLoc :: Maybe (s -> s) - -- ^ adjust src locs in abstract syntax to - } deriving Typeable - -instance Eq Language where - l1 == l2 = name l1 == name l2 - - --- |datatype to specify parse errors. Since parsers offer different --- amounts of information about parse errors, we offer the following --- three parse errors: -data Error - = Err -- ^ no error information - | ErrMessage String -- ^ simple error message - | ErrLocation SrcLocation String -- ^ error message and src loc - --- |specifies a source location in text area, -data SrcLocation = SrcLocation - { line :: Int -- ^ line, zero point: 1 - , row :: Int -- ^ row, zero point: 0 - } diff --git a/src/Language/Astview/Registry.hs b/src/Language/Astview/Registry.hs deleted file mode 100644 index 9baf7b3..0000000 --- a/src/Language/Astview/Registry.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Language.Astview.Registry where - --- hint -import Language.Haskell.Interpreter hiding ((:=),set) - --- glob -import System.FilePath.Glob (compile,globDir) - --- astview-utils -import Language.Astview.Language (Language) - --- local -import Paths_astview (getDataDir) -- by cabal - --- | loads the language registration and all modules in data dir -loadLanguages :: IO [Language] -loadLanguages = do - -- find additional modules in data - (glob,_) <- globDir [compile "data/**/*.hs"] =<< getDataDir - let modules = head glob - -- run Interpreter - langs' <- runInterpreter $ interpretLangs modules - case langs' of - Right l -> return l - Left err -> error (show err) - --- | interprets the modules and returns all languages found. -interpretLangs :: [FilePath] -> Interpreter [Language] -interpretLangs modules = do - loadModules modules - setTopLevelModules ["Languages"] - return =<< interpret "languages" (as :: [Language]) - diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index 81ce7b3..0000000 --- a/src/Main.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -module Main where - --- order of imports analogous to cabal build-depends - --- base -import System.Environment(getArgs) - --- gtk -import Graphics.UI.Gtk hiding (get) - --- local -import Language.Astview.GUIActions (actionEmptyGUI,actionLoadHeadless) -import Language.Astview.GUIData -import Language.Astview.Registry (loadLanguages) -import Language.Astview.GUI (buildAststate) - - --- -------------------------------------------------------- --- * main () --- -------------------------------------------------------- - --- | loads LanguageRegistration, inits GTK-GUI, checks for a --- CLI-argument (one file to parse) and finally starts the GTK-GUI -main :: IO () -main = do - let os = Options "Monospace" 9 - ref <- buildAststate os =<< loadLanguages - - args <- getArgs - case length args of - 0 -> actionEmptyGUI ref - 1 -> actionLoadHeadless L (head args) ref - 2 -> do - actionLoadHeadless L (head args) ref - actionLoadHeadless R (last args) ref - _ -> error "Zero, one or two parameter expected" - - widgetShowAll =<< fmap window (getGui ref) - mainGUI diff --git a/src/core/Language/Astview/DataTree.hs b/src/core/Language/Astview/DataTree.hs new file mode 100644 index 0000000..b05a0a9 --- /dev/null +++ b/src/core/Language/Astview/DataTree.hs @@ -0,0 +1,146 @@ +{-| This module contains datatype-generic functions to gain a 'Ast' +out of an arbitrary term. +-} +module Language.Astview.DataTree + (annotateWithPaths + ,dataToAstIgnoreByExample + ,flatten + ,dataToAst + ,dataToAstSimpl + ,removeSubtrees + ,manual + ) where + +import Data.Generics (Data + ,extQ + ,gmapQ + ,showConstr + ,toConstr) +import Data.Typeable +import Data.Tree (Tree(..)) +import Data.Maybe(isNothing,isJust) +import Language.Astview.Language + +-- |uses the tree builder to get a tree and then runs the usual update and +-- path annotation functions. +-- +-- 'manual' is a more flexible version of 'dataToAst', but in most cases +-- 'dataToAst' is the function of choice. +-- Use 'manual' only if the tree builder function has to differ from the default +-- defined in 'dataToAst' (see 'Language.Astview.Languages.HaskellCore' for an +-- example). +manual :: (t -> Tree (Maybe AstNode)) -- ^tree builder + -> t + -> Ast +manual f = + Ast . annotateWithPaths . delegateSrcLoc . removeSubtrees isEmpty . removeNothings . f + +-- |creates an 'Ast' from the input term by using the constructor names +-- of node labels and keeping the structure. We try to associate source +-- locations to nodes by applying the source location selector at every subtree. +-- We ignore a whole subtree if the filter predicate holds (useful if meta Data +-- like source locations should not be visible in the 'Ast'). +dataToAst :: (Data t) + => (forall span.Data span => span -> Maybe SrcSpan) -- ^ source location selector + -> (forall st. Typeable st => st -> Bool) -- ^ filter predicate + -> t -> Ast +dataToAst getSrcLoc pIgnore t = manual worker t where + + worker :: Data t => t -> Tree (Maybe AstNode) + worker term | pIgnore term = Node Nothing [] + | otherwise = (gdefault `extQ` atString) term where + + atString :: String -> Tree (Maybe AstNode) + atString s = Node (Just $ AstNode s Nothing [] Identificator) [] + + gdefault :: Data t => t -> Tree (Maybe AstNode) + gdefault x = Node (Just n) cs where + + n :: AstNode + n = AstNode (showConstr $ toConstr x) (getSrcLoc x) [] Operation + + cs = gmapQ worker x + +-- |usually we want to discard all values of one type (the type of term +-- annotations) from the ast. Just give one example value of the annotation +-- type to this function and all values of this type are being discarded from +-- the ast. +dataToAstIgnoreByExample :: (Data t,Data ig) + => (forall a . (Data a,Typeable a) => a -> Maybe SrcSpan) -- ^ source location selector + -> ig -- ^all values of this type will be missing in 'Ast' + -> t -> Ast +dataToAstIgnoreByExample getLoc igExample = dataToAst getLoc ignore where + ignore t = equalTypes t igExample + +-- |dataToAstSimpl stores the terms' structure directly in the 'Ast' (without +-- annotating source locations or discarding subtrees) +dataToAstSimpl :: Data t => t -> Ast +dataToAstSimpl = dataToAst (const Nothing) (const False) + +-- * helper functions + +-- |Every node will be annotated with its path, beginning with @[0]@ for root +-- node. Don't manually annotate paths during creation of 'Ast's, instead +-- use a default (e.g. @[]@) and add paths by 'annotateWithPaths' afterwards. +annotateWithPaths :: Tree AstNode -> Tree AstNode +annotateWithPaths = f [0] where + f :: [Int] -> Tree AstNode -> Tree AstNode + f p (Node (AstNode l s _ t) cs) = + Node (AstNode l s p t) $ zipWith (\i c -> f (p++[i]) c) [0,1..] cs + +removeNothings :: Tree (Maybe AstNode) -> Tree AstNode +removeNothings (Node Nothing _) = error "cannot remove the root of a one-noded tree" +removeNothings (Node (Just n) cs) = + Node n (map removeNothings $ filter (isJust . rootLabel) cs) + +-- |removes all proper subtrees satisfying the predicate. +-- The predicate is not being checked at root node, since the resulting tree +-- has to be non-empty. +removeSubtrees :: (Tree a -> Bool) -> Tree a -> Tree a +removeSubtrees p (Node n cs) = Node n $ map (removeSubtrees p) $ filter (not . p) cs + +isEmpty :: Tree AstNode -> Bool +isEmpty (Node (AstNode "" _ _ _) []) = True +isEmpty _ = False + + +-- |returns whether both values are of the same type +equalTypes :: (Typeable b1,Typeable b2) => b1 -> b2 -> Bool +equalTypes t1 t2 = typeOf t1 == typeOf t2 + +-- |transform nested usage of cons operator to one flat operation +-- (this drastically reduces the asts depth) +flatten :: Ast -> Ast +flatten (Ast t) = Ast (annotateWithPaths $ flat t) where + + flat :: Tree AstNode -> Tree AstNode + flat t@(Node _ []) = t + flat t@(Node (AstNode "(:)" s p Operation) _) = + let lbl = '[': replicate (length (collect t) - 1) ',' ++ "]" in + Node (AstNode lbl s p Operation) (collect t) + flat (Node n cs) = Node n $ map flat cs + + collect :: Tree AstNode -> [Tree AstNode] + collect (Node (AstNode "(:)" _ _ Operation) cs) = case cs of + [t1,t2] -> flat t1 : collect t2 + _ -> err + collect (Node (AstNode "[]" _ _ Operation) []) = [] + collect _ = err + + err = error "Malformed term. Disabling flattening solves the problem." + +-- |delegates source location annotation to unique subtrees. This should +-- not lead to malformed syntax trees, since every unique subtree which is not +-- annotated with a source location represents the same source location as its +-- direct predecessor. If a subtree represents a smaller source location than +-- its predecessor, the subtree has to be explicitly tagged with +-- a smaller source location (in this case no delegation takes place). +delegateSrcLoc :: Tree AstNode -> Tree AstNode +delegateSrcLoc t@(Node (AstNode _ (Just srcLoc) _ _) [Node n cs]) = + t { subForest = [Node n'(map delegateSrcLoc cs)] } where + + n' :: AstNode + n' | isNothing (srcspan n) = n { srcspan = Just srcLoc } + | otherwise = n + +delegateSrcLoc (Node n cs) = Node n (map delegateSrcLoc cs) diff --git a/src/core/Language/Astview/Language.hs b/src/core/Language/Astview/Language.hs new file mode 100644 index 0000000..1c6bacd --- /dev/null +++ b/src/core/Language/Astview/Language.hs @@ -0,0 +1,168 @@ +{-| +This module offers the main data type 'Language'. A value of 'Language' +states how their files shall be processed by astview. +-} +module Language.Astview.Language + ( Language(..) + , SrcSpan(..) + , SrcPos(..) + , position + , linear + , span + , NodeType(..) + , Path + , AstNode(..) + , Ast(..) + , Error (..) + , SrcLocException(..) + , Parser(..) + ) +where +import Prelude hiding (span) +import Data.Tree(Tree(..)) +import Data.Generics (Typeable,Data) +import Test.QuickCheck +import Control.Exception(Exception,throw) + +-- |'NodeType' distinguishes two kinds of nodes in arbitrary haskell terms: +-- +-- * (leaf) nodes representing an identificator (and thus a 'String'). +-- Note: usually strings are lists of characters and therefore subtrees +-- of an abstract syntax tree, but we flatten these subtrees to one +-- node, which will then be annotated with 'Identificator'. +-- +-- * all constructors in a term not representing an identificator are just +-- an 'Operation' +-- +data NodeType = Operation + | Identificator + deriving Eq + +-- |A position in a tree is uniquely determined by a list of natural numbers. +-- (beginning with @0@). +type Path = [Int] + +-- |'AstNode' represents a node in an untyped abstract syntax tree +-- annotated with additional information. +data AstNode = AstNode + { label :: String -- ^ constructor name or the representing string + , srcspan :: Maybe SrcSpan -- ^the source span this node represents in the parsed text (if existing) + , path :: Path -- ^ the path from the root of the tree to this node + , nodeType :: NodeType -- ^the node type + } + deriving Eq + +instance Show AstNode where + show (AstNode l s _ _) = + l ++ (case s of { Nothing -> ""; + Just x ->replicate 5 ' ' ++"["++show x++"]"}) + +-- |An (untyped) abstract syntax tree is just a tree of 'AstNode's. +newtype Ast = Ast { ast :: Tree AstNode } + +-- |A parser is a function which transforms a string into an untyped abstract +-- syntax tree. +data Parser = PureParser (String -> Either Error Ast) + | IoParser (String -> IO (Either Error Ast)) + +-- |A value of 'Language' states how files (associated with this language by +-- their file extentions 'exts') are being parsed. +-- The file extentions of all languages known to astview may overlap, since +-- a language can be manually selected in the menu. For perfect automatic +-- language detection the extentions need to be disjoint. +data Language = Language + { name :: String -- ^ language name + , syntax :: String + -- ^ (kate) syntax highlighter name. Use @[]@ if no highlighting is desired. + , exts :: [String] + -- ^ file extentions which should be associated with this language + , parser :: Parser -- ^ parse function + } + +-- |Since parsers return different +-- amounts of information about parse errors, we distinguish the following +-- three kinds of parse errors: +data Error + = Err -- ^ no specific error information + | ErrMessage String -- ^ plain error message + | ErrLocation SrcSpan String -- ^ error message with position information + +-- * source locations and spans + +-- |represents a source position. +data SrcPos = SrcPos { line :: Int , column :: Int } deriving (Eq,Ord,Typeable,Data) + +instance Show SrcPos where + show (SrcPos l c) = show l ++ " : "++show c + +instance Arbitrary SrcPos where + arbitrary = do + NonNegative l <- arbitrary + NonNegative c <- arbitrary + return $ SrcPos l c + +-- |specifies a source span in a text area consisting of a begin position +-- and a end position. +-- Use functions 'span', 'linear' and 'position' to create source spans, since +-- they apply validity checks. +data SrcSpan = SrcSpan { begin :: SrcPos , end :: SrcPos } + deriving (Eq,Typeable,Data) + +instance Show SrcSpan where + show (SrcSpan b e) = show b ++ " , " ++ show e + +instance Ord SrcSpan where + s1 >= s2 = s2 <= s1 + s1 > s2 = s2 < s1 + (SrcSpan b e) <= s2 = s2 `contains` b && s2 `contains` e + +-- |returns whether the given source span contains the position +contains :: SrcSpan -> SrcPos -> Bool +contains (SrcSpan (SrcPos br bc) (SrcPos er ec)) (SrcPos r c) = + let s = (r,c) in (br,bc) <= s && s <= (er,ec) + +instance Arbitrary SrcSpan where + arbitrary = do + pos@(SrcPos l c ) <- arbitrary + (NonNegative l') <- arbitrary + (NonNegative c') <- arbitrary + return $ SrcSpan pos $ SrcPos (l+l') (c+c') + +-- |a smart constructor for 'SrcSpan', which also applies validity checks. +-- +-- >>> span 1 2 3 4 +-- SrcSpan (SrcPos 1 2) (SrcPos 3 4)) +span :: Int -> Int -> Int -> Int -> SrcSpan +span bl bc el ec + | bl > el = throw $ SrcLocException s + | bl == el && bc > ec = throw $ SrcLocException s + | otherwise = s where + s = SrcSpan (SrcPos bl bc) (SrcPos el ec) + +-- |a constructor for 'SrcSpan' to define an exact position. +-- +-- >>> position 1 2 +-- SrcSpan (SrcPos 1 2) (SrcPos 1 2)) +position :: Int -- ^line + -> Int -- ^row + -> SrcSpan +position line row = let p = SrcPos line row in SrcSpan p p + +-- |a constructor for 'SrcSpan' to define a span which ranges +-- over one specific line and more than one row. Since 'linear' +-- is implemented using 'span' validity of input is being checked. +-- +-- >>> linear 1 3 12 +-- SrcSpan (SrcPos 1 3) (SrcPos 1 12)) +linear :: Int -- ^ line + -> Int -- ^ begin row + -> Int -- ^ end row + -> SrcSpan +linear line beginRow endRow = span line beginRow line endRow + +data SrcLocException = SrcLocException SrcSpan deriving (Eq,Typeable) + +instance Show SrcLocException where + show (SrcLocException s) = "Source location "++show s++" is not valid." + +instance Exception SrcLocException diff --git a/src/core/Language/Astview/Languages.hs b/src/core/Language/Astview/Languages.hs new file mode 100644 index 0000000..0a01356 --- /dev/null +++ b/src/core/Language/Astview/Languages.hs @@ -0,0 +1,17 @@ +{- | +This module exports the list of languages known to astview. +You can extend it with your own languages. See +documentation of 'Language' for details. + +-} + +module Language.Astview.Languages(languages) where + +import Language.Astview.Language (Language) +import Language.Astview.Languages.Haskell (haskellExts) +import Language.Astview.Languages.Python (python) +import Language.Astview.Languages.HaskellCore (haskellCore) + +-- |all languages, whose abstract syntax trees can be viewed in astview. +languages :: [Language] +languages = [haskellExts,python,haskellCore] diff --git a/src/core/Language/Astview/Languages/Haskell.hs b/src/core/Language/Astview/Languages/Haskell.hs new file mode 100644 index 0000000..3527810 --- /dev/null +++ b/src/core/Language/Astview/Languages/Haskell.hs @@ -0,0 +1,31 @@ +module Language.Astview.Languages.Haskell (haskellExts) where +import Prelude hiding (span) + +import Language.Astview.DataTree (dataToAstIgnoreByExample) +import Language.Astview.Language + +import Data.Generics (Data, extQ) +import Data.Generics.Zipper (down', query, toZipper) + +import Language.Haskell.Exts.Parser (ParseResult (..),parseModule) +import qualified Language.Haskell.Exts.SrcLoc as HsSrcLoc + +haskellExts :: Language +haskellExts = Language "Haskell" "Haskell" [".hs"] (PureParser parsehs) + +parsehs :: String -> Either Error Ast +parsehs s = case parseModule s of + ParseOk t -> Right $ dataToAstIgnoreByExample getSrcLoc + (undefined::HsSrcLoc.SrcSpanInfo) + t + ParseFailed (HsSrcLoc.SrcLoc _ l c) m -> Left $ ErrLocation (position l c) m + +getSrcLoc :: Data t => t -> Maybe SrcSpan +getSrcLoc t = down' (toZipper t) >>= query (def `extQ` atSpan) where + + def :: a -> Maybe SrcSpan + def _ = Nothing + + atSpan :: HsSrcLoc.SrcSpanInfo -> Maybe SrcSpan + atSpan (HsSrcLoc.SrcSpanInfo (HsSrcLoc.SrcSpan _ c1 c2 c3 c4) _) = + Just $ span c1 c2 c3 c4 diff --git a/src/core/Language/Astview/Languages/HaskellCore.hs b/src/core/Language/Astview/Languages/HaskellCore.hs new file mode 100644 index 0000000..bb90f7e --- /dev/null +++ b/src/core/Language/Astview/Languages/HaskellCore.hs @@ -0,0 +1,123 @@ +module Language.Astview.Languages.HaskellCore (haskellCore) where +import Prelude hiding (span) + +import Data.Generics (Data, Typeable, ext1Q, extQ, gmapQ, + showConstr, toConstr, typeOf) +import Data.Generics.Zipper (down', query, toZipper) +import Data.Tree (Tree (Node)) + +import Language.Astview.DataTree (manual) +import Language.Astview.Language + +import qualified DynFlags as GHC +import FastString +import qualified GHC +import Lexer hiding (buffer, getDynFlags, + getSrcLoc) +import qualified OccName as GHC +import Outputable +import qualified Outputable as GHC +import Parser +import qualified RdrName as GHC +import qualified SrcLoc as GHC +import StringBuffer + +import GHC.Paths (libdir) + +haskellCore :: Language +haskellCore = Language "HaskellCore" "Haskell" [".hs"] (IoParser parsehs) + +parsehs :: String -> IO (Either Error Ast) +parsehs s = do + dynFlags <- getDynFlags + return $ + case runParser dynFlags s parseModule of + POk _ parsed -> Right (coreToAst parsed) + PFailed ss msg -> Left $ makeError ss (showSDoc dynFlags msg) + +makeError :: GHC.SrcSpan -> String -> Error +makeError ss s = + case ss of + GHC.RealSrcSpan real -> ErrLocation (ghcss2ss real) s + _ -> ErrMessage s + + +ghcss2ss :: GHC.RealSrcSpan -> SrcSpan +ghcss2ss real + = let start = GHC.realSrcSpanStart real + end = GHC.realSrcSpanEnd real + in span (GHC.srcLocLine start) + (GHC.srcLocCol start) + (GHC.srcLocLine end) + (GHC.srcLocCol end) + +runParser :: GHC.DynFlags -> String -> P a -> ParseResult a +runParser flags str parser = unP parser parseState + where + filename = "" + location = GHC.mkRealSrcLoc (mkFastString filename) 1 1 + buffer = stringToStringBuffer str + parseState = mkPState flags buffer location + +getDynFlags :: IO GHC.DynFlags +getDynFlags = + GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ + GHC.runGhc (Just libdir) GHC.getSessionDynFlags + +getSrcLoc :: Data t => t -> Maybe SrcSpan +getSrcLoc t = down' (toZipper t) >>= query (def `extQ` atSpan) where + + def :: a -> Maybe SrcSpan + def _ = Nothing + + atSpan :: GHC.SrcSpan -> Maybe SrcSpan + atSpan (GHC.RealSrcSpan ss) = Just $ ghcss2ss ss + atSpan _ = Nothing + +-- * typed ast to untyped ast + +coreToAst :: (Data t,Typeable t) => t -> Ast +coreToAst = manual worker where + worker :: (Data t,Typeable t) => t -> Tree (Maybe AstNode) + worker term + | term `equalTypes` (undefined :: GHC.SrcSpan) = Node Nothing [] + | otherwise = (gdefault `ext1Q` atL `extQ` atRdrName `extQ` atOccName `extQ` atString) term where + + atString :: String -> Tree (Maybe AstNode) + atString s = Node (Just $ AstNode s Nothing [] Identificator) [] + + atRdrName :: GHC.RdrName -> Tree (Maybe AstNode) + atRdrName rdr = Node (Just $ AstNode (rdrName2String rdr) (getSrcLoc rdr) [] Identificator) [] + + atOccName :: GHC.OccName -> Tree (Maybe AstNode) + atOccName o = Node (Just $ AstNode (GHC.occNameString o) (getSrcLoc o) [] Identificator) [] + + atL :: Data t => GHC.GenLocated GHC.SrcSpan t -> Tree (Maybe AstNode) + atL (GHC.L _ a) = worker a + + gdefault :: Data t => t -> Tree (Maybe AstNode) + gdefault x = Node (Just n) cs where + + n :: AstNode + n = AstNode (showConstr $ toConstr x) (getSrcLoc x) [] Operation + + cs = gmapQ worker x + +rdrName2String :: GHC.RdrName -> String +rdrName2String r = + case GHC.isExact_maybe r of + Just n -> showGhc n + Nothing -> + case r of + GHC.Unqual _occ -> GHC.occNameString $ GHC.rdrNameOcc r + GHC.Qual modname _occ -> GHC.moduleNameString modname ++ "." + ++ GHC.occNameString (GHC.rdrNameOcc r) + GHC.Orig _ _ -> error "GHC.Orig introduced after renaming" + GHC.Exact _ -> error "GHC.Exact introduced after renaming" + +showGhc :: (GHC.Outputable a) => a -> String +showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags + +-- |returns whether both values are of the same type +equalTypes :: (Typeable b1,Typeable b2) => b1 -> b2 -> Bool +equalTypes t1 t2 = typeOf t1 == typeOf t2 diff --git a/src/core/Language/Astview/Languages/Python.hs b/src/core/Language/Astview/Languages/Python.hs new file mode 100644 index 0000000..ff162f3 --- /dev/null +++ b/src/core/Language/Astview/Languages/Python.hs @@ -0,0 +1,32 @@ +module Language.Astview.Languages.Python (python) where +import Prelude hiding (span) +import Language.Astview.Language +import Language.Astview.DataTree (dataToAstIgnoreByExample) + +import Language.Python.Version3.Parser(parseModule) +import qualified Language.Python.Common.SrcLocation as Py + +import Data.Generics (Data,extQ) +import Data.Generics.Zipper(toZipper,down,query) + +python :: Language +python = Language "Python" "Python" [".py"] (PureParser parsePy) + +parsePy :: String -> Either Error Ast +parsePy s = case parseModule s [] of + Right (m,_) -> Right $ dataToAstIgnoreByExample getSrcLoc + (undefined::Py.SrcSpan) + m + Left e -> Left $ ErrMessage (show e) + +getSrcLoc :: Data t => t -> Maybe SrcSpan +getSrcLoc t = down (toZipper t) >>= query (def `extQ` atSpan) where + + def :: a -> Maybe SrcSpan + def _ = Nothing + + atSpan :: Py.SrcSpan -> Maybe SrcSpan + atSpan (Py.SpanPoint _ r c) = Just $ position r c + atSpan (Py.SpanCoLinear _ r sc ec) = Just $ linear r sc ec + atSpan (Py.SpanMultiLine _ sr sc er ec) = Just $ span sr sc er ec + atSpan (Py.SpanEmpty) = Nothing diff --git a/src/core/Language/Astview/SmallestSrcLocContainingCursor.hs b/src/core/Language/Astview/SmallestSrcLocContainingCursor.hs new file mode 100644 index 0000000..d24d09a --- /dev/null +++ b/src/core/Language/Astview/SmallestSrcLocContainingCursor.hs @@ -0,0 +1,57 @@ +{-| +This module contains a brute force algorithm to compute the associated subtree +for a given source span. +We need this in the GUI to associate text selections with a subtree of the ast. +-} +module Language.Astview.SmallestSrcLocContainingCursor + (smallestSrcLocContainingCursorPos) +where +import Data.Maybe(catMaybes) +import Data.Tree(flatten) +import Data.Function(on) +import Data.List (minimumBy) + +import Language.Astview.Language + +{- |selects the shortest path to the subtree of @t@ + which is annotated by the smallest source span containing + @s@ (if existing). +If multiple subtrees represent such source span the greatest subtree +is chosen. + -} +smallestSrcLocContainingCursorPos + :: SrcSpan -- ^ source span @s@ + -> Ast -- ^ tree @t@ + -> Maybe Path +smallestSrcLocContainingCursorPos sele = + selectShortestPath . locsContainingSelection sele . findAllSrcSpans + +-- |computes the shortest path in given association list. In case of an empty +-- list 'Nothing' is being returned. +selectShortestPath :: [(SrcSpan,Path)] -> Maybe Path +selectShortestPath [] = Nothing +selectShortestPath ps@(_:_) = + Just $ minimumBy (compare `on` length) $ pathsToSmallestSrcLoc ps + +-- |returns all paths with are associated with the smallest source spans. +-- Precondition: input list is nonempty. +pathsToSmallestSrcLoc :: [(SrcSpan,Path)] -> [Path] +pathsToSmallestSrcLoc ps = + let smallestSrcLoc = minimum $ map fst ps + in map snd $ filter (\(s,_) -> s==smallestSrcLoc) ps + +-- |extracts all source spans from abstract syntax tree +findAllSrcSpans :: Ast -> [(SrcSpan,Path)] +findAllSrcSpans (Ast ast) = (catMaybes . flatten . fmap getSrcLocPathPairs) ast + +-- |returns the source spans associated to given node if existing +getSrcLocPathPairs :: AstNode -> Maybe (SrcSpan,Path) +getSrcLocPathPairs (AstNode _ Nothing _ _) = Nothing +getSrcLocPathPairs (AstNode _ (Just s) p _) = Just (s,p) + +-- |removes all source spans from list, +-- which are not surrounded by given cursor selection +locsContainingSelection :: SrcSpan -> [(SrcSpan,Path)] -> [(SrcSpan,Path)] +locsContainingSelection sele = filter (\(s,_) -> s >= sele) + + diff --git a/src/gui/Language/Astview/Gui/Actions.hs b/src/gui/Language/Astview/Gui/Actions.hs new file mode 100644 index 0000000..574827b --- /dev/null +++ b/src/gui/Language/Astview/Gui/Actions.hs @@ -0,0 +1,164 @@ +{- contains the main gui functions + -} + +module Language.Astview.Gui.Actions where +import Language.Astview.DataTree (flatten) +import Language.Astview.Gui.GtkActions +import Language.Astview.Gui.Types +import Language.Astview.Language +import Language.Astview.SmallestSrcLocContainingCursor (smallestSrcLocContainingCursorPos) + +import Control.Monad (unless, void, + when) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString.Char8 as BS (hGetContents, + unpack) +import Data.List (find) +import Data.Tree (Tree (Node)) +import Prelude hiding + (writeFile) +import System.FilePath (takeExtension, + takeFileName) +import System.IO (IOMode (..), + withFile) + +-- | resets the GUI, +actionEmptyGUI :: AstAction () +actionEmptyGUI = do + clearTreeView + sourceViewSetText "" + winSetTitle unsavedDoc + +-- | updates the sourceview with a given file and parses the file +actionLoadHeadless :: FilePath -> AstAction () +actionLoadHeadless file = do + setCurrentFile file + winSetTitle (takeFileName file) + sourceViewSetText =<< liftIO (withFile file ReadMode (fmap BS.unpack . BS.hGetContents)) + deleteStar + setChanged False + actionReparse + +-- |tries to find a language based on the extension of +-- current file name +getLanguageByExtension :: AstAction (Maybe Language) +getLanguageByExtension = do + file <- getCurrentFile + languages <- getKnownLanguages + return $ find (elem (takeExtension file) . exts) languages + +getLanguage :: AstAction (Maybe Language) +getLanguage = do + maybeLang <- getActiveLanguage + case maybeLang of + Nothing -> getLanguageByExtension + Just lang -> return $ Just lang + +actionGetAst :: Language -> AstAction (Either Error Ast) +actionGetAst l = do + plain <- getText + flattening <- getFlattenLists + errOrAst <- case parser l of + PureParser p -> return $ p plain + IoParser p -> liftIO $ p plain + return $ (if flattening then flatten else id) <$> errOrAst + +-- | parses the contents of the sourceview with the selected language +actionParse :: Language -> AstAction (Tree String) +actionParse l = do + clearTreeView + setupSyntaxHighlighting l + tree <- buildTree <$> actionGetAst l + treeviewSetTree tree + +-- |constructs the tree which will be presented by our gtk-treeview +buildTree :: Either Error Ast -> Tree String +buildTree (Left Err) = Node "Parse error" [] +buildTree (Left (ErrMessage m)) = Node m [] +buildTree (Left (ErrLocation pos m)) = Node ("Parse error at:"++show pos++": "++m) [] +buildTree (Right t) = label <$> ast t + +-- |saves current file if a file is active or calls "save as"-dialog +actionSave :: AstAction () +actionSave = do + file <- getCurrentFile + text <- getText + case file of + "Unsaved document" -> actionDlgSave + _ -> do + deleteStar + writeFile file text + setChanged False + + +-- |launches a dialog which displays the text position associated to +-- last clicked tree node. +actionJumpToTextLoc :: AstAction () +actionJumpToTextLoc = do + maybeLang <- getLanguage + case maybeLang of + Nothing -> return () + Just lang -> do + astOrError <- actionGetAst lang + case astOrError of + Left _ -> return () + Right (Ast ast) -> do + gtkPath <- getPath + unless (null gtkPath) $ do + let astPath = tail gtkPath + loc = ast `at` astPath + case loc of + Nothing -> return () + Just l -> actionSelectSrcLoc l + +at :: Tree AstNode -> Path -> Maybe SrcSpan +at (Node n _ ) [] = srcspan n +at (Node _ cs) (i:is) = get i cs >>= \tree -> tree `at` is where + + get :: Int -> [a] -> Maybe a + get _ [] = Nothing + get n (x:xs) + | n < 0 = Nothing + | n > 0 = get (n-1) xs + | otherwise = Just x + + +-- |opens tree position associated with current cursor position. +actionJumpToSrcLoc :: AstAction () +actionJumpToSrcLoc = do + treePath <- actionGetAssociatedPath + case treePath of + Just p -> activatePath p + Nothing -> return () + +-- |returns the shortest path in tree which is associated with the +-- current selected source location. +actionGetAssociatedPath :: AstAction (Maybe Path) +actionGetAssociatedPath = do + sele <- getCursorPosition + maybeLang <- getLanguage + case maybeLang of + Nothing -> return Nothing + Just lang -> do + astOrError <- actionGetAst lang + case astOrError of + Left _ -> return Nothing + Right ast -> + return $ smallestSrcLocContainingCursorPos sele ast + + +-- ------------------------------------------------------------------- +-- ** other actions +-- ------------------------------------------------------------------- + +-- | destroys window widget +actionQuit :: AstAction () +actionQuit = do + isChanged <- getChanged + when isChanged $ actionQuitWorker actionSave actionQuitForce + actionQuitForce + +-- |applies current parser to sourcebuffer +actionReparse :: AstAction () +actionReparse = + whenJustM getLanguage (void . actionParse) diff --git a/src/gui/Language/Astview/Gui/GtkActions.hs b/src/gui/Language/Astview/Gui/GtkActions.hs new file mode 100644 index 0000000..6626904 --- /dev/null +++ b/src/gui/Language/Astview/Gui/GtkActions.hs @@ -0,0 +1,288 @@ +module Language.Astview.Gui.GtkActions where + +import Graphics.UI.Gtk hiding (Language) +import Graphics.UI.Gtk.SourceView + +import Prelude hiding (span, + writeFile) +import Control.Monad.IO.Class (liftIO) +import Data.Char (toLower) +import Data.Tree (Tree) +import Control.Monad +import System.FilePath (takeFileName) +import System.IO (IOMode (..), + hClose, + hPutStr, + withFile) + +import Language.Astview.Language +import Language.Astview.Gui.Types + + +clearTreeView :: AstAction () +clearTreeView = do + t <- getTreeView + liftIO $ do + c <- treeViewGetColumn t 0 + case c of + Just col-> treeViewRemoveColumn t col + Nothing -> return 0 + return () + +sourceViewSetText :: String -> AstAction () +sourceViewSetText text = do + sb <- getSourceBuffer + liftIO $ textBufferSetText sb text + +winSetTitle :: String -> AstAction () +winSetTitle title = do + w <- getWindow + liftIO $ set w [windowTitle := title++" - astview" ] + +-- | adds '*' to window title if file changed and sets state +actionBufferChanged :: AstAction () +actionBufferChanged = do + w <- fmap window getGui + t <- liftIO $ get w windowTitle + c <- getChanged + unless c $ liftIO $ set w [windowTitle := '*':t] + cp <- getCursorPosition + setCursor cp + setChanged True + +-- |removes @*@ from window title if existing and updates state +deleteStar :: AstAction () +deleteStar = do + w <- getWindow + bufferChanged <- getChanged + liftIO $ do + (t :: String) <- get w windowTitle + when bufferChanged $ + set w [windowTitle := tail t] + +-- |uses the name of given language to establish syntax highlighting in +-- source buffer +setupSyntaxHighlighting :: Language -> AstAction () +setupSyntaxHighlighting language = do + buffer <- getSourceBuffer + liftIO $ do + langManager <- sourceLanguageManagerGetDefault + maybeLang <- sourceLanguageManagerGetLanguage + langManager + (map toLower $ syntax language) + case maybeLang of + Just lang -> do + sourceBufferSetHighlightSyntax buffer True + sourceBufferSetLanguage buffer (Just lang) + Nothing -> sourceBufferSetHighlightSyntax buffer False + + +-- |select tree path +activatePath :: Path -> AstAction () +activatePath p = do + view <- getTreeView + liftIO $ do + treeViewExpandToPath view p + treeViewExpandRow view p True + treeViewSetCursor view p Nothing + +-- |returns the current cursor position in a source view. +-- return type: (line,row) +getCursorPosition :: AstAction SrcSpan +getCursorPosition = do + buffer <- getSourceBuffer + liftIO $ do + (startIter,endIter) <- textBufferGetSelectionBounds buffer + lineStart <- textIterGetLine startIter + rowStart <- textIterGetLineOffset startIter + lineEnd <- textIterGetLine endIter + rowEnd <- textIterGetLineOffset endIter + return $ span (lineStart+1) (rowStart+1) (lineEnd+1) (rowEnd+1) + +-- |selects the given source location in gui textview +actionSelectSrcLoc :: SrcSpan -> AstAction () +actionSelectSrcLoc (SrcSpan (SrcPos bl br) (SrcPos el er)) = do + textBuffer <- getSourceBuffer + liftIO $ do + let getIter line row = textBufferGetIterAtLineOffset textBuffer (line-1) (0 `max` row-1) + -- we need to subtract 1 since lines and offsets start with 0 + begin <- getIter bl br + end <- getIter el er + textBufferSelectRange textBuffer begin end + +treeviewSetTree :: Tree String -> AstAction (Tree String) +treeviewSetTree tree = do + fontsize <- getFontsize + view <- getTreeView + liftIO $ do + model <- treeStoreNew [tree] + treeViewSetModel view model + col <- treeViewColumnNew + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes + col + renderer + model + (\row -> [ cellText := row + , cellTextSize := (fromInteger . toInteger) fontsize + ] ) + treeViewAppendColumn view col + return tree + +actionGetPath :: AstAction Path +actionGetPath = do + tv <- getTreeView + rows <- liftIO (treeSelectionGetSelectedRows =<< treeViewGetSelection tv) + return $ case rows of + [] -> [] + (p:_) -> p + + +-- |moves selected source to clipboard (cut) +actionCutSource :: AstAction () +actionCutSource = do + actionCopySource + actionDeleteSource + +-- |copies selected source to clipboard +actionCopySource :: AstAction () +actionCopySource = do + buffer <- getSourceBuffer + liftIO $ do + (start,end) <- textBufferGetSelectionBounds buffer + clipBoard <- clipboardGet selectionClipboard + s :: String <- textBufferGetText buffer start end True + clipboardSetText clipBoard s + +-- |pastes text from clipboard at current cursor position +actionPasteSource :: AstAction () +actionPasteSource = do + buffer <- getSourceBuffer + liftIO $ do + clipBoard <- clipboardGet selectionClipboard + clipboardRequestText clipBoard (insertAt buffer) where + + insertAt :: SourceBuffer -> Maybe String -> IO () + insertAt buff m = whenJust m (textBufferInsertAtCursor buff) + +-- |deletes selected source +actionDeleteSource :: AstAction () +actionDeleteSource = void $ do + buffer <- getSourceBuffer + liftIO $ textBufferDeleteSelection buffer False False + + + + +-- * dialogs + +-- |sets up a simple filechooser dialog, whose response to Ok +-- is given by argument function +actionMkDialog :: FileChooserAction -> (FileChooserDialog -> AstAction ()) -> AstAction() +actionMkDialog fileChooser actionOnOkay = do + dia <- liftIO $ fileChooserDialogNew + (Just ("astview" :: String)) + Nothing + fileChooser + [] + + liftIO $ zipWithM_ (dialogAddButton dia) + [stockCancel,stockOpen] [ResponseCancel,ResponseOk] + + liftIO $ widgetShowAll dia + response <- liftIO $ dialogRun dia + case response of + ResponseCancel -> return () + ResponseOk -> actionOnOkay dia + _ -> return () + liftIO $ widgetHide dia + + +-- |lanches the "save as"-dialog +actionSaveAs :: AstAction () +actionSaveAs = actionMkDialog FileChooserActionSave onOkay where + + onOkay :: FileChooserDialog -> AstAction () + onOkay dia = do + maybeFile <- liftIO $ fileChooserGetFilename dia + case maybeFile of + Nothing-> return () + Just file -> do + setCurrentFile file + Language.Astview.Gui.GtkActions.writeFile file =<< getText + +-- | launches open dialog +actionDlgOpen :: (FilePath -> AstAction ()) -> AstAction () +actionDlgOpen f = actionMkDialog FileChooserActionOpen onOkay where + + onOkay :: FileChooserDialog -> AstAction () + onOkay dia = whenJustM (liftIO $ fileChooserGetFilename dia) f + +-- | launches save dialog +actionDlgSave :: AstAction () +actionDlgSave = actionMkDialog FileChooserActionSave onOkay where + + onOkay :: FileChooserDialog -> AstAction () + onOkay dia = do + maybeFile <- liftIO $ fileChooserGetFilename dia + case maybeFile of + Nothing-> return () + Just file -> do + g <- getGui + setChanged False + setCurrentFile file + writeFile file =<< getText + liftIO $ set (window g) [windowTitle := takeFileName file] + +-- * Shutting down astview + +-- |ends program with force +actionQuitForce :: AstAction () +actionQuitForce = do + w <- getWindow + liftIO $ widgetDestroy w + +actionQuitWorker :: AstAction () -> AstAction () -> AstAction () +actionQuitWorker onYes onElse = do + file <- getCurrentFile + + dialog <- liftIO $ messageDialogNew Nothing [] MessageQuestion ButtonsYesNo + ("Save changes to document \""++takeFileName file ++ "\" before closing?") + response <- liftIO $ do + containerSetBorderWidth dialog 2 + widgetShowAll dialog + dialogRun dialog + case response of + ResponseYes -> onYes + _ -> onElse + liftIO $ widgetHide dialog + +-- * Helper functions + +-- |similar to @when@ +whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenJust Nothing _ = return () +whenJust (Just x) action = action x + +-- |similar to @whenJust@, but value is inside a monad +whenJustM :: Monad m => m(Maybe a) -> (a -> m ()) -> m () +whenJustM val action = do + m <- val + whenJust m action + +-- |returns the text in given text buffer +getText :: AstAction String +getText = do + tb <- getSourceBuffer + liftIO $ do + start <- textBufferGetStartIter tb + end <- textBufferGetEndIter tb + textBufferGetText tb start end True + + + +-- |safe function to write files +writeFile :: FilePath -> String -> AstAction () +writeFile f str = liftIO $ + withFile f WriteMode (\h -> hPutStr h str >> hClose h) diff --git a/src/gui/Language/Astview/Gui/Init.hs b/src/gui/Language/Astview/Gui/Init.hs new file mode 100644 index 0000000..f5fc7a2 --- /dev/null +++ b/src/gui/Language/Astview/Gui/Init.hs @@ -0,0 +1,82 @@ +{- provides 'setupGUI' the main gui initialization +function. + - + -} +module Language.Astview.Gui.Init(setupGui,setupAstState,hooks) where + +import Language.Astview.Gui.Actions +import Language.Astview.Gui.GtkActions +import Language.Astview.Gui.Menu +import Language.Astview.Gui.Types +import Language.Astview.Languages (languages) + +import Control.Monad.Trans (liftIO) +import Data.IORef + +import Graphics.UI.Gtk hiding (Language) +import Graphics.UI.Gtk.SourceView + +setupAstState :: IO (IORef AstState) +setupAstState = do + newIORef $ AstState (defaultValue { knownLanguages = languages}) defaultValue + +-- |builds initial gui state from builder file +setupGui :: Builder -> IO GUI +setupGui builder = do + win <- builderGetObjectStr builder castToWindow "mainWindow" + treeview <- builderGetObjectStr builder castToTreeView "treeview" + tb <- buildSourceView =<< builderGetObjectStr builder castToScrolledWindow "swSource" + return $ GUI win treeview tb + +-- | setup the GtkSourceView and add it to the ScrollPane. return the +-- underlying textbuffer +buildSourceView :: ScrolledWindow -> IO SourceBuffer +buildSourceView sw = do + sourceBuffer <- sourceBufferNew Nothing + sourceBufferSetHighlightSyntax sourceBuffer True + sourceView <- sourceViewNewWithBuffer sourceBuffer + sourceViewSetShowLineNumbers sourceView True + sourceViewSetHighlightCurrentLine sourceView True + srcfont <- fontDescriptionFromString $ font defaultValue ++" "++show (fsize defaultValue) + widgetModifyFont sourceView (Just srcfont) + containerAdd sw sourceView + return sourceBuffer + +-- * hooks + +-- | adds actions to widgets defined in type 'Gui'. +hooks :: AstAction (ConnectId Window) +hooks = do + runner <- ioRunner + storeLastActiveTextPosition runner + storeLastActiveTreePosition runner + closeAstviewOnWindowClosed runner + close runner + +type Hook a = (AstAction () -> IO ()) -> AstAction (ConnectId a) + +-- |stores the last active cursor position in text to the program state +storeLastActiveTextPosition :: Hook SourceBuffer +storeLastActiveTextPosition runner = do + buffer <- getSourceBuffer + liftIO $ buffer `on` bufferChanged $ runner actionBufferChanged + +-- |stores the path to the last selected tree cell to the program state +storeLastActiveTreePosition :: Hook TreeView +storeLastActiveTreePosition runner = do + tree <- getTreeView + liftIO $ tree `on` cursorChanged $ do + (p,_) <- treeViewGetCursor tree + runner (setTreePath p) + +-- |softly terminate application on main window closed +closeAstviewOnWindowClosed :: Hook Window +closeAstviewOnWindowClosed runner = do + w <- getWindow + liftIO $ w `on` deleteEvent $ tryEvent $ liftIO $ runner actionQuit + +-- |terminate application on main window closed +close :: Hook Window +close _ = do + w <- getWindow + liftIO $ w `on` objectDestroy $ mainQuit diff --git a/src/gui/Language/Astview/Gui/Menu.hs b/src/gui/Language/Astview/Gui/Menu.hs new file mode 100644 index 0000000..c13f458 --- /dev/null +++ b/src/gui/Language/Astview/Gui/Menu.hs @@ -0,0 +1,275 @@ +{- | This module creates the menu bar and binds Actions +to the respective MenuItems. +-} +module Language.Astview.Gui.Menu (initMenu,connect,builderGetObjectStr) where + +import Language.Astview.Gui.Actions +import Language.Astview.Gui.GtkActions +import Language.Astview.Gui.Types +import Language.Astview.Language +import Language.Astview.Languages (languages) + +import Control.Monad (forM_) +import Control.Monad.IO.Class (liftIO) +import Data.List (intercalate) +import Data.Monoid ((<>)) +import Graphics.UI.Gtk hiding (Language) +import Paths_astview (getDataFileName) +import System.FilePath (()) +import System.Glib.UTFString (stringToGlib) + +-- |sets up the menu and binds menu items to logic +initMenu :: Builder -> AstAction () +initMenu builder = do + uiManager <- liftIO uiManagerNew + menuDeclFile <- liftIO $ getDataFileName ("data" "menu.xml") + liftIO $ uiManagerAddUiFromFile uiManager menuDeclFile + uiManagerBuildLanguagesMenu uiManager + + actionGroup <- liftIO $ actionGroupNew ("ActionGroup" :: String) + initMenuFile actionGroup + initMenuEdit actionGroup + initMenuNavigate actionGroup + initMenuLanguages actionGroup + initMenuHelp actionGroup builder + + liftIO $ do + uiManagerInsertActionGroup uiManager actionGroup 0 + maybeMenubar <- uiManagerGetWidget uiManager ("/ui/menubar" :: String) + let menubar = case maybeMenubar of + Nothing -> error $ "Could not parse menu bar declaration from " + ++ show menuDeclFile + Just m -> m + vboxMain <- builderGetObjectStr builder castToBox "vboxMain" + vboxMain `set` [ containerChild := menubar ] + boxReorderChild vboxMain menubar 0 + +-- |creates a menu item for every element of 'knownLanguages' in menu "Languages". +-- +-- We do this dynamically, because the menu.xml should not contain any static +-- information about specific languages. This offers simple addition of +-- new languages by just adding it to the list of languages without even +-- touching any gui component. +uiManagerBuildLanguagesMenu :: UIManager -> AstAction () +uiManagerBuildLanguagesMenu uiManager = do + langs <- getKnownLanguages + liftIO $ do + forM_ langs $ \lang -> do + mergeId <- uiManagerNewMergeId uiManager + let ident = "actionLanguage"++name lang + uiManagerAddUi uiManager mergeId "/ui/menubar/Languages/LangsSep" + (ident :: String) + (Just ident) + [UiManagerMenuitem] + False + +-- |the association between the gui functions from 'Actions' +-- and the gtk identifier from xml file. +menuActions :: [(String,AstAction ())] +menuActions = menuFile ++ menuEdit ++ menuNavigate where + menuFile = + [("actionNew",actionEmptyGUI) + ,("actionSaveAs",actionSaveAs) + ,("actionOpen",actionDlgOpen actionLoadHeadless) + ,("actionSave",actionSave) + ,("actionQuit",actionQuit) + ] + menuEdit = + [("actionCut",actionCutSource) + ,("actionCopy",actionCopySource) + ,("actionPaste",actionPasteSource) + ,("actionDelete",actionDeleteSource) + ,("actionReparse",actionReparse) + ,("actionFlatten",actionReparse) + ] + menuNavigate = + [("actionTreeLoc",actionJumpToSrcLoc) + ,("actionTextLoc",actionJumpToTextLoc) + ] + +-- |associate the menu action with the respective +-- gui function from module Actions +connect :: Action -> AstAction (ConnectId Action) +connect action = do + runner <- ioRunner + liftIO $ do + name <- actionGetName action + case lookup name menuActions of + Nothing -> error $ "No action associated with "++ show name + Just f -> action `on` actionActivated $ runner f + + +-- * the menu File + +initMenuFile :: ActionGroup -> AstAction () +initMenuFile actionGroup = do + actions <- liftIO $ do + actionFile <- actionNewStr "actionMenuFile" "File" Nothing Nothing + + actionNew <- actionNewStr "actionNew" "New" Nothing (Just stockNew) + actionOpen <- actionNewStr "actionOpen" "Open" Nothing (Just stockOpen) + actionSave <- actionNewStr "actionSave" "Save" Nothing (Just stockSave) + actionSaveAs <- actionNewStr "actionSaveAs" "Save As" Nothing (Just stockSaveAs) + actionQuit <- actionNewStr "actionQuit" "Quit" Nothing (Just stockQuit) + actionGroupAddAction actionGroup actionFile + return [actionNew,actionOpen,actionSave,actionSaveAs,actionQuit] + + forM_ actions $ \action -> do + connect action + liftIO $ addAction actionGroup action Nothing + + +-- * the menu Edit + +initMenuEdit :: ActionGroup -> AstAction () +initMenuEdit actionGroup = do + + actionReparse <- liftIO $ actionNewStr "actionReparse" "Reparse" Nothing (Just stockRefresh) + actions <- liftIO $ do + actionEdit <- actionNewStr "actionMenuEdit" "Edit" Nothing Nothing + + actionCut <- actionNewStr "actionCut" "Cut" Nothing (Just stockCut) + actionCopy <- actionNewStr "actionCopy" "Copy" Nothing (Just stockCopy) + actionPaste <- actionNewStr "actionPaste" "Paste" Nothing (Just stockPaste) + actionDelete <- actionNewStr "actionDelete" "Delete" Nothing (Just stockRemove) + actionGroupAddAction actionGroup actionEdit + return [actionCut,actionCopy,actionPaste,actionDelete,actionReparse] + + forM_ actions $ \action -> do + connect action + liftIO $ addAction actionGroup action Nothing + + liftIO $ actionSetAccelPath actionReparse ("p" :: String) + initMenuItemFlatten actionGroup + +-- |bind the check menu for flattening lists to the boolean value in the state. +initMenuItemFlatten :: ActionGroup -> AstAction () +initMenuItemFlatten actionGroup = do + run <- ioRunner + isFlat <- getFlattenLists + let actionToggleFlatten = + ToggleActionEntry "actionFlatten" + "Flatten lists in tree?" + Nothing Nothing Nothing + (run f) + isFlat + + f :: AstAction () + f = do + isFlat <- getFlattenLists + setFlattenLists (not isFlat) + actionReparse + + liftIO $ actionGroupAddToggleActions actionGroup [actionToggleFlatten] + +-- * the menu Navigate + +initMenuNavigate :: ActionGroup -> AstAction () +initMenuNavigate actionGroup = do + actions <- liftIO $ do + actionNavigate <- actionNewStr "actionMenuNavigate" "Navigate" Nothing Nothing + + actionTreeLoc <- actionNewStr "actionTreeLoc" ">>>" Nothing Nothing + actionTextLoc <- actionNewStr "actionTextLoc" "<<<" Nothing Nothing + actionGroupAddAction actionGroup actionNavigate + return [actionTreeLoc,actionTextLoc] + + forM_ actions $ \action -> do + connect action + liftIO $ addAction actionGroup action Nothing + + +-- * the menu Languages + +-- |sets up the menu @Languages@ and binds actions to the menu items. +initMenuLanguages :: ActionGroup -> AstAction () +initMenuLanguages actionGroup = do + langs <- getKnownLanguages + run <- ioRunner + liftIO $ do + actionLangs <- actionNewStr "actionMenuLanguages" "Languages" Nothing Nothing + actionGroupAddAction actionGroup actionLangs + let auto = RadioActionEntry + "actionLanguageAuto" + "Automatically select languages" + Nothing Nothing Nothing 0 + raes = auto:languagesToRadioActionEntry langs + actionGroupAddRadioActions actionGroup raes 0 $ \a -> run (onRadioChange a) + +-- |creates a 'RadioActionEntry' for every language +languagesToRadioActionEntry :: [Language] -> [RadioActionEntry] +languagesToRadioActionEntry languages = zipWith mkRadioActionEntry languages [1..] where + mkRadioActionEntry :: Language -> Int -> RadioActionEntry + mkRadioActionEntry lang i = + RadioActionEntry ("actionLanguage" <> stringToGlib (name lang)) + (stringToGlib $ makeLanguageLabel lang) + Nothing Nothing Nothing i + +-- |bind functionality to RadioAction +onRadioChange :: RadioAction -> AstAction () +onRadioChange action = do + i <- liftIO $ radioActionGetCurrentValue action + if i == 0 + then + setActiveLanguage Nothing + else + let lang = languages !! (i-1) in + setActiveLanguage (Just lang) + actionReparse + +-- |produces a string containing the languages' name and +-- the associated file extensions +makeLanguageLabel :: Language -> String +makeLanguageLabel language = + name language ++ + " [" ++ + intercalate "," (map (\l -> "*"++l) $ exts language)++ + "]" + +-- * the language Help + +initMenuHelp :: ActionGroup -> Builder -> AstAction () +initMenuHelp actionGroup _ = liftIO $ do + actionHelp <- actionNewStr "actionMenuHelp" "Help" Nothing Nothing + actionAbout <- actionNewStr "actionAbout" "About" Nothing (Just stockAbout) + actionGroupAddAction actionGroup actionHelp + addAction actionGroup actionAbout Nothing + license <- getLicense + actionAbout `on` actionActivated $ do + dialog <- aboutDialogNew + set dialog [ aboutDialogWebsite := ("https://github.com/pascalh/Astview"::String) + , aboutDialogProgramName := ("Astview"::String) + , aboutDialogComments := aboutComment + , aboutDialogWrapLicense := True + , aboutDialogLicense := Just license + , aboutDialogAuthors := authors + ] + widgetShow dialog + dialog `on` response $ \_ -> widgetHide dialog + return () + return () + +aboutComment :: String +aboutComment = + "astview: View abstract syntax trees for your custom languages and "++ + "parsers in a graphical (GTK+) application." + +getLicense :: IO String +getLicense = readFile =<< getDataFileName "LICENSE" + +authors :: [String] +authors = + [ "Pascal Hof <pascal.hof@tu-dortmund.de> (2009-)" + , "Sebastian Menge <sebastian.menge@tu-dortmund.de> (2009-2011)" + ] + +-- ** helper functions + +actionNewStr :: String -> String -> Maybe String -> Maybe StockId -> IO Action +actionNewStr = actionNew + +addAction :: ActionGroup -> Action -> Maybe String -> IO () +addAction = actionGroupAddActionWithAccel + +builderGetObjectStr :: GObjectClass cls => Builder -> (GObject -> cls) -> String -> IO cls +builderGetObjectStr = builderGetObject diff --git a/src/gui/Language/Astview/Gui/Types.hs b/src/gui/Language/Astview/Gui/Types.hs new file mode 100644 index 0000000..abff2c6 --- /dev/null +++ b/src/gui/Language/Astview/Gui/Types.hs @@ -0,0 +1,167 @@ +{- contains the GUI data types + - + -} +module Language.Astview.Gui.Types where +import Data.Label +import Data.IORef +import Control.Monad.Reader + +import Graphics.UI.Gtk hiding (Language,get,set) +import Graphics.UI.Gtk.SourceView (SourceBuffer) +import Language.Astview.Language(Language,SrcSpan,Path,position) + +-- |a type class for default values, compareable to mempty in class 'Monoid' +class Default a where + defaultValue :: a + +type AstAction a = ReaderT (IORef AstState) (ReaderT GUI IO) a + +-- |run a 'AstAction' by providing values for the reader monad. +-- (in most cases 'ioRunner' is more useful) +runAsIo :: GUI -> IORef AstState -> AstAction a -> IO a +runAsIo gui st f = runReaderT (runReaderT f st) gui + +-- |returns a transformer from 'AstAction' to 'IO' +ioRunner :: AstAction (AstAction a -> IO a) +ioRunner = do + ioref <- ask + gui <- lift ask + return $ \f -> runAsIo gui ioref f + +-- |internal program state +data AstState = AstState + { state :: State -- ^ intern program state + , options :: Options -- ^ global program options + } + +-- |data type for global options, which can be directly changed in the gui +-- (...or at least should be. Menu for changing font and font size not yet +-- implemented) +data Options = Options + { font :: String -- ^ font name of textbuffer + , fsize :: Int -- ^ font size of textbuffer + , flattenLists :: Bool -- ^should lists be flattened + } + +instance Default Options where + defaultValue = Options "Monospace" 9 True + +-- |data type for the internal program state +data State = State + { currentFile :: String -- ^ current file + , textchanged :: Bool -- ^ true if buffer changed after last save + , lastSelectionInText :: SrcSpan -- ^ last active cursor position + , lastSelectionInTree :: Path -- ^ last clicked tree cell + , knownLanguages :: [Language] -- ^ known languages, which can be parsed + , activeLanguage :: Maybe Language -- ^the currently selected language or Nothing if language is selected by file extension + } + +instance Default State where + defaultValue = State + { currentFile = unsavedDoc + , textchanged = False + , lastSelectionInText = position 0 0 + , lastSelectionInTree = [] + , knownLanguages = [] + , activeLanguage = Nothing + } + +-- |unsaved document +unsavedDoc :: String +unsavedDoc = "Unsaved document" + +-- |main gui data type, contains gtk components +data GUI = GUI + { window :: Window -- ^ main window + , tv :: TreeView -- ^ treeview + , sb :: SourceBuffer -- ^ sourceview + } + + +-- * getAstStateter functions + +mkLabels [ ''AstState + , ''Options + , ''State + , ''GUI + ] + + + +getAstState :: AstAction AstState +getAstState = do + ioRef <- ask + liftIO (readIORef ioRef) + +getSourceBuffer :: AstAction SourceBuffer +getSourceBuffer = sb <$> getGui + +getTreeView :: AstAction TreeView +getTreeView = tv <$> getGui + +getGui :: AstAction GUI +getGui = lift ask + +getState :: AstAction State +getState = state <$> getAstState + +getKnownLanguages :: AstAction [Language] +getKnownLanguages = (knownLanguages . state) <$> getAstState + +getChanged :: AstAction Bool +getChanged = (textchanged . state) <$> getAstState + +getCursor :: AstAction SrcSpan +getCursor = (lastSelectionInText . state) <$> getAstState + +getPath :: AstAction TreePath +getPath = (lastSelectionInTree . state) <$> getAstState + + +getCurrentFile :: AstAction String +getCurrentFile = (currentFile . state) <$> getAstState + +getActiveLanguage :: AstAction (Maybe Language) +getActiveLanguage = (activeLanguage . state) <$> getAstState + +getWindow :: AstAction Window +getWindow = window <$> getGui + +getFlattenLists :: AstAction Bool +getFlattenLists = (flattenLists . options) <$> getAstState + +getFontsize :: AstAction Int +getFontsize = (fsize . options) <$> getAstState + +-- * setter functions + +lensSetIoRef :: (AstState :-> a) -> (a :-> b) -> b -> AstAction () +lensSetIoRef outerLens innerLens value = do + ref <- ask + liftIO $ modifyIORef ref m where + + m :: AstState -> AstState + m = modify outerLens (set innerLens value) + +-- |stores the given cursor selection +setCursor :: SrcSpan -> AstAction () +setCursor = lensSetIoRef lState lLastSelectionInText + +-- |stores the given tree selection +setTreePath :: Path -> AstAction () +setTreePath = lensSetIoRef lState lLastSelectionInTree + +-- |stores file path of current opened file +setCurrentFile :: FilePath -> AstAction () +setCurrentFile = lensSetIoRef lState lCurrentFile + +-- |stores whether the current file buffer has been changed +setChanged :: Bool -> AstAction () +setChanged = lensSetIoRef lState lTextchanged + +-- |stores whether the lists in trees should be flattened +setFlattenLists :: Bool -> AstAction () +setFlattenLists = lensSetIoRef lOptions lFlattenLists + +setActiveLanguage :: Maybe Language -> AstAction () +setActiveLanguage = lensSetIoRef lState lActiveLanguage diff --git a/src/gui/Main.hs b/src/gui/Main.hs new file mode 100644 index 0000000..9f6c519 --- /dev/null +++ b/src/gui/Main.hs @@ -0,0 +1,44 @@ +module Main where + +import Control.Monad.Reader +import Graphics.UI.Gtk hiding (get) +import Paths_astview (getDataFileName) +import System.Environment (getArgs) +import System.FilePath (()) + +import Language.Astview.Gui.Actions (actionEmptyGUI, + actionLoadHeadless) +import Language.Astview.Gui.Init (hooks, setupAstState, setupGui) +import Language.Astview.Gui.Menu (initMenu) +import Language.Astview.Gui.Types + + + +-- | loads LanguageRegistration, inits GTK-GUI, checks for a +-- CLI-argument (one file to parse) and finally starts the GTK-GUI +main :: IO () +main = do + initGUI + + builder <- builderNew + builderAddFromFile builder =<< getDataFileName ("data" "astview.xml") + + gui <- setupGui builder + ioref <- setupAstState + + args <- getArgs + + runAsIo gui ioref $ do + + initMenu builder + hooks + + case args of + [] -> actionEmptyGUI + [file] -> actionLoadHeadless file + _ -> error "Zero or one argument expected" + + w <- getWindow + liftIO $ do + widgetShowAll w + mainGUI diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..45d7144 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,5 @@ +flags: {} +extra-package-dbs: [] +packages: +- . +resolver: lts-8.24 diff --git a/test/DataTree.hs b/test/DataTree.hs new file mode 100644 index 0000000..327a2f1 --- /dev/null +++ b/test/DataTree.hs @@ -0,0 +1,245 @@ +{-| This module contains test cases for the functions creating abstract +syntax trees defined in module 'Language.Astview.DataTree'. -} +module DataTree(testDataTree) where +import Prelude hiding (span) +import Test.Tasty +import Test.Tasty.QuickCheck hiding (label) + +import Data.Tree(Tree(..)) +import Control.Monad(liftM,liftM2,liftM3) +import Data.Foldable (foldrM) +import Data.List(sort) +import Data.Generics (Data) +import Data.Typeable(Typeable,typeOf) +import Control.Monad.Omega(diagonal) +import Language.Astview.DataTree +import Language.Astview.Language + + +propIgnoreInt :: TestTree +propIgnoreInt = testProperty "removing leafs with int values" p where + + p (TermUnit t) = act t === exped t + + act :: Term () -> Tree String + act = fmap label . ast . dataToAstIgnoreByExample (const Nothing) (1::Int) + + exped :: Term () -> Tree String + exped = removeSubtrees (\t -> isNumber t || isEmpty t) . fmap label . ast . dataToAstSimpl + + isEmpty :: Tree String -> Bool + isEmpty = null . rootLabel + + isNumber :: Tree String -> Bool + isNumber (Node ('-':xs) _) = not (null xs) && all (\x -> elem x ['0'..'9']) xs + isNumber (Node xs@(_:_) _) = all (\x -> elem x ['0'..'9']) xs + isNumber _ = False + +-- * + +testDataTree :: TestTree +testDataTree = testGroup "data to ast" [testsBasic,propIgnoreInt] where + +testsBasic :: TestTree +testsBasic = testGroup "Basic data to ast transformations" + [mkProp b f | b <- [True,False] , f <- [True,False]] where + + mkProp ::Bool -> Bool -> TestTree + mkProp b f = testProperty name p where + + name = (if b then " " else "remove annotations ") ++ + (if f then "flattened" else "") + + p :: TermUnit -> Property + p (TermUnit t) = actual b f t === expected b f t + +-- |applies functions from 'Language.Astview.DataTree' to given term +actual :: Bool -- ^ should the term contain annotations= + -> Bool -- ^ should be term be flattened + -> Term () -- ^ input term + -> Tree String +actual b f = fmap label . ast . mkFlat . mkAst where + + mkFlat :: Ast -> Ast + mkFlat = if f then flatten else id + + mkAst :: Term () -> Ast + mkAst = if b then dataToAstSimpl + else dataToAstIgnoreByExample (const Nothing) () + +-- * a toy language + +data Term ann + = EmptyLeaf + | Leaf ann String + | Number ann Int + | Nested ann (Term ann) + | BinaryBranch ann (Term ann) (Term ann) + | List ann [Term ann] + deriving (Show,Data,Typeable,Functor) + +newtype TermUnit = TermUnit {term :: Term () } + +instance Show TermUnit where + show = show . term + +instance Arbitrary TermUnit where + arbitrary = liftM TermUnit arbitrary + +newtype TermSrcloc = TermSrcloc { termSrcLoc :: Term SrcSpan} + +instance Show TermSrcloc where + show = show . termSrcLoc + +instance Arbitrary TermSrcloc where + arbitrary = do + TermUnit t <- arbitrary + l <- arbitrary + t' <- arbitrarySrcLocs l t + return $ TermSrcloc t' + +-- * creating the expected trees + +-- |builds the expected tree for a given term +expected :: Bool -- ^should tree contain annotations + -> Bool -- ^flatten lists in tree? + -> Term () -> Tree String +expected _ _ EmptyLeaf = Node "EmptyLeaf" [] +expected b _ (Leaf _ s) = annotate b $ Node "Leaf" [Node s []] +expected b _ (Number _ n) = annotate b $ Node "Number" [Node (show n) []] +expected b f (Nested _ t) = annotate b $ Node "Nested" [expected b f t] +expected b f (BinaryBranch _ t1 t2) = + annotate b $ Node "BinaryBranch" [expected b f t1,expected b f t2] +expected b False (List _ ts) = annotate b $ Node "List" [ts' ts] where + + ts' :: [Term ()] -> Tree String + ts' [] = Node "[]" [] + ts' (t:ts) = Node "(:)" [expected b False t,ts' ts] + +expected b True (List _ []) = annotate b $ Node "List" [Node "[]" []] +expected b True (List _ ts) = annotate b $ Node "List" [Node lbl (map (expected b True) ts)] where + + lbl :: String + lbl = "["++replicate (length ts - 1) ',' ++ "]" + +annotate :: Bool -> Tree String -> Tree String +annotate b (Node l cs) + | b = let unit = Node "()" [] + in Node l $ unit : cs + | otherwise = Node l cs + +-- ** the generation of arbitrary terms + +instance Arbitrary ann => Arbitrary (Term ann) where + arbitrary = sized arbitraryTerm + +arbitraryTerm :: Arbitrary a => Int -> Gen (Term a) +arbitraryTerm 0 = oneof [return EmptyLeaf, arbitraryString, arbitraryInt] +arbitraryTerm n + | n > 0 = oneof [ arbitraryNested n, arbitraryBinary n, arbitraryList n] + | n < 0 = return EmptyLeaf + +arbitraryString :: Arbitrary a => Gen (Term a) +arbitraryString = liftM2 Leaf arbitrary (listOf1 arbitraryChar) where + + arbitraryChar :: Gen Char + arbitraryChar = elements $ ['A'..'Z']++['a'..'z'] + +arbitraryInt :: Arbitrary a => Gen (Term a) +arbitraryInt = liftM2 Number arbitrary arbitrary + +arbitraryNested :: Arbitrary a => Int -> Gen (Term a) +arbitraryNested n = liftM2 Nested arbitrary (arbitraryTerm (n-1)) + +arbitraryBinary :: Arbitrary a => Int -> Gen (Term a) +arbitraryBinary n = do + (n1,n2) <- split n + liftM3 BinaryBranch arbitrary (arbitraryTerm n1) (arbitraryTerm n2) + +arbitraryList :: Arbitrary a => Int -> Gen (Term a) +arbitraryList n = do + m <- elements [0..5] + ann <- arbitrary + case m of + 0 -> return $ List ann [] + 1 -> liftM (\t -> List ann [t]) (arbitraryTerm (n-1)) + _ -> do + ns <- splits m n + ts <- foldrM (\n acc -> do {t <- arbitraryTerm n ; return $ t:acc}) [] ns + return $ List ann ts + +-- |split n returns an arbitrary pair (x1,x2) such that x1 + x2 == n +split :: Int -> Gen (Int,Int) +split n = do + x <- elements [0..n] + return (x,n-x) + +splits :: Int -> Int -> Gen [Int] +splits 2 n = do + (x1,x2) <- split n + return [x1,x2] +splits m n = do + (x1,x2) <- split n + xs <- splits (m-1) x1 + return (x2:xs) + +-- |given a term and a source span arbitrarySrcLocs annotates the term +-- with source spans, such that the span at the root of every subterm t +-- surrounds the spans of every successor of t. +arbitrarySrcLocs :: SrcSpan -> Term () -> Gen (Term SrcSpan) +arbitrarySrcLocs _ EmptyLeaf = return EmptyLeaf +arbitrarySrcLocs l (Leaf _ str) = return $ Leaf l str +arbitrarySrcLocs l (Number _ n) = return $ Number l n +arbitrarySrcLocs l (Nested _ t) = do + l' <- sublocation l + t' <- arbitrarySrcLocs l' t + return $ Nested l t' +arbitrarySrcLocs l (BinaryBranch _ t1 t2) = do + (s1,s2) <- sublocation2 l + t1' <- arbitrarySrcLocs s1 t1 + t2' <- arbitrarySrcLocs s2 t2 + return $ BinaryBranch l t1' t2' +arbitrarySrcLocs l (List _ []) = return $ List l [] +arbitrarySrcLocs l (List _ (t:ts)) = do + (s1,s2) <- sublocation2 l + t' <- arbitrarySrcLocs s1 t + ts' <- arbitrarySrcLocs s2 (List () ts) + return $ List l (t':ts':[]) + + + + + +-- |sublocation loc returns a arbitrary source span loc' which is +-- surrounded by loc +sublocation :: SrcSpan -> Gen SrcSpan +sublocation s = do + NonNegative n <- arbitrary + let g = elements $ positionsInSpan n s + p1 <- g + p2 <- g + return $ if p1 < p2 then SrcSpan p1 p2 else SrcSpan p2 p1 + +sublocation2 :: SrcSpan -> Gen (SrcSpan,SrcSpan) +sublocation2 s = do + NonNegative n <- arbitrary + let g = elements $ positionsInSpan n s + p1 <- g + p2 <- g + p3 <- g + p4 <- g + let [p1,p2,p3,p4] = sort [p1,p2,p3,p4] + return (SrcSpan p1 p2,SrcSpan p3 p4) + +-- |returns n source positions which are in the given source span +positionsInSpan :: Int -> SrcSpan -> [SrcPos] +positionsInSpan n = sort . take n . diagonal . locsPerLine where + + locsPerLine :: SrcSpan -> [[SrcPos]] + locsPerLine (SrcSpan (SrcPos bl bc) (SrcPos el ec)) + | bl == el = [[SrcPos bl c | c <- [bc..ec]]] + | bl > el = [] + | bl < el = [SrcPos bl c | c <- [bc..]] : + locsPerLine (span (bl+1) 1 el ec) + + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..b0ac5cd --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,13 @@ +module Main where +import Test.Tasty (defaultMain,testGroup) + +import SourceLocation(testSourceLocations) +import SmallestSrcLocContainingCursor (testSelect) +import DataTree(testDataTree) + +main :: IO () +main = defaultMain $ testGroup "Tests" + [ testSourceLocations + , testSelect + , testDataTree + ] diff --git a/test/SmallestSrcLocContainingCursor.hs b/test/SmallestSrcLocContainingCursor.hs new file mode 100644 index 0000000..5a02390 --- /dev/null +++ b/test/SmallestSrcLocContainingCursor.hs @@ -0,0 +1,83 @@ +module SmallestSrcLocContainingCursor (testSelect) where + +import Test.Tasty +import Test.Tasty.HUnit +import Prelude hiding (span) +import Language.Astview.SmallestSrcLocContainingCursor + (smallestSrcLocContainingCursorPos) +import Language.Astview.DataTree(annotateWithPaths) +import Language.Astview.Language + +import Data.Tree (Tree(Node)) + +testSelect :: TestTree +testSelect = + testGroup "selecting the greatest sorrounding source location" + [t1,t2,t3,t4,t5,t6] + +-- |a shorter name +select :: SrcSpan -> Ast -> Maybe [Int] +select = smallestSrcLocContainingCursorPos + +mkTree :: String -> SrcSpan -> [Tree AstNode] -> Tree AstNode +mkTree l s cs = annotateWithPaths $ Node (AstNode l (Just s) [] Identificator) cs + +t1 :: TestTree +t1 = testCase "return first occourence" $ + select (span 1 2 1 7) (Ast ast) @?= Just [0] where + ast = mkTree "a" (span 1 2 1 7) [] + +t2 :: TestTree +t2 = testCase "return immediate successor" $ + let r = span 1 2 3 9 + ast = mkTree "a" (span 1 1 16 3) [c] + c = mkTree "b" r [] + in + select (span 1 3 3 6) (Ast ast) + @?= + Just [0,0] + +t3 :: TestTree +t3 = testCase "return root if successor does not match" $ + let r = span 1 1 19 7 + ast = mkTree "a" r [c] + c = mkTree "b" (span 10 2 17 9 ) [] + in + select (span 1 2 3 9) (Ast ast) + @?= + Just [0] + + +t4 :: TestTree +t4 = testCase "return leaf in three containing spans" $ + let r = span 2 1 4 2 + ast = mkTree "a" (span 1 1 16 3) [c1] + c1 = mkTree "b" (span 1 1 5 9) [c2] + c2 = mkTree "b" r [] + in + select (span 2 1 3 1) (Ast ast) + @?= + Just [0,0,0] + +t5 :: TestTree +t5 = testCase "triangle, select the correct child" $ + let r = span 2 1 4 5 + ast = mkTree "a" (span 1 1 16 3) [c1,c2] + c1 = mkTree "b" (span 10 1 15 9) [] + c2 = mkTree "b" r [] + in + select (span 2 1 3 1) (Ast ast) + @?= + Just [0,1] + +t6 :: TestTree +t6 = testCase "triangle, select multiple locations" $ + let r = span 2 1 4 2 + ast = mkTree "a" (span 1 1 16 3) [c1,c2] + c1 = mkTree "b" (span 10 1 15 9) [] + c2 = mkTree "b" r [c3] + c3 = mkTree "b" r [] + in + select (span 2 1 3 1) (Ast ast) + @?= + Just [0,1] diff --git a/test/SourceLocation.hs b/test/SourceLocation.hs new file mode 100644 index 0000000..a74e8d3 --- /dev/null +++ b/test/SourceLocation.hs @@ -0,0 +1,123 @@ +{-| This module contains test cases for functions on source locations. -} +module SourceLocation(testSourceLocations) where +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit +import Prelude hiding (span) +import Language.Astview.Language +import Control.Exception(Exception,evaluate,try) +import Control.Monad(unless) + +testSourceLocations :: TestTree +testSourceLocations = + testGroup "Source locations" [groupContains,smartConstructors] + +groupContains :: TestTree +groupContains = + testGroup "ord instance for source locations implements contains" + [groupInOneline + ,groupSorrounded + ,groupSameBegin + ,groupSameEnd + ,groupEx + ,groupAlgebraicProperties + ] + +groupAlgebraicProperties :: TestTree +groupAlgebraicProperties = testGroup "algebraic properties" + [propReflexivity + ,propDuality + ] + +propReflexivity :: TestTree +propReflexivity = testGroup "Reflexivity" [propLEQ,propGEQ] where + + propLEQ = testProperty "Reflexivity of <=" prop where + + prop :: SrcSpan -> Bool + prop s = s <= s + + propGEQ = testProperty "Reflexivity of >=" prop where + + prop :: SrcSpan -> Bool + prop s = s >= s + +propDuality:: TestTree +propDuality = testProperty "Duality of < and >" prop where + + prop :: SrcSpan -> SrcSpan -> Bool + prop a b + | a < b = b > a && a /= b + | a == b = b == a + | a > b = b < a && a /= b + | otherwise = True + +groupInOneline :: TestTree +groupInOneline = testGroup "Everything in one line" $ map (testCase []) + + [ linear 3 1 2 > linear 3 1 2 @?= False + , linear 4 1 9 > linear 4 3 6 @?= True + , linear 4 0 6 < linear 4 1 9 @?= False + , linear 4 2 9 < linear 4 1 7 @?= False + , linear 4 1 9 > linear 4 1 9 @?= False + ] + + +groupSorrounded :: TestTree +groupSorrounded = testGroup "Point sorrounded by span" $ map (testCase []) + + [ span 4 9 7 9 > span 5 18 6 100 @?= True + , span 4 9 7 9 > span 5 1 6 1 @?= True + ] + + +groupSameBegin :: TestTree +groupSameBegin = testGroup "Same begin line" $ map (testCase []) + + [ span 4 9 7 9 > span 4 18 6 100 @?= True + , span 4 9 6 9 > span 4 18 7 100 @?= False + ] + +groupSameEnd :: TestTree +groupSameEnd = testGroup "Same end line" $ map (testCase []) + + [ span 4 9 7 9 > span 5 18 7 5 @?= True + , span 1 9 7 9 > span 4 18 7 10 @?= False + ] + +groupEx :: TestTree +groupEx = testGroup "Extreme cases" + + [ testCase "equal position" $ span 1 9 7 9 > span 1 9 7 9 @?= False + , testCase "same end" $ span 1 1 7 9 > span 1 2 7 9 @?= True + , testCase "same begin" $ span 1 9 7 9 > span 1 9 7 3 @?= True + ] + +smartConstructors :: TestTree +smartConstructors = testGroup "Smart constructors" + [ testCase "span works" $ span 1 2 3 4 @=? SrcSpan (SrcPos 1 2) (SrcPos 3 4) + , testCase "span throws exception if begin line > end line" $ + assertException (SrcLocException $ spanUnsafe 2 1 1 1) (span 2 1 1 1) + , testCase "span throws exception if begin line equals end line and begin column > end column" $ + assertException (SrcLocException $ spanUnsafe 1 5 1 3) (span 1 5 1 3) + , testCase "position works" $ position 3 4 @=? span 3 4 3 4 + , testCase "linear works" $ linear 1 2 5 @=? span 1 2 1 5 + , testCase "linear throws exception if begin row > end row" $ + assertException (SrcLocException $ spanUnsafe 1 3 1 1) (linear 1 3 1) + ] + + -- * Util functions + +-- |unsafe variant of 'span' +spanUnsafe :: Int -> Int -> Int -> Int -> SrcSpan +spanUnsafe bl bc el ec = SrcSpan (SrcPos bl bc) (SrcPos el ec) + +-- |expects the exception @e@ to occur whhen trying to evaluate @t@ +assertException :: (Show a,Show e,Exception e,Eq e) => e -> a -> Assertion +assertException e t = + let failure x = assertFailure $ "Expected exception ["++show e++"] but got "++show x + in do + result <- try (evaluate t) + case result of + Left exception -> unless (e == exception) $ failure exception + Right t -> failure t