{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE TypeFamilies #-} 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) -- historical design note -- -- We previously had -- data BriDocF (f :: Type -> Type) = … -- where instead of BriDocRec we used `f (BriDocF f)`. -- This was very close to what we have now, because: -- BriDocW Wrapped ~ BriDocF ((,) Int) -- BriDocW Unwrapped ~ BriDocF Identity -- but the crucial (and annoying) difference is the existence of `Identity` -- constructors that are required inside the `BriDocF Identity` values. -- -- This new type-family based approach is much neater, yay! data IsWrapped = Wrapped | Unwrapped type family BriDocRec (w :: IsWrapped) where BriDocRec 'Wrapped = (Int, BriDocW 'Wrapped) BriDocRec 'Unwrapped = BriDocW 'Unwrapped data BriDocW (w :: IsWrapped) = -- BDWrapAnnKey AnnKey BriDoc BDEmpty | BDLit !Text | BDSeq [BriDocRec w] -- elements other than the last should -- not contains BDPars. | BDCols ColSig [BriDocRec w] -- elements other than the last -- should not contains BDPars | BDSeparator -- semantically, space-unless-at-end-of-line. | BDAddBaseY BrIndent (BriDocRec w) | BDBaseYPushCur (BriDocRec w) | BDIndentLevelPushCur (BriDocRec w) | BDIndentLevelPop (BriDocRec w) | BDPar { _bdpar_indent :: BrIndent , _bdpar_restOfLine :: BriDocRec w -- should not contain other BDPars , _bdpar_indented :: BriDocRec w } -- | BDAddIndent BrIndent (BriDocRec w) -- | BDNewline | BDAlt [BriDocRec w] | BDForwardLineMode (BriDocRec w) | 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] (BriDocRec w) -- queue to be later flushed when the markers are reached | BDFlushCommentsPrior RealSrcLoc (BriDocRec w) -- process comments before loc from the queue | BDFlushCommentsPost RealSrcLoc Bool (BriDocRec w) -- process comments before loc from the queue, but flow to end of -- child-nodes. The boolean determines whether we set this location for -- purposes of multiple-line DP calculations. This determines whether -- empty lines after this element will be retained in the output. | BDEntryDelta DeltaPos (BriDocRec w) -- 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 [(BriDocRec w)] | BDEnsureIndent BrIndent (BriDocRec w) -- the following constructors are only relevant for the alt transformation -- and are removed afterwards. They should never occur in any (BriDocRec w) -- after the alt transformation. | BDForceAlt ForceAlt (BriDocRec w) -- pseudo-deprecated | BDDebug String (BriDocRec w) deriving instance Data.Data.Data (BriDocW 'Unwrapped) deriving instance Data.Data.Data (BriDocW 'Wrapped) type BriDoc = BriDocW 'Unwrapped type BriDocWrapped = BriDocW 'Wrapped type BriDocNumbered = (Int, BriDocWrapped) data ForceAlt = ForceMultiline | ForceSingleline | NonBottomSpacing Bool | SetParSpacing | ForceParSpacing | ForceZeroAdd deriving (Eq, Ord, Data.Data.Data, Show) data BrIndent = BrIndentNone | BrIndentRegular | BrIndentRegularForce | BrIndentSpecial Int deriving (Eq, Ord, Data.Data.Data, Show) 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 shouldMark bd) = plate BDFlushCommentsPost |- loc |- shouldMark |* bd uniplate (BDEntryDelta dp bd ) = plate BDEntryDelta |- dp |* bd uniplate (BDLines lines ) = plate BDLines ||* lines uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd uniplate (BDForceAlt forceFlag bd) = plate BDForceAlt |- forceFlag |* 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 _m bd -> briDocSeqSpine bd BDEntryDelta _dp bd -> briDocSeqSpine bd BDLines lines -> foldl' (\() -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd BDForceAlt _ 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 BDEmpty -> BDEmpty BDLit t -> BDLit t BDSeq list -> BDSeq $ rec <$> list BDCols sig list -> BDCols sig $ rec <$> list BDSeparator -> BDSeparator BDAddBaseY ind bd -> BDAddBaseY ind $ rec bd BDBaseYPushCur bd -> BDBaseYPushCur $ rec bd BDIndentLevelPushCur bd -> BDIndentLevelPushCur $ rec bd BDIndentLevelPop bd -> BDIndentLevelPop $ rec bd BDPar ind line indented -> BDPar ind (rec line) (rec indented) BDAlt alts -> BDAlt $ rec <$> alts -- not that this will happen BDForwardLineMode bd -> BDForwardLineMode $ rec bd BDExternal c t -> BDExternal c t BDPlain t -> BDPlain t BDQueueComments comms bd -> BDQueueComments comms $ rec bd BDFlushCommentsPrior loc bd -> BDFlushCommentsPrior loc $ rec bd BDFlushCommentsPost loc mrk bd -> BDFlushCommentsPost loc mrk $ rec bd BDEntryDelta dp bd -> BDEntryDelta dp $ rec bd BDLines lines -> BDLines $ rec <$> lines BDEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDForceAlt forceFlag bd -> BDForceAlt forceFlag $ rec bd BDDebug 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)