283 lines
12 KiB
Haskell
283 lines
12 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
module Language.Haskell.Brittany.Internal.Components.BriDoc where
|
|
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
|
|
import Data.Generics.Uniplate.Direct as Uniplate
|
|
import qualified Data.Data
|
|
import GHC (RealSrcLoc, LEpaComment, DeltaPos)
|
|
|
|
|
|
|
|
-- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot
|
|
-- of transformations on `BriDocF Identity`s and it is really annoying to
|
|
-- `Identity`/`runIdentity` everywhere.
|
|
data BriDoc
|
|
= -- BDWrapAnnKey AnnKey BriDoc
|
|
BDEmpty
|
|
| BDLit !Text
|
|
| BDSeq [BriDoc] -- elements other than the last should
|
|
-- not contains BDPars.
|
|
| BDCols ColSig [BriDoc] -- elements other than the last
|
|
-- should not contains BDPars
|
|
| BDSeparator -- semantically, space-unless-at-end-of-line.
|
|
| BDAddBaseY BrIndent BriDoc
|
|
| BDBaseYPushCur BriDoc
|
|
| BDIndentLevelPushCur BriDoc
|
|
| BDIndentLevelPop BriDoc
|
|
| BDPar
|
|
{ _bdpar_indent :: BrIndent
|
|
, _bdpar_restOfLine :: BriDoc -- should not contain other BDPars
|
|
, _bdpar_indented :: BriDoc
|
|
}
|
|
-- | BDAddIndent BrIndent (BriDocF f)
|
|
-- | BDNewline
|
|
| BDAlt [BriDoc]
|
|
| BDForwardLineMode BriDoc
|
|
| BDExternal -- AnnKey
|
|
-- (Set AnnKey) -- set of annkeys contained within the node
|
|
-- -- to be printed via exactprint
|
|
Bool -- should print extra comment ?
|
|
Text
|
|
| BDPlain !Text -- used for QuasiQuotes, content can be multi-line
|
|
-- (contrast to BDLit)
|
|
| BDQueueComments [LEpaComment] BriDoc
|
|
-- queue to be later flushed when the markers are reached
|
|
| BDFlushCommentsPrior RealSrcLoc BriDoc
|
|
-- process comments before loc from the queue
|
|
| BDFlushCommentsPost RealSrcLoc BriDoc
|
|
-- process comments before loc from the queue, but flow to end of
|
|
-- child-nodes
|
|
| BDEntryDelta DeltaPos BriDoc
|
|
-- Move to the specified delta position before rendering the inner
|
|
-- element. Currently this only ever respects newlines, i.e. Sameline
|
|
-- is ignored and only the `n` of DifferentLine n _ is used.
|
|
-- Purpose is to retain some spacing in the formatted code, inside
|
|
-- a particular declaration - on the top-level spacing is retained by
|
|
-- other means.
|
|
-- The deltas should in general derived via `obtainAnnDeltaPos`.
|
|
| BDLines [BriDoc]
|
|
| BDEnsureIndent BrIndent BriDoc
|
|
-- the following constructors are only relevant for the alt transformation
|
|
-- and are removed afterwards. They should never occur in any BriDoc
|
|
-- after the alt transformation.
|
|
| BDForceMultiline BriDoc
|
|
| BDForceSingleline BriDoc
|
|
| BDNonBottomSpacing Bool BriDoc
|
|
| BDSetParSpacing BriDoc
|
|
| BDForceParSpacing BriDoc
|
|
-- pseudo-deprecated
|
|
| BDDebug String BriDoc
|
|
deriving (Data.Data.Data, Eq, Ord)
|
|
|
|
data BriDocF f
|
|
= -- BDWrapAnnKey AnnKey BriDoc
|
|
BDFEmpty
|
|
| BDFLit !Text
|
|
| BDFSeq [f (BriDocF f)] -- elements other than the last should
|
|
-- not contains BDPars.
|
|
| BDFCols ColSig [f (BriDocF f)] -- elements other than the last
|
|
-- should not contains BDPars
|
|
| BDFSeparator -- semantically, space-unless-at-end-of-line.
|
|
| BDFAddBaseY BrIndent (f (BriDocF f))
|
|
| BDFBaseYPushCur (f (BriDocF f))
|
|
| BDFIndentLevelPushCur (f (BriDocF f))
|
|
| BDFIndentLevelPop (f (BriDocF f))
|
|
| BDFPar
|
|
{ _bdfpar_indent :: BrIndent
|
|
, _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars
|
|
, _bdfpar_indented :: f (BriDocF f)
|
|
}
|
|
-- | BDAddIndent BrIndent (BriDocF f)
|
|
-- | BDNewline
|
|
| BDFAlt [f (BriDocF f)]
|
|
| BDFForwardLineMode (f (BriDocF f))
|
|
| BDFExternal -- AnnKey
|
|
-- (Set AnnKey) -- set of annkeys contained within the node
|
|
-- -- to be printed via exactprint
|
|
Bool -- should print extra comment ?
|
|
Text
|
|
| BDFPlain !Text -- used for QuasiQuotes, content can be multi-line
|
|
-- (contrast to BDLit)
|
|
| BDFQueueComments [LEpaComment] (f (BriDocF f))
|
|
-- ^ true = comments will be left in the queue when the node is left
|
|
| BDFFlushCommentsPrior RealSrcLoc (f (BriDocF f))
|
|
-- process comments before loc from the queue
|
|
| BDFFlushCommentsPost RealSrcLoc (f (BriDocF f))
|
|
-- process comments before loc from the queue, but flow to end of
|
|
-- child-nodes
|
|
| BDFEntryDelta DeltaPos (f (BriDocF f))
|
|
| BDFLines [(f (BriDocF f))]
|
|
| BDFEnsureIndent BrIndent (f (BriDocF f))
|
|
| BDFForceMultiline (f (BriDocF f))
|
|
| BDFForceSingleline (f (BriDocF f))
|
|
| BDFNonBottomSpacing Bool (f (BriDocF f))
|
|
| BDFSetParSpacing (f (BriDocF f))
|
|
| BDFForceParSpacing (f (BriDocF f))
|
|
| BDFDebug String (f (BriDocF f))
|
|
|
|
data BrIndent = BrIndentNone
|
|
| BrIndentRegular
|
|
| BrIndentSpecial Int
|
|
deriving (Eq, Ord, Data.Data.Data, Show)
|
|
|
|
-- deriving instance Data.Data.Data (BriDocF Identity)
|
|
deriving instance Data.Data.Data (BriDocF ((,) Int))
|
|
|
|
type BriDocFInt = BriDocF ((,) Int)
|
|
type BriDocNumbered = (Int, BriDocFInt)
|
|
|
|
instance Uniplate.Uniplate BriDoc where
|
|
uniplate x@BDEmpty{} = plate x
|
|
uniplate x@BDLit{} = plate x
|
|
uniplate (BDSeq list ) = plate BDSeq ||* list
|
|
uniplate (BDCols sig list) = plate BDCols |- sig ||* list
|
|
uniplate x@BDSeparator = plate x
|
|
uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd
|
|
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
|
|
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
|
|
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
|
|
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
|
|
uniplate (BDAlt alts ) = plate BDAlt ||* alts
|
|
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
|
|
uniplate x@BDExternal{} = plate x
|
|
uniplate x@BDPlain{} = plate x
|
|
uniplate (BDQueueComments comms bd) =
|
|
plate BDQueueComments |- comms |* bd
|
|
uniplate (BDFlushCommentsPrior loc bd) =
|
|
plate BDFlushCommentsPrior |- loc |* bd
|
|
uniplate (BDFlushCommentsPost loc bd) =
|
|
plate BDFlushCommentsPost |- loc |* bd
|
|
uniplate (BDEntryDelta dp bd ) = plate BDEntryDelta |- dp |* bd
|
|
uniplate (BDLines lines ) = plate BDLines ||* lines
|
|
uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
|
|
uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd
|
|
uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd
|
|
uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd
|
|
uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd
|
|
uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd
|
|
uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd
|
|
|
|
-- this might not work. is not used anywhere either.
|
|
briDocSeqSpine :: BriDoc -> ()
|
|
briDocSeqSpine = \case
|
|
BDEmpty -> ()
|
|
BDLit _t -> ()
|
|
BDSeq list -> foldl' ((briDocSeqSpine .) . seq) () list
|
|
BDCols _sig list -> foldl' ((briDocSeqSpine .) . seq) () list
|
|
BDSeparator -> ()
|
|
BDAddBaseY _ind bd -> briDocSeqSpine bd
|
|
BDBaseYPushCur bd -> briDocSeqSpine bd
|
|
BDIndentLevelPushCur bd -> briDocSeqSpine bd
|
|
BDIndentLevelPop bd -> briDocSeqSpine bd
|
|
BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
|
|
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
|
|
BDForwardLineMode bd -> briDocSeqSpine bd
|
|
BDExternal{} -> ()
|
|
BDPlain{} -> ()
|
|
BDQueueComments _comms bd -> briDocSeqSpine bd
|
|
BDFlushCommentsPrior _loc bd -> briDocSeqSpine bd
|
|
BDFlushCommentsPost _loc bd -> briDocSeqSpine bd
|
|
BDEntryDelta _dp bd -> briDocSeqSpine bd
|
|
BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines
|
|
BDEnsureIndent _ind bd -> briDocSeqSpine bd
|
|
BDForceMultiline bd -> briDocSeqSpine bd
|
|
BDForceSingleline bd -> briDocSeqSpine bd
|
|
BDNonBottomSpacing _ bd -> briDocSeqSpine bd
|
|
BDSetParSpacing bd -> briDocSeqSpine bd
|
|
BDForceParSpacing bd -> briDocSeqSpine bd
|
|
BDDebug _s bd -> briDocSeqSpine bd
|
|
|
|
briDocForceSpine :: BriDoc -> BriDoc
|
|
briDocForceSpine bd = briDocSeqSpine bd `seq` bd
|
|
|
|
isNotEmpty :: BriDoc -> Bool
|
|
isNotEmpty BDEmpty = False
|
|
isNotEmpty _ = True
|
|
|
|
-- TODO: rename to "dropLabels" ?
|
|
unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
|
|
unwrapBriDocNumbered tpl = case snd tpl of
|
|
BDFEmpty -> BDEmpty
|
|
BDFLit t -> BDLit t
|
|
BDFSeq list -> BDSeq $ rec <$> list
|
|
BDFCols sig list -> BDCols sig $ rec <$> list
|
|
BDFSeparator -> BDSeparator
|
|
BDFAddBaseY ind bd -> BDAddBaseY ind $ rec bd
|
|
BDFBaseYPushCur bd -> BDBaseYPushCur $ rec bd
|
|
BDFIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd
|
|
BDFIndentLevelPop bd -> BDIndentLevelPop $ rec bd
|
|
BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
|
|
BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
|
|
BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
|
|
BDFExternal c t -> BDExternal c t
|
|
BDFPlain t -> BDPlain t
|
|
BDFQueueComments comms bd -> BDQueueComments comms $ rec bd
|
|
BDFFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd
|
|
BDFFlushCommentsPost loc bd -> BDFlushCommentsPost loc $ rec bd
|
|
BDFEntryDelta dp bd -> BDEntryDelta dp $ rec bd
|
|
BDFLines lines -> BDLines $ rec <$> lines
|
|
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
|
|
BDFForceMultiline bd -> BDForceMultiline $ rec bd
|
|
BDFForceSingleline bd -> BDForceSingleline $ rec bd
|
|
BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
|
|
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
|
|
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
|
|
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
|
|
where rec = unwrapBriDocNumbered
|
|
|
|
data ColSig
|
|
= ColTyOpPrefix
|
|
-- any prefixed operator/paren/"::"/..
|
|
-- expected to have exactly two colums.
|
|
-- e.g. ":: foo"
|
|
-- 111222
|
|
-- "-> bar asd asd"
|
|
-- 11122222222222
|
|
| ColPatternsFuncPrefix
|
|
-- pattern-part of the lhs, e.g. "func (foo a b) c _".
|
|
-- Has variable number of columns depending on the number of patterns.
|
|
| ColPatternsFuncInfix
|
|
-- pattern-part of the lhs, e.g. "Foo a <> Foo b".
|
|
-- Has variable number of columns depending on the number of patterns.
|
|
| ColPatterns
|
|
| ColCasePattern
|
|
| ColBindingLine (Maybe Text)
|
|
-- e.g. "func pat pat = expr"
|
|
-- 1111111111111222222
|
|
-- or "pat | stmt -> expr"
|
|
-- 111111111112222222
|
|
-- expected to have exactly two columns.
|
|
| ColGuard
|
|
-- e.g. "func pat pat | cond = ..."
|
|
-- 11111111111112222222
|
|
-- or "pat | cond1, cond2 -> ..."
|
|
-- 1111222222222222222
|
|
-- expected to have exactly two columns
|
|
| ColGuardedBody
|
|
-- e.g. | foofoo = 1
|
|
-- | bar = 2
|
|
-- 111111111222
|
|
-- expected to have exactly two columns
|
|
| ColBindStmt
|
|
| ColDoLet -- the non-indented variant
|
|
| ColRec
|
|
| ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?
|
|
| ColRecDecl
|
|
| ColListComp
|
|
| ColList
|
|
| ColApp Text
|
|
| ColTuple
|
|
| ColTuples
|
|
| ColOpPrefix -- merge with ColList ? other stuff?
|
|
| ColImport
|
|
|
|
-- TODO
|
|
deriving (Eq, Ord, Data.Data.Data, Show)
|