257 lines
11 KiB
Haskell
257 lines
11 KiB
Haskell
{-# 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.
|
|
| BDForceMultiline (BriDocRec w)
|
|
| BDForceSingleline (BriDocRec w)
|
|
| BDNonBottomSpacing Bool (BriDocRec w)
|
|
| BDSetParSpacing (BriDocRec w)
|
|
| BDForceParSpacing (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 BrIndent = BrIndentNone
|
|
| BrIndentRegular
|
|
| 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 (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 _m 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
|
|
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
|
|
BDForceMultiline bd -> BDForceMultiline $ rec bd
|
|
BDForceSingleline bd -> BDForceSingleline $ rec bd
|
|
BDNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
|
|
BDSetParSpacing bd -> BDSetParSpacing $ rec bd
|
|
BDForceParSpacing bd -> BDForceParSpacing $ 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)
|