packages feed

haskell-tools-prettyprint (empty) → 0.1.2.0

raw patch · 5 files changed

+186/−0 lines, 5 filesdep +basedep +containersdep +ghcsetup-changed

Dependencies added: base, containers, ghc, haskell-tools-ast, haskell-tools-ast-trf, mtl, references, split, structural-traversal

Files

+ LICENSE view
@@ -0,0 +1,29 @@+Haskell-Tools is Copyright (c) Boldizsár Németh, 2016, all rights reserved,
+and is distributed as free software under the following license.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+- Redistributions of source code must retain the above copyright
+notice, this list of conditions, and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions, and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+- The names of the copyright holders may not be used to endorse or
+promote products derived from this software without specific prior
+written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY
+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/Haskell/Tools/PrettyPrint.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE FlexibleInstances
+           , FlexibleContexts
+           , UndecidableInstances
+           , NamedFieldPuns 
+           #-}
+
+-- | Pretty printing the AST
+module Language.Haskell.Tools.PrettyPrint (prettyPrint) where
+
+import SrcLoc
+import FastString
+
+import Language.Haskell.Tools.AST
+import Language.Haskell.Tools.PrettyPrint.RoseTree
+import Language.Haskell.Tools.AnnTrf.SourceTemplate
+
+import Control.Monad.State
+import Control.Reference
+import Data.Maybe
+import Data.List.Split
+import Data.Foldable
+import Data.StructuralTraversal
+import Data.Sequence hiding (null, replicate)
+
+-- | Pretty prints an AST by using source templates stored as node info
+prettyPrint :: (StructuralTraversable node) => node (NodeInfo sema SourceTemplate) -> String
+prettyPrint = toList . printRose . toRoseTree
+
+printRose :: RoseTree (NodeInfo sema SourceTemplate) -> Seq Char      
+printRose rt = evalState (printRose' $ fmap (^. sourceInfo&sourceTemplateElems) rt) (mkRealSrcLoc (fsLit "") 1 1)
+       
+type PPState = State RealSrcLoc
+       
+-- | Pretty prints a rose tree according to the source templates remaining from the original AST
+printRose' :: RoseTree [SourceTemplateElem] -> PPState (Seq Char)
+-- simple implementation could be optimized a bit
+-- warning: the length of the file should not exceed maxbound::Int
+printRose' (RoseTree (TextElem txt : rest) children) 
+  = putString txt >+< printRose' (RoseTree rest children) 
+printRose' (RoseTree (ChildElem : rest) (child : children)) 
+  = printRose' child >+< printRose' (RoseTree rest children) 
+  
+printRose' (RoseTree [ChildListElem {}] []) = return empty
+printRose' (RoseTree [ChildListElem bef aft defSep indented []] children) 
+  = putString bef >+< (if indented then printListWithSepsIndented else printListWithSeps) (repeat defSep) children >+< putString aft
+printRose' (RoseTree [ChildListElem bef aft _ indented seps] children) 
+  = putString bef >+< (if indented then printListWithSepsIndented else printListWithSeps) (seps ++ repeat (last seps)) children >+< putString aft
+      
+printRose' (RoseTree [OptionalChildElem _ _] []) = return empty
+printRose' (RoseTree [OptionalChildElem bef aft] [child]) = putString bef >+< printRose' child >+< putString aft
+printRose' (RoseTree [OptionalChildElem _ _] _) = error "More than one child element in an optional node."
+printRose' (RoseTree [] []) = return empty 
+printRose' r@(RoseTree (ChildElem : rest) []) = error ("More child elem in template than actual children. In: " ++ show r)
+printRose' r@(RoseTree [] children) = error ("Not all children are used to pretty printing. In: " ++ show r) 
+printRose' r = error ("printRose': unexpected input: " ++ show r) 
+    
+putString :: String -> PPState (Seq Char)
+putString s = do modify $ advanceStr s
+                 return (fromList s)
+                  
+advanceStr :: String -> RealSrcLoc -> RealSrcLoc
+advanceStr s loc = foldl advanceSrcLoc loc s
+
+untilReaches :: String -> RealSrcLoc -> RealSrcLoc -> (String, Int)
+untilReaches s start end 
+  = let ls = splitOn "\n" s 
+     in case ls of _:_:_ -> (unlines (init ls) ++) 
+                              `mapFst` untilReaches' (last ls) (advanceSrcLoc start '\n') end 
+                   _ -> (s, srcLocCol start)
+  where
+    untilReaches' [] curr _ = ([], srcLocCol curr)
+    untilReaches' (c:rest) curr until | srcLocCol advancedLoc <= srcLocCol until
+      = (c:) `mapFst` untilReaches' rest advancedLoc until
+      where advancedLoc = advanceSrcLoc curr c
+    untilReaches' _ curr _ = ([], srcLocCol curr)
+    
+mapFst :: (a -> b) -> (a, x) -> (b, x)
+mapFst f (a, x) = (f a, x)
+
+(>+<) :: PPState (Seq Char) -> PPState (Seq Char) -> PPState (Seq Char)
+(>+<) = liftM2 (><)
+    
+printListWithSeps :: [String] -> [RoseTree [SourceTemplateElem]] -> PPState (Seq Char)
+printListWithSeps = printListWithSeps' putString
+
+printListWithSepsIndented :: [String] -> [RoseTree [SourceTemplateElem]] -> PPState (Seq Char)
+printListWithSepsIndented seps children
+  = do base <- get
+       let putCorrectSep s = do curr <- get
+                                let (shortened, currCol) = untilReaches s curr base
+                                putString $ shortened ++ replicate (srcLocCol base - currCol) ' '
+       printListWithSeps' putCorrectSep seps children
+    
+printListWithSeps' :: (String -> PPState (Seq Char)) -> [String] -> [RoseTree [SourceTemplateElem]] -> PPState (Seq Char)
+printListWithSeps' _ _ [] = return empty
+printListWithSeps' putCorrectSep _ [child] = printRose' child
+printListWithSeps' putCorrectSep (sep:seps) (child:children) 
+  = printRose' child >+< putCorrectSep sep >+< printListWithSeps' putCorrectSep seps children
+
+ Language/Haskell/Tools/PrettyPrint/RoseTree.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE NamedFieldPuns
+           , FlexibleContexts 
+           , DeriveFunctor
+           #-}
+-- | A simpler representation of the original AST.
+module Language.Haskell.Tools.PrettyPrint.RoseTree where
+
+import Control.Monad.State
+import Data.StructuralTraversal
+
+-- | A rose tree containing additional node information         
+data RoseTree a = RoseTree { roseInfo :: a 
+                           , roseChildren :: [RoseTree a]
+                           } deriving Functor
+
+instance Show a => Show (RoseTree a) where
+  show = show' 0
+    where show' i RoseTree{roseInfo,roseChildren}
+             = "\n" ++ replicate (2*i) '#'
+                    ++ show roseInfo 
+                    ++ concatMap (show' (i+1)) roseChildren
+                          
+-- | Transforms the heterogeneous AST into a homogeneous representation for pretty printing                   
+toRoseTree :: (StructuralTraversable n) => n inf -> RoseTree inf
+toRoseTree = head . head . tail . flip execState [[],[]] . toSrcRoseSt
+  where toSrcRoseSt = traverseUp desc asc f
+  
+        desc  = modify ([]:)
+        asc   = modify tail
+        f inf = modify (\(y : x : xs) -> [] : (RoseTree inf (reverse y) : x) : xs)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haskell-tools-prettyprint.cabal view
@@ -0,0 +1,26 @@+name:                haskell-tools-prettyprint
+version:             0.1.2.0
+synopsis:            Pretty printing of Haskell-Tools AST
+description:         Converts the Haskell-Tools AST to the original source text. Works using the source annotations that are present in the AST. Creates a rose tree first to simplify the conversion.
+homepage:            https://github.com/haskell-tools/haskell-tools
+license:             BSD3
+license-file:        LICENSE
+author:              Boldizsar Nemeth
+maintainer:          nboldi@elte.hu
+category:            Language
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Language.Haskell.Tools.PrettyPrint
+                     , Language.Haskell.Tools.PrettyPrint.RoseTree
+  build-depends:       base                  >=4.9   && <5.0
+                     , ghc                   >=8.0   && <8.1
+                     , mtl                   >=2.2   && <2.3
+                     , containers            >=0.5   && <0.6
+                     , references            >=0.3.2 && <1.0
+                     , structural-traversal  >=0.1   && <0.2
+                     , haskell-tools-ast     >=0.1   && <1.0
+                     , haskell-tools-ast-trf >=0.1   && <1.0
+                     , split                 >=0.2   && <1.0
+  default-language:    Haskell2010