782 lines
28 KiB
Haskell
782 lines
28 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Language.Haskell.Brittany.Internal.LayouterBasics where
|
|
|
|
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
|
|
import qualified Control.Monad.Writer.Strict as Writer
|
|
import qualified Data.Char as Char
|
|
import Data.Data
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Semigroup as Semigroup
|
|
import qualified Data.Sequence as Seq
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy.Builder as Text.Builder
|
|
import DataTreePrint
|
|
import GHC (GenLocated(L), Located, moduleName, moduleNameString)
|
|
import qualified GHC.OldList as List
|
|
import GHC.Parser.Annotation (AnnKeywordId(..))
|
|
import GHC.Types.Name (getOccString)
|
|
import GHC.Types.Name.Occurrence (occNameString)
|
|
import GHC.Types.Name.Reader (RdrName(..))
|
|
import qualified GHC.Types.SrcLoc as GHC
|
|
import Language.Haskell.Brittany.Internal.Config.Types
|
|
import Language.Haskell.Brittany.Internal.ExactPrintUtils
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
import Language.Haskell.Brittany.Internal.PreludeUtils
|
|
import Language.Haskell.Brittany.Internal.Types
|
|
import Language.Haskell.Brittany.Internal.Utils
|
|
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
|
|
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
|
|
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
|
|
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
|
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
|
|
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
|
|
|
|
|
|
|
|
processDefault
|
|
:: ( ExactPrint.Annotate.Annotate ast
|
|
, MonadMultiWriter Text.Builder.Builder m
|
|
, MonadMultiReader ExactPrint.Types.Anns m
|
|
)
|
|
=> Located ast
|
|
-> m ()
|
|
processDefault x = do
|
|
anns <- mAsk
|
|
let str = ExactPrint.exactPrint x anns
|
|
-- this hack is here so our print-empty-module trick does not add
|
|
-- a newline at the start if there actually is no module header / imports
|
|
-- / anything.
|
|
-- TODO: instead the appropriate annotation could be removed when "cleaning"
|
|
-- the module (header). This would remove the need for this hack!
|
|
case str of
|
|
"\n" -> return ()
|
|
_ -> mTell $ Text.Builder.fromString str
|
|
|
|
-- | Use ExactPrint's output for this node; add a newly generated inline comment
|
|
-- at insertion position (meant to point out to the user that this node is
|
|
-- not handled by brittany yet). Useful when starting implementing new
|
|
-- syntactic constructs when children are not handled yet.
|
|
briDocByExact
|
|
:: (ExactPrint.Annotate.Annotate ast)
|
|
=> Located ast
|
|
-> ToBriDocM BriDocNumbered
|
|
briDocByExact ast = do
|
|
anns <- mAsk
|
|
traceIfDumpConf "ast"
|
|
_dconf_dump_ast_unknown
|
|
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
|
docExt ast anns True
|
|
|
|
-- | Use ExactPrint's output for this node.
|
|
-- Consider that for multi-line input, the indentation of the code produced
|
|
-- by ExactPrint might be different, and even incompatible with the indentation
|
|
-- of its surroundings as layouted by brittany. But there are safe uses of
|
|
-- this, e.g. for any top-level declarations.
|
|
briDocByExactNoComment
|
|
:: (ExactPrint.Annotate.Annotate ast)
|
|
=> Located ast
|
|
-> ToBriDocM BriDocNumbered
|
|
briDocByExactNoComment ast = do
|
|
anns <- mAsk
|
|
traceIfDumpConf "ast"
|
|
_dconf_dump_ast_unknown
|
|
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
|
docExt ast anns False
|
|
|
|
-- | Use ExactPrint's output for this node, presuming that this output does
|
|
-- not contain any newlines. If this property is not met, the semantics
|
|
-- depend on the @econf_AllowRiskyExactPrintUse@ config flag.
|
|
briDocByExactInlineOnly
|
|
:: (ExactPrint.Annotate.Annotate ast)
|
|
=> String
|
|
-> Located ast
|
|
-> ToBriDocM BriDocNumbered
|
|
briDocByExactInlineOnly infoStr ast = do
|
|
anns <- mAsk
|
|
traceIfDumpConf "ast"
|
|
_dconf_dump_ast_unknown
|
|
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
|
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
|
|
fallbackMode <-
|
|
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
|
|
let exactPrintNode t = allocateNode $ BDFExternal
|
|
(ExactPrint.Types.mkAnnKey ast)
|
|
(foldedAnnKeys ast)
|
|
False
|
|
t
|
|
let errorAction = do
|
|
mTell [ErrorUnknownNode infoStr ast]
|
|
docLit
|
|
$ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
|
|
case (fallbackMode, Text.lines exactPrinted) of
|
|
(ExactPrintFallbackModeNever, _ ) -> errorAction
|
|
(_ , [t]) -> exactPrintNode
|
|
(Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)
|
|
(ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted
|
|
_ -> errorAction
|
|
|
|
rdrNameToText :: RdrName -> Text
|
|
-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr
|
|
rdrNameToText (Unqual occname) = Text.pack $ occNameString occname
|
|
rdrNameToText (Qual mname occname) =
|
|
Text.pack $ moduleNameString mname ++ "." ++ occNameString occname
|
|
rdrNameToText (Orig modul occname) =
|
|
Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname
|
|
rdrNameToText (Exact name) = Text.pack $ getOccString name
|
|
|
|
lrdrNameToText :: GenLocated l RdrName -> Text
|
|
lrdrNameToText (L _ n) = rdrNameToText n
|
|
|
|
lrdrNameToTextAnnGen
|
|
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
|
|
=> (Text -> Text)
|
|
-> Located RdrName
|
|
-> m Text
|
|
lrdrNameToTextAnnGen f ast@(L _ n) = do
|
|
anns <- mAsk
|
|
let t = f $ rdrNameToText n
|
|
let hasUni x (ExactPrint.Types.G y, _) = x == y
|
|
hasUni _ _ = False
|
|
-- TODO: in general: we should _always_ process all annotaiton stuff here.
|
|
-- whatever we don't probably should have had some effect on the
|
|
-- output. in such cases, resorting to byExact is probably the safe
|
|
-- choice.
|
|
return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
|
|
Nothing -> t
|
|
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
|
|
Exact{} | t == Text.pack "()" -> t
|
|
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
|
|
_ | any (hasUni AnnCommaTuple) aks -> t
|
|
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
|
|
_ | otherwise -> t
|
|
|
|
lrdrNameToTextAnn
|
|
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
|
|
=> Located RdrName
|
|
-> m Text
|
|
lrdrNameToTextAnn = lrdrNameToTextAnnGen id
|
|
|
|
lrdrNameToTextAnnTypeEqualityIsSpecial
|
|
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
|
|
=> Located RdrName
|
|
-> m Text
|
|
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
|
|
let f x = if x == Text.pack "Data.Type.Equality~"
|
|
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
|
|
else x
|
|
lrdrNameToTextAnnGen f ast
|
|
|
|
-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects
|
|
-- the annotations for a (parent) node for a tick to be added to the
|
|
-- literal.
|
|
-- Excessively long name to reflect on us having to work around such
|
|
-- excessively obscure special cases in the exactprint API.
|
|
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
|
|
:: ( Data ast
|
|
, MonadMultiReader Config m
|
|
, MonadMultiReader (Map AnnKey Annotation) m
|
|
)
|
|
=> Located ast
|
|
-> Located RdrName
|
|
-> m Text
|
|
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
|
|
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
|
|
x <- lrdrNameToTextAnn ast2
|
|
let lit = if x == Text.pack "Data.Type.Equality~"
|
|
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
|
|
else x
|
|
return $ if hasQuote then Text.cons '\'' lit else lit
|
|
|
|
askIndent :: (MonadMultiReader Config m) => m Int
|
|
askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
|
|
|
|
|
|
extractAllComments
|
|
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
|
|
extractAllComments ann =
|
|
ExactPrint.annPriorComments ann ++ extractRestComments ann
|
|
|
|
extractRestComments
|
|
:: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]
|
|
extractRestComments ann =
|
|
ExactPrint.annFollowingComments ann
|
|
++ (ExactPrint.annsDP ann >>= \case
|
|
(ExactPrint.AnnComment com, dp) -> [(com, dp)]
|
|
_ -> []
|
|
)
|
|
|
|
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
|
|
filterAnns ast =
|
|
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
|
|
|
|
-- | True if there are any comments that are
|
|
-- a) connected to any node below (in AST sense) the given node AND
|
|
-- b) after (in source code order) the node.
|
|
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
|
hasAnyCommentsBelow ast@(L l _) =
|
|
List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)
|
|
<$> astConnectedComments ast
|
|
|
|
hasCommentsBetween
|
|
:: Data ast
|
|
=> GHC.Located ast
|
|
-> AnnKeywordId
|
|
-> AnnKeywordId
|
|
-> ToBriDocM Bool
|
|
hasCommentsBetween ast leftKey rightKey = do
|
|
mAnn <- astAnn ast
|
|
let go1 [] = False
|
|
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
|
|
go1 (_ : rest) = go1 rest
|
|
go2 [] = False
|
|
go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
|
|
go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
|
|
go2 (_ : rest) = go2 rest
|
|
case mAnn of
|
|
Nothing -> pure False
|
|
Just ann -> pure $ go1 $ ExactPrint.annsDP ann
|
|
|
|
-- | True if there are any comments that are connected to any node below (in AST
|
|
-- sense) the given node
|
|
hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
|
hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
|
|
|
|
-- | True if there are any regular comments connected to any node below (in AST
|
|
-- sense) the given node
|
|
hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
|
hasAnyRegularCommentsConnected ast =
|
|
any isRegularComment <$> astConnectedComments ast
|
|
|
|
-- | Regular comments are comments that are actually "source code comments",
|
|
-- i.e. things that start with "--" or "{-". In contrast to comment-annotations
|
|
-- used by ghc-exactprint for capturing symbols (and their exact positioning).
|
|
--
|
|
-- Only the type instance layouter makes use of this filter currently, but
|
|
-- it might make sense to apply it more aggressively or make it the default -
|
|
-- I believe that most of the time we branch on the existence of comments, we
|
|
-- only care about "regular" comments. We simply did not need the distinction
|
|
-- because "irregular" comments are not that common outside of type/data decls.
|
|
isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool
|
|
isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst
|
|
|
|
astConnectedComments
|
|
:: Data ast
|
|
=> GHC.Located ast
|
|
-> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)]
|
|
astConnectedComments ast = do
|
|
anns <- filterAnns ast <$> mAsk
|
|
pure $ extractAllComments =<< Map.elems anns
|
|
|
|
hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
|
hasAnyCommentsPrior ast = astAnn ast <&> \case
|
|
Nothing -> False
|
|
Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors
|
|
|
|
hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
|
hasAnyRegularCommentsRest ast = astAnn ast <&> \case
|
|
Nothing -> False
|
|
Just ann -> any isRegularComment (extractRestComments ann)
|
|
|
|
hasAnnKeywordComment
|
|
:: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
|
|
hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
|
|
Nothing -> False
|
|
Just ann -> any hasK (extractAllComments ann)
|
|
where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
|
|
|
|
hasAnnKeyword
|
|
:: (Data a, MonadMultiReader (Map AnnKey Annotation) m)
|
|
=> Located a
|
|
-> AnnKeywordId
|
|
-> m Bool
|
|
hasAnnKeyword ast annKeyword = astAnn ast <&> \case
|
|
Nothing -> False
|
|
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
|
|
where
|
|
hasK (ExactPrint.Types.G x, _) = x == annKeyword
|
|
hasK _ = False
|
|
|
|
astAnn
|
|
:: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
|
|
=> GHC.Located ast
|
|
-> m (Maybe Annotation)
|
|
astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk
|
|
|
|
-- new BriDoc stuff
|
|
|
|
allocateNode
|
|
:: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered
|
|
allocateNode bd = do
|
|
i <- allocNodeIndex
|
|
return (i, bd)
|
|
|
|
allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int
|
|
allocNodeIndex = do
|
|
NodeAllocIndex i <- mGet
|
|
mSet $ NodeAllocIndex (i + 1)
|
|
return i
|
|
|
|
-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
|
|
-- docEmpty = allocateNode BDFEmpty
|
|
--
|
|
-- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered
|
|
-- docLit t = allocateNode $ BDFLit t
|
|
--
|
|
-- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m)
|
|
-- => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered
|
|
-- docExt x anns shouldAddComment = allocateNode $ BDFExternal
|
|
-- (ExactPrint.Types.mkAnnKey x)
|
|
-- (foldedAnnKeys x)
|
|
-- shouldAddComment
|
|
-- (Text.pack $ ExactPrint.exactPrint x anns)
|
|
--
|
|
-- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered
|
|
-- docAlt l = allocateNode . BDFAlt =<< sequence l
|
|
--
|
|
--
|
|
-- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered
|
|
-- docSeq l = allocateNode . BDFSeq =<< sequence l
|
|
--
|
|
-- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered
|
|
-- docLines l = allocateNode . BDFLines =<< sequence l
|
|
--
|
|
-- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered
|
|
-- docCols sig l = allocateNode . BDFCols sig =<< sequence l
|
|
--
|
|
-- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered
|
|
-- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
|
|
--
|
|
-- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
|
|
-- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm
|
|
--
|
|
-- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
|
|
-- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm
|
|
--
|
|
-- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
|
|
-- docSeparator = allocateNode BDFSeparator
|
|
--
|
|
-- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered
|
|
-- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
|
|
--
|
|
-- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered
|
|
-- docAnnotationPost annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm
|
|
--
|
|
-- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
|
|
-- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm
|
|
--
|
|
-- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
|
|
-- appSep x = docSeq [x, docSeparator]
|
|
--
|
|
-- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
|
|
-- docCommaSep = appSep $ docLit $ Text.pack ","
|
|
--
|
|
-- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
|
|
-- docParenLSep = appSep $ docLit $ Text.pack "("
|
|
--
|
|
--
|
|
-- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m)
|
|
-- => Located ast
|
|
-- -> m BriDocNumbered
|
|
-- -> m BriDocNumbered
|
|
-- docPostComment ast bdm = do
|
|
-- bd <- bdm
|
|
-- allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd
|
|
--
|
|
-- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m)
|
|
-- => Located ast
|
|
-- -> m BriDocNumbered
|
|
-- -> m BriDocNumbered
|
|
-- docWrapNode ast bdm = do
|
|
-- bd <- bdm
|
|
-- i1 <- allocNodeIndex
|
|
-- i2 <- allocNodeIndex
|
|
-- return
|
|
-- $ (,) i1
|
|
-- $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
|
|
-- $ (,) i2
|
|
-- $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)
|
|
-- $ bd
|
|
--
|
|
-- docPar :: MonadMultiState NodeAllocIndex m
|
|
-- => m BriDocNumbered
|
|
-- -> m BriDocNumbered
|
|
-- -> m BriDocNumbered
|
|
-- docPar lineM indentedM = do
|
|
-- line <- lineM
|
|
-- indented <- indentedM
|
|
-- allocateNode $ BDFPar BrIndentNone line indented
|
|
--
|
|
-- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
|
|
-- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
|
|
--
|
|
-- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered
|
|
-- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
|
|
--
|
|
-- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered
|
|
-- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
|
|
|
|
docEmpty :: ToBriDocM BriDocNumbered
|
|
docEmpty = allocateNode BDFEmpty
|
|
|
|
docLit :: Text -> ToBriDocM BriDocNumbered
|
|
docLit t = allocateNode $ BDFLit t
|
|
|
|
docLitS :: String -> ToBriDocM BriDocNumbered
|
|
docLitS s = allocateNode $ BDFLit $ Text.pack s
|
|
|
|
docExt
|
|
:: (ExactPrint.Annotate.Annotate ast)
|
|
=> Located ast
|
|
-> ExactPrint.Types.Anns
|
|
-> Bool
|
|
-> ToBriDocM BriDocNumbered
|
|
docExt x anns shouldAddComment = allocateNode $ BDFExternal
|
|
(ExactPrint.Types.mkAnnKey x)
|
|
(foldedAnnKeys x)
|
|
shouldAddComment
|
|
(Text.pack $ ExactPrint.exactPrint x anns)
|
|
|
|
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
|
docAlt l = allocateNode . BDFAlt =<< sequence l
|
|
|
|
newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
|
|
deriving (Functor, Applicative, Monad)
|
|
|
|
addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
|
|
addAlternativeCond cond doc =
|
|
when cond (addAlternative doc)
|
|
|
|
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
|
|
addAlternative =
|
|
CollectAltM . Writer.tell . (: [])
|
|
|
|
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
|
|
runFilteredAlternative (CollectAltM action) =
|
|
docAlt $ Writer.execWriter action
|
|
|
|
|
|
docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
|
docSeq [] = docEmpty
|
|
docSeq l = allocateNode . BDFSeq =<< sequence l
|
|
|
|
docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
|
docLines l = allocateNode . BDFLines =<< sequence l
|
|
|
|
docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
|
docCols sig l = allocateNode . BDFCols sig =<< sequence l
|
|
|
|
docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
|
|
|
|
docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docSetBaseY bdm = do
|
|
bd <- bdm
|
|
-- the order here is important so that these two nodes can be treated
|
|
-- properly over at `transformAlts`.
|
|
n1 <- allocateNode $ BDFBaseYPushCur bd
|
|
n2 <- allocateNode $ BDFBaseYPop n1
|
|
return n2
|
|
|
|
docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docSetIndentLevel bdm = do
|
|
bd <- bdm
|
|
n1 <- allocateNode $ BDFIndentLevelPushCur bd
|
|
n2 <- allocateNode $ BDFIndentLevelPop n1
|
|
return n2
|
|
|
|
docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docSetBaseAndIndent = docSetBaseY . docSetIndentLevel
|
|
|
|
docSeparator :: ToBriDocM BriDocNumbered
|
|
docSeparator = allocateNode BDFSeparator
|
|
|
|
docAnnotationPrior
|
|
:: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docAnnotationPrior annKey bdm =
|
|
allocateNode . BDFAnnotationPrior annKey =<< bdm
|
|
|
|
docAnnotationKW
|
|
:: AnnKey
|
|
-> Maybe AnnKeywordId
|
|
-> ToBriDocM BriDocNumbered
|
|
-> ToBriDocM BriDocNumbered
|
|
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
|
|
|
|
docMoveToKWDP
|
|
:: AnnKey
|
|
-> AnnKeywordId
|
|
-> Bool
|
|
-> ToBriDocM BriDocNumbered
|
|
-> ToBriDocM BriDocNumbered
|
|
docMoveToKWDP annKey kw shouldRestoreIndent bdm =
|
|
allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm
|
|
|
|
docAnnotationRest
|
|
:: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm
|
|
|
|
docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm
|
|
|
|
docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm
|
|
|
|
docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm
|
|
|
|
docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm
|
|
|
|
docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docDebug s bdm = allocateNode . BDFDebug s =<< bdm
|
|
|
|
appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
appSep x = docSeq [x, docSeparator]
|
|
|
|
docCommaSep :: ToBriDocM BriDocNumbered
|
|
docCommaSep = appSep $ docLit $ Text.pack ","
|
|
|
|
docParenLSep :: ToBriDocM BriDocNumbered
|
|
docParenLSep = appSep docParenL
|
|
|
|
-- TODO: we don't make consistent use of these (yet). However, I think the
|
|
-- most readable approach overall might be something else: define
|
|
-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`.
|
|
-- I think those two would make the usage most readable.
|
|
-- lit "(" and appSep (lit "(") are understandable and short without
|
|
-- introducing a new top-level binding for all types of parentheses.
|
|
docParenL :: ToBriDocM BriDocNumbered
|
|
docParenL = docLit $ Text.pack "("
|
|
|
|
docParenR :: ToBriDocM BriDocNumbered
|
|
docParenR = docLit $ Text.pack ")"
|
|
|
|
docParenHashLSep :: ToBriDocM BriDocNumbered
|
|
docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]
|
|
|
|
docParenHashRSep :: ToBriDocM BriDocNumbered
|
|
docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]
|
|
|
|
docBracketL :: ToBriDocM BriDocNumbered
|
|
docBracketL = docLit $ Text.pack "["
|
|
|
|
docBracketR :: ToBriDocM BriDocNumbered
|
|
docBracketR = docLit $ Text.pack "]"
|
|
|
|
|
|
docTick :: ToBriDocM BriDocNumbered
|
|
docTick = docLit $ Text.pack "'"
|
|
|
|
docNodeAnnKW
|
|
:: Data.Data.Data ast
|
|
=> Located ast
|
|
-> Maybe AnnKeywordId
|
|
-> ToBriDocM BriDocNumbered
|
|
-> ToBriDocM BriDocNumbered
|
|
docNodeAnnKW ast kw bdm =
|
|
docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm
|
|
|
|
docNodeMoveToKWDP
|
|
:: Data.Data.Data ast
|
|
=> Located ast
|
|
-> AnnKeywordId
|
|
-> Bool
|
|
-> ToBriDocM BriDocNumbered
|
|
-> ToBriDocM BriDocNumbered
|
|
docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =
|
|
docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm
|
|
|
|
class DocWrapable a where
|
|
docWrapNode :: ( Data.Data.Data ast)
|
|
=> Located ast
|
|
-> a
|
|
-> a
|
|
docWrapNodePrior :: ( Data.Data.Data ast)
|
|
=> Located ast
|
|
-> a
|
|
-> a
|
|
docWrapNodeRest :: ( Data.Data.Data ast)
|
|
=> Located ast
|
|
-> a
|
|
-> a
|
|
|
|
instance DocWrapable (ToBriDocM BriDocNumbered) where
|
|
docWrapNode ast bdm = do
|
|
bd <- bdm
|
|
i1 <- allocNodeIndex
|
|
i2 <- allocNodeIndex
|
|
return
|
|
$ (,) i1
|
|
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
|
|
$ (,) i2
|
|
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
|
|
$ bd
|
|
docWrapNodePrior ast bdm = do
|
|
bd <- bdm
|
|
i1 <- allocNodeIndex
|
|
return
|
|
$ (,) i1
|
|
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
|
|
$ bd
|
|
docWrapNodeRest ast bdm = do
|
|
bd <- bdm
|
|
i2 <- allocNodeIndex
|
|
return
|
|
$ (,) i2
|
|
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
|
|
$ bd
|
|
|
|
instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
|
|
docWrapNode ast bdms = case bdms of
|
|
[] -> []
|
|
[bd] -> [docWrapNode ast bd]
|
|
(bd1:bdR) | (bdN:bdM) <- reverse bdR ->
|
|
[docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]
|
|
_ -> error "cannot happen (TM)"
|
|
docWrapNodePrior ast bdms = case bdms of
|
|
[] -> []
|
|
[bd] -> [docWrapNodePrior ast bd]
|
|
(bd1:bdR) -> docWrapNodePrior ast bd1 : bdR
|
|
docWrapNodeRest ast bdms = case reverse bdms of
|
|
[] -> []
|
|
(bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR
|
|
|
|
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
|
|
docWrapNode ast bdsm = do
|
|
bds <- bdsm
|
|
case bds of
|
|
[] -> return [] -- TODO: this might be bad. maybe. then again, not really. well.
|
|
[bd] -> do
|
|
bd' <- docWrapNode ast (return bd)
|
|
return [bd']
|
|
(bd1:bdR) | (bdN:bdM) <- reverse bdR -> do
|
|
bd1' <- docWrapNodePrior ast (return bd1)
|
|
bdN' <- docWrapNodeRest ast (return bdN)
|
|
return $ [bd1'] ++ reverse bdM ++ [bdN']
|
|
_ -> error "cannot happen (TM)"
|
|
docWrapNodePrior ast bdsm = do
|
|
bds <- bdsm
|
|
case bds of
|
|
[] -> return []
|
|
(bd1:bdR) -> do
|
|
bd1' <- docWrapNodePrior ast (return bd1)
|
|
return (bd1':bdR)
|
|
docWrapNodeRest ast bdsm = do
|
|
bds <- bdsm
|
|
case reverse bds of
|
|
[] -> return []
|
|
(bdN:bdR) -> do
|
|
bdN' <- docWrapNodeRest ast (return bdN)
|
|
return $ reverse (bdN':bdR)
|
|
|
|
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
|
|
docWrapNode ast bdsm = do
|
|
bds <- bdsm
|
|
case Seq.viewl bds of
|
|
Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.
|
|
bd1 Seq.:< rest -> case Seq.viewr rest of
|
|
Seq.EmptyR -> do
|
|
bd1' <- docWrapNode ast (return bd1)
|
|
return $ Seq.singleton bd1'
|
|
bdM Seq.:> bdN -> do
|
|
bd1' <- docWrapNodePrior ast (return bd1)
|
|
bdN' <- docWrapNodeRest ast (return bdN)
|
|
return $ (bd1' Seq.<| bdM) Seq.|> bdN'
|
|
docWrapNodePrior ast bdsm = do
|
|
bds <- bdsm
|
|
case Seq.viewl bds of
|
|
Seq.EmptyL -> return Seq.empty
|
|
bd1 Seq.:< bdR -> do
|
|
bd1' <- docWrapNodePrior ast (return bd1)
|
|
return $ bd1' Seq.<| bdR
|
|
docWrapNodeRest ast bdsm = do
|
|
bds <- bdsm
|
|
case Seq.viewr bds of
|
|
Seq.EmptyR -> return Seq.empty
|
|
bdR Seq.:> bdN -> do
|
|
bdN' <- docWrapNodeRest ast (return bdN)
|
|
return $ bdR Seq.|> bdN'
|
|
|
|
instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where
|
|
docWrapNode ast stuffM = do
|
|
(bds, bd, x) <- stuffM
|
|
if null bds
|
|
then do
|
|
bd' <- docWrapNode ast (return bd)
|
|
return (bds, bd', x)
|
|
else do
|
|
bds' <- docWrapNodePrior ast (return bds)
|
|
bd' <- docWrapNodeRest ast (return bd)
|
|
return (bds', bd', x)
|
|
docWrapNodePrior ast stuffM = do
|
|
(bds, bd, x) <- stuffM
|
|
bds' <- docWrapNodePrior ast (return bds)
|
|
return (bds', bd, x)
|
|
docWrapNodeRest ast stuffM = do
|
|
(bds, bd, x) <- stuffM
|
|
bd' <- docWrapNodeRest ast (return bd)
|
|
return (bds, bd', x)
|
|
|
|
|
|
|
|
docPar
|
|
:: ToBriDocM BriDocNumbered
|
|
-> ToBriDocM BriDocNumbered
|
|
-> ToBriDocM BriDocNumbered
|
|
docPar lineM indentedM = do
|
|
line <- lineM
|
|
indented <- indentedM
|
|
allocateNode $ BDFPar BrIndentNone line indented
|
|
|
|
docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
|
|
|
|
docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
|
|
|
|
docEnsureIndent
|
|
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
|
docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
|
|
|
|
unknownNodeError
|
|
:: Data.Data.Data ast
|
|
=> String
|
|
-> GenLocated GHC.SrcSpan ast
|
|
-> ToBriDocM BriDocNumbered
|
|
unknownNodeError infoStr ast = do
|
|
mTell [ErrorUnknownNode infoStr ast]
|
|
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
|
|
|
|
spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered]
|
|
spacifyDocs [] = []
|
|
spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
|
|
|
|
briDocMToPPM :: ToBriDocM a -> PPMLocal a
|
|
briDocMToPPM m = do
|
|
(x, errs, debugs) <- briDocMToPPMInner m
|
|
mTell debugs
|
|
mTell errs
|
|
return x
|
|
|
|
briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)
|
|
briDocMToPPMInner m = do
|
|
readers <- MultiRWSS.mGetRawR
|
|
let ((x, errs), debugs) =
|
|
runIdentity
|
|
$ MultiRWSS.runMultiRWSTNil
|
|
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
|
|
$ MultiRWSS.withMultiReaders readers
|
|
$ MultiRWSS.withMultiWriterAW
|
|
$ MultiRWSS.withMultiWriterAW
|
|
$ m
|
|
pure (x, errs, debugs)
|
|
|
|
docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)
|
|
docSharedWrapper f x = return <$> f x
|