diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 4.3.10 +version: 4.3.11 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -30,6 +30,7 @@ exposed-modules: HIndent HIndent.Types HIndent.Pretty + HIndent.Comments HIndent.Styles.Fundamental HIndent.Styles.ChrisDone HIndent.Styles.JohanTibell diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -22,8 +22,7 @@ ) where -import Control.Monad.Trans.Maybe -import Data.Functor.Identity +import HIndent.Comments import HIndent.Pretty import HIndent.Styles.ChrisDone (chrisDone) import HIndent.Styles.Fundamental (fundamental) @@ -32,8 +31,9 @@ import HIndent.Types import Control.Monad.State.Strict -import Data.Data -import Data.Function +import Control.Monad.Trans.Maybe +import Data.Functor.Identity +import Data.Maybe (fromMaybe) import Data.Monoid import qualified Data.Text.IO as ST import Data.Text.Lazy (Text) @@ -41,21 +41,18 @@ import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as T import qualified Data.Text.Lazy.IO as T -import Data.Traversable import Language.Haskell.Exts.Annotated hiding (Style,prettyPrint,Pretty,style,parse) -import Data.Maybe (fromMaybe) -- | Format the given source. reformat :: Style -> Maybe [Extension] -> Text -> Either String Builder reformat style mexts x = - case parseModuleWithComments (case mexts of - Just exts -> parseMode {extensions = exts} - Nothing -> parseMode) + case parseModuleWithComments mode (T.unpack x) of ParseOk (m,comments) -> let (cs,ast) = annotateComments (fromMaybe m $ applyFixities baseFixities m) comments in Right (prettyPrint + mode style -- For the time being, assume that all "free-floating" comments come at the beginning. -- If they were not at the beginning, they would be after some ast node. @@ -63,17 +60,20 @@ (do mapM_ (printComment Nothing) (reverse cs) pretty ast)) ParseFailed _ e -> Left e + where mode = (case mexts of + Just exts -> parseMode {extensions = exts} + Nothing -> parseMode) -- | Pretty print the given printable thing. -prettyPrint :: Style -> (forall s. Printer s ()) -> Builder -prettyPrint style m = +prettyPrint :: ParseMode -> Style -> (forall s. Printer s ()) -> Builder +prettyPrint mode style m = case style of Style _name _author _desc st extenders config -> maybe (error "Printer failed with mzero call.") psOutput (runIdentity (runMaybeT (execStateT (runPrinter m) - (PrintState 0 mempty False 0 1 st extenders config False False)))) + (PrintState 0 mempty False 0 1 st extenders config False False mode)))) -- | Parse mode, includes all extensions, doesn't assume any fixities. parseMode :: ParseMode @@ -113,100 +113,3 @@ styles :: [Style] styles = [fundamental,chrisDone,johanTibell,gibiansky] - --- | Annotate the AST with comments. -annotateComments :: forall ast. (Data (ast NodeInfo),Traversable ast,Annotated ast) - => ast SrcSpanInfo -> [Comment] -> ([ComInfo],ast NodeInfo) -annotateComments src comments = - let - -- Make sure to process comments top to bottom. - reversed = reverse comments - - -- Replace source spans with node infos in the AST. - src' = fmap (\n -> NodeInfo n []) src - - -- Add all comments to the ast. - (cominfos, src'') = foldr processComment ([], src') reversed - - in -- Reverse order of comments at each node. - (cominfos, fmap (\(NodeInfo n cs) -> NodeInfo n $ reverse cs) src'') - - where processComment :: Comment - -> ([ComInfo],ast NodeInfo) - -> ([ComInfo],ast NodeInfo) - -- Add in a single comment to the ast. - processComment c@(Comment _ cspan _) (cs,ast) = - -- Try to find the node after which this comment lies. - case execState (traverse (collect After c) ast) Nothing of - -- When no node is found, the comment is on its own line. - Nothing -> (ComInfo c Nothing : cs, ast) - - -- We found the node that this comment follows. - -- Check whether the node is on the same line. - Just (NodeInfo l coms) - -- If it's on a different line than the node, but the node has an - -- EOL comment, and the EOL comment and this comment are aligned, - -- attach this comment to the preceding node. - | ownLine && alignedWithPrevious -> insertedBefore - - -- If it's on a different line than the node, look for the following node to attach it to. - | ownLine -> - case execState (traverse (collect Before c) ast) Nothing of - -- If we don't find a node after the comment, leave it with the previous node. - Nothing -> insertedBefore - Just (NodeInfo node _) -> - (cs, evalState (traverse (insert node (ComInfo c $ Just Before)) ast) False) - - -- If it's on the same line, insert this comment into that node. - | otherwise -> insertedBefore - where - ownLine = srcSpanStartLine cspan /= srcSpanEndLine (srcInfoSpan l) - insertedBefore = (cs, evalState (traverse (insert l (ComInfo c $ Just After)) ast) False) - alignedWithPrevious - | null coms = False - | otherwise = case last coms of - -- Require single line comment after the node. - ComInfo (Comment False prevSpan _) (Just After) -> - srcSpanStartLine prevSpan == srcSpanStartLine cspan - 1 && - srcSpanStartColumn prevSpan == srcSpanStartColumn cspan - _ -> False - - -- For a comment, check whether the comment is after the node. - -- If it is, store it in the state; otherwise do nothing. - -- The location specifies where the comment should lie relative to the node. - collect :: ComInfoLocation -> Comment -> NodeInfo -> State (Maybe NodeInfo) NodeInfo - collect loc' c ni@(NodeInfo newL _) = - do when (commentLocated loc' ni c) - (modify (maybe (Just ni) - (\oldni@(NodeInfo oldL _) -> - Just (if (spanTest loc' `on` srcInfoSpan) oldL newL - then ni - else oldni)))) - return ni - - -- Insert the comment into the ast. Find the right node and add it to the - -- comments of that node. Do nothing afterwards. - insert :: SrcSpanInfo -> ComInfo -> NodeInfo -> State Bool NodeInfo - insert al c ni@(NodeInfo bl cs) = - do done <- get - if not done && al == bl - then do put True - return (ni {nodeInfoComments = c : cs}) - else return ni - --- | Is the comment after the node? -commentLocated :: ComInfoLocation -> NodeInfo -> Comment -> Bool -commentLocated loc' (NodeInfo (SrcSpanInfo n _) _) (Comment _ c _) = - spanTest loc' n c - --- | For @After@, does the first span end before the second starts? --- For @Before@, does the first span start after the second ends? -spanTest :: ComInfoLocation -> SrcSpan -> SrcSpan -> Bool -spanTest loc' first second = - (srcSpanStartLine after > srcSpanEndLine before) || - ((srcSpanStartLine after == srcSpanEndLine before) && - (srcSpanStartColumn after > srcSpanEndColumn before)) - where (before,after) = - case loc' of - After -> (first,second) - Before -> (second,first) diff --git a/src/HIndent/Comments.hs b/src/HIndent/Comments.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Comments.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables #-} + +-- | Comment handling. + +module HIndent.Comments where + +import Control.Monad.State.Strict +import Data.Data +import Data.Function +import Data.Traversable +import HIndent.Types +import Language.Haskell.Exts.Annotated hiding (Style,prettyPrint,Pretty,style,parse) + +-- | Annotate the AST with comments. +annotateComments :: forall ast. (Data (ast NodeInfo),Traversable ast,Annotated ast) + => ast SrcSpanInfo -> [Comment] -> ([ComInfo],ast NodeInfo) +annotateComments src comments = + let + -- Make sure to process comments top to bottom. + reversed = reverse comments + + -- Replace source spans with node infos in the AST. + src' = fmap (\n -> NodeInfo n []) src + + -- Add all comments to the ast. + (cominfos, src'') = foldr processComment ([], src') reversed + + in -- Reverse order of comments at each node. + (cominfos, fmap (\(NodeInfo n cs) -> NodeInfo n $ reverse cs) src'') + + where processComment :: Comment + -> ([ComInfo],ast NodeInfo) + -> ([ComInfo],ast NodeInfo) + -- Add in a single comment to the ast. + processComment c@(Comment _ cspan _) (cs,ast) = + -- Try to find the node after which this comment lies. + case execState (traverse (collect After c) ast) Nothing of + -- When no node is found, the comment is on its own line. + Nothing -> (ComInfo c Nothing : cs, ast) + + -- We found the node that this comment follows. + -- Check whether the node is on the same line. + Just (NodeInfo l coms) + -- If it's on a different line than the node, but the node has an + -- EOL comment, and the EOL comment and this comment are aligned, + -- attach this comment to the preceding node. + | ownLine && alignedWithPrevious -> insertedBefore + + -- If it's on a different line than the node, look for the following node to attach it to. + | ownLine -> + case execState (traverse (collect Before c) ast) Nothing of + -- If we don't find a node after the comment, leave it with the previous node. + Nothing -> insertedBefore + Just (NodeInfo node _) -> + (cs, evalState (traverse (insert node (ComInfo c $ Just Before)) ast) False) + + -- If it's on the same line, insert this comment into that node. + | otherwise -> insertedBefore + where + ownLine = srcSpanStartLine cspan /= srcSpanEndLine (srcInfoSpan l) + insertedBefore = (cs, evalState (traverse (insert l (ComInfo c $ Just After)) ast) False) + alignedWithPrevious + | null coms = False + | otherwise = case last coms of + -- Require single line comment after the node. + ComInfo (Comment False prevSpan _) (Just After) -> + srcSpanStartLine prevSpan == srcSpanStartLine cspan - 1 && + srcSpanStartColumn prevSpan == srcSpanStartColumn cspan + _ -> False + + -- For a comment, check whether the comment is after the node. + -- If it is, store it in the state; otherwise do nothing. + -- The location specifies where the comment should lie relative to the node. + collect :: ComInfoLocation -> Comment -> NodeInfo -> State (Maybe NodeInfo) NodeInfo + collect loc' c ni@(NodeInfo newL _) = + do when (commentLocated loc' ni c) + (modify (maybe (Just ni) + (\oldni@(NodeInfo oldL _) -> + Just (if (spanTest loc' `on` srcInfoSpan) oldL newL + then ni + else oldni)))) + return ni + + -- Insert the comment into the ast. Find the right node and add it to the + -- comments of that node. Do nothing afterwards. + insert :: SrcSpanInfo -> ComInfo -> NodeInfo -> State Bool NodeInfo + insert al c ni@(NodeInfo bl cs) = + do done <- get + if not done && al == bl + then do put True + return (ni {nodeInfoComments = c : cs}) + else return ni + +-- | Is the comment after the node? +commentLocated :: ComInfoLocation -> NodeInfo -> Comment -> Bool +commentLocated loc' (NodeInfo (SrcSpanInfo n _) _) (Comment _ c _) = + spanTest loc' n c + +-- | For @After@, does the first span end before the second starts? +-- For @Before@, does the first span start after the second ends? +spanTest :: ComInfoLocation -> SrcSpan -> SrcSpan -> Bool +spanTest loc' first second = + (srcSpanStartLine after > srcSpanEndLine before) || + ((srcSpanStartLine after == srcSpanEndLine before) && + (srcSpanStartColumn after > srcSpanEndColumn before)) + where (before,after) = + case loc' of + After -> (first,second) + Before -> (second,first) diff --git a/src/HIndent/Styles/ChrisDone.hs b/src/HIndent/Styles/ChrisDone.hs --- a/src/HIndent/Styles/ChrisDone.hs +++ b/src/HIndent/Styles/ChrisDone.hs @@ -8,13 +8,18 @@ module HIndent.Styles.ChrisDone where import HIndent.Pretty +import HIndent.Comments import HIndent.Types import Control.Monad import Control.Monad.Loops import Control.Monad.State.Class import Data.Int +import Data.Maybe +import Language.Haskell.Exts.Annotated (parseExpWithComments) +import Language.Haskell.Exts.Annotated.Fixity import Language.Haskell.Exts.Annotated.Syntax +import Language.Haskell.Exts.Parser (ParseResult(..)) import Prelude hiding (exp) -------------------------------------------------------------------------------- @@ -204,6 +209,17 @@ -- | Expressions exp :: Exp NodeInfo -> Printer t () +exp e@(QuasiQuote _ "i" s) = + do parseMode <- gets psParseMode + case parseExpWithComments parseMode s of + ParseOk (e',comments) -> + do depend (do write "[" + string "i" + write "|") + (do exp (snd (annotateComments (fromMaybe e' (applyFixities baseFixities e')) + comments)) + write "|]") + _ -> prettyNoExt e -- Infix applications will render on one line if possible, otherwise -- if any of the arguments are not "flat" then that expression is -- line-separated. diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -29,6 +29,7 @@ import Data.Text (Text) import Data.Text.Lazy.Builder (Builder) import Language.Haskell.Exts.Comments +import Language.Haskell.Exts.Parser import Language.Haskell.Exts.SrcLoc -- | A pretty printing monad. @@ -48,10 +49,11 @@ ,psConfig :: !Config -- ^ Config which styles may or may not pay attention to. ,psEolComment :: !Bool -- ^ An end of line comment has just been outputted. ,psInsideCase :: !Bool -- ^ Whether we're in a case statement, used for Rhs printing. + ,psParseMode :: !ParseMode -- ^ Mode used to parse the original AST. } instance Eq (PrintState s) where - PrintState ilevel out newline col line _ _ _ eolc inc == PrintState ilevel' out' newline' col' line' _ _ _ eolc' inc' = + PrintState ilevel out newline col line _ _ _ eolc inc pm == PrintState ilevel' out' newline' col' line' _ _ _ eolc' inc' pm' = (ilevel,out,newline,col,line,eolc, inc) == (ilevel',out',newline',col',line',eolc', inc') -- | A printer extender. Takes as argument the user state that the diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -109,5 +109,5 @@ ,TransformListComp -- steals the group keyword ,XmlSyntax, RegularPatterns -- steals a-b ,UnboxedTuples -- breaks (#) lens operator - ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break + -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break ]