new function named manual to ease haskell core support

Author: pascalh

CHANGES

@@ -1,11 +1,15 @@
 // release history with features and fixed and open bugs
 
+new features implemented in master branch but not part of the latest release
+* new language: haskell core (write 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

src/core/Language/Astview/DataTree.hs

@@ -8,6 +8,7 @@ module Language.Astview.DataTree
   ,dataToAst
   ,dataToAstSimpl
   ,removeSubtrees
+  ,manual
   ) where
 
 import Data.Generics (Data
@@ -20,10 +21,30 @@ import Data.Tree (Tree(..))
 import Data.Maybe(isNothing,isJust)
 import Language.Astview.Language
 
-dataToAst :: (Data t) => (forall span.Data span => span -> Maybe SrcSpan)
-                       ->  (forall st . Typeable st => st -> Bool)
-                        -> t -> Ast
-dataToAst getSrcLoc pIgnore = Ast . annotateWithPaths . delegateSrcLoc . removeSubtrees isEmpty . removeNothings . worker where
+-- |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,Typeable t) => t -> Tree (Maybe AstNode)
   worker term | pIgnore term = Node Nothing []
@@ -44,9 +65,10 @@ dataToAst getSrcLoc pIgnore = Ast . annotateWithPaths . delegateSrcLoc . removeS
 -- 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,Typeable t,Typeable b,Data b)
-       => (forall a . (Data a,Typeable a)  => a -> Maybe SrcSpan)
-       -> b        -> t -> Ast
+dataToAstIgnoreByExample :: (Data t,Typeable t,Typeable ig,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
 
@@ -57,7 +79,9 @@ dataToAstSimpl = dataToAst (const Nothing) (const False)
 
 -- * helper functions
 
--- |every node will be annotated with its path.
+-- |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

src/core/Language/Astview/Languages/HaskellCore.hs

@@ -1,19 +1,24 @@
 module Language.Astview.Languages.HaskellCore (haskellCore) where
 import Prelude hiding (span)
-import Data.Generics (Data,extQ)
+
+import Data.Tree(Tree(Node))
+import Data.Generics (Data,Typeable,extQ,ext1Q,gmapQ,showConstr,toConstr,typeOf)
 import Data.Generics.Zipper(toZipper,down',query)
 
 import Language.Astview.Language hiding (parse)
-import Language.Astview.DataTree (dataToAstIgnoreByExample)
+import Language.Astview.DataTree (manual)
 
 import Parser
 import Lexer hiding (getDynFlags, getSrcLoc, buffer)
 import qualified DynFlags as GHC
 import Outputable
-import qualified SrcLoc
 import FastString
 import StringBuffer
 import qualified GHC
+import qualified SrcLoc as GHC
+import qualified Outputable as GHC
+import qualified RdrName as GHC
+import qualified OccName as GHC
 
 import GHC.Paths (libdir)
 
@@ -25,34 +30,33 @@ haskellCore = Language "HaskellCore" "Haskell" [".hs"] parsehs
 parsehs :: String -> Either Error Ast
 parsehs s =
   case runParser s parseModule of
-    POk _ parsed -> Right (dataToAstIgnoreByExample getSrcLoc (undefined :: SrcSpan) parsed)
+    POk _ parsed -> Right (coreToAst parsed)
     PFailed ss msg -> Left $ makeError ss (showSDocUnsafe msg)
 
-makeError :: SrcLoc.SrcSpan -> String -> Error
+makeError :: GHC.SrcSpan -> String -> Error
 makeError ss s =
   case ss of
-    SrcLoc.RealSrcSpan real -> ErrLocation (ghcss2ss real) s
+    GHC.RealSrcSpan real -> ErrLocation (ghcss2ss real) s
     _ -> ErrMessage s
 
 
-ghcss2ss :: SrcLoc.RealSrcSpan -> SrcSpan
+ghcss2ss :: GHC.RealSrcSpan -> SrcSpan
 ghcss2ss real
-         = let start = SrcLoc.realSrcSpanStart real
-               end   = SrcLoc.realSrcSpanEnd real
-           in span (SrcLoc.srcLocLine start)
-                   (SrcLoc.srcLocCol start)
-                   (SrcLoc.srcLocLine end)
-                   (SrcLoc.srcLocCol end)
+         = let start = GHC.realSrcSpanStart real
+               end   = GHC.realSrcSpanEnd real
+           in span (GHC.srcLocLine start)
+                   (GHC.srcLocCol start)
+                   (GHC.srcLocLine end)
+                   (GHC.srcLocCol end)
 
 runParser :: String -> P a -> ParseResult a
 runParser str parser = unP parser parseState
     where
       filename = "<interactive>"
-      location = SrcLoc.mkRealSrcLoc (mkFastString filename) 1 1
+      location = GHC.mkRealSrcLoc (mkFastString filename) 1 1
       buffer = stringToStringBuffer str
       parseState = mkPState (unsafePerformIO getDynFlags) buffer location
 
-
 getDynFlags :: IO GHC.DynFlags
 getDynFlags =
   GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $
@@ -67,3 +71,51 @@ getSrcLoc t = down' (toZipper t) >>= query (def `extQ` atSpan) where
   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 :: (Typeable t, Data t) => GHC.GenLocated GHC.SrcSpan t -> Tree (Maybe AstNode)
+      atL (GHC.L _ a) = worker a
+
+      gdefault :: (Typeable t,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