module HIndent
(
reformat
,prettyPrint
,parseMode
,Style(..)
,styles
,chrisDone
,johanTibell
,fundamental
,gibiansky
,test
,testAll
,testAst
)
where
import HIndent.Pretty
import HIndent.Styles.ChrisDone (chrisDone)
import HIndent.Styles.Fundamental (fundamental)
import HIndent.Styles.Gibiansky (gibiansky)
import HIndent.Styles.JohanTibell (johanTibell)
import HIndent.Types
import Control.Monad.State.Strict
import Data.Data
import Data.Function
import Data.Monoid
import qualified Data.Text.IO as ST
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
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)
reformat :: Style -> Maybe [Extension] -> Text -> Either String Builder
reformat style mexts x =
case parseModuleWithComments (case mexts of
Just exts -> parseMode {extensions = exts}
Nothing -> parseMode)
(T.unpack x) of
ParseOk (m,comments) ->
let (cs,ast) =
annotateComments (fromMaybe m $ applyFixities baseFixities m) comments
in Right (prettyPrint
style
(do mapM_ (printComment Nothing) (reverse cs)
pretty ast))
ParseFailed _ e -> Left e
prettyPrint :: Style -> (forall s. Printer s ()) -> Builder
prettyPrint style m =
case style of
Style _name _author _desc st extenders config ->
psOutput (execState (runPrinter m)
(PrintState 0 mempty False 0 1 st extenders config False False))
parseMode :: ParseMode
parseMode =
defaultParseMode {extensions = allExtensions
,fixities = Nothing}
where allExtensions =
filter isDisabledExtention knownExtensions
isDisabledExtention (DisableExtension _) = False
isDisabledExtention _ = True
test :: Style -> Text -> IO ()
test style =
either error (T.putStrLn . T.toLazyText) .
reformat style Nothing
testAll :: Text -> IO ()
testAll i =
forM_ styles
(\style ->
do ST.putStrLn ("-- " <> styleName style <> ":")
test style i
ST.putStrLn "")
testAst :: Text -> Either String ([ComInfo], Module NodeInfo)
testAst x =
case parseModuleWithComments parseMode
(T.unpack x) of
ParseOk (m,comments) ->
Right (annotateComments m comments)
ParseFailed _ e -> Left e
styles :: [Style]
styles =
[fundamental,chrisDone,johanTibell,gibiansky]
annotateComments :: forall ast. (Data (ast NodeInfo),Traversable ast,Annotated ast)
=> ast SrcSpanInfo -> [Comment] -> ([ComInfo],ast NodeInfo)
annotateComments src comments =
let
reversed = reverse comments
src' = fmap (\n -> NodeInfo n []) src
(cominfos, src'') = foldr processComment ([], src') reversed
in
(cominfos, fmap (\(NodeInfo n cs) -> NodeInfo n $ reverse cs) src'')
where processComment :: Comment
-> ([ComInfo],ast NodeInfo)
-> ([ComInfo],ast NodeInfo)
processComment c@(Comment _ cspan _) (cs,ast) =
case execState (traverse (collect After c) ast) Nothing of
Nothing -> (ComInfo c Nothing : cs, ast)
Just (NodeInfo l coms)
| ownLine && alignedWithPrevious -> insertedBefore
| ownLine ->
case execState (traverse (collect Before c) ast) Nothing of
Nothing -> insertedBefore
Just (NodeInfo node _) ->
(cs, evalState (traverse (insert node (ComInfo c $ Just Before)) ast) False)
| 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
ComInfo (Comment False prevSpan _) (Just After) ->
srcSpanStartLine prevSpan == srcSpanStartLine cspan 1 &&
srcSpanStartColumn prevSpan == srcSpanStartColumn cspan
_ -> False
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 :: 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
commentLocated :: ComInfoLocation -> NodeInfo -> Comment -> Bool
commentLocated loc' (NodeInfo (SrcSpanInfo n _) _) (Comment _ c _) =
spanTest loc' n c
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)