diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Haskell-Tools is Copyright (c) Boldizsár Németh, 2016, all rights reserved, +and is distributed as free software under the following license. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +- Redistributions of source code must retain the above copyright +notice, this list of conditions, and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions, and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- The names of the copyright holders may not be used to endorse or +promote products derived from this software without specific prior +written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/Haskell/Tools/PrettyPrint.hs b/Language/Haskell/Tools/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/PrettyPrint.hs @@ -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 + diff --git a/Language/Haskell/Tools/PrettyPrint/RoseTree.hs b/Language/Haskell/Tools/PrettyPrint/RoseTree.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Tools/PrettyPrint/RoseTree.hs @@ -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) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haskell-tools-prettyprint.cabal b/haskell-tools-prettyprint.cabal new file mode 100644 --- /dev/null +++ b/haskell-tools-prettyprint.cabal @@ -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