Apply brittany on parts of its source; Add comments
Lennart Spitzner
parent
3809ba9ef0
commit
b03996e401
|
|
@ -225,11 +225,11 @@ readConfigs cmdlineConfig configPaths = do
|
|||
userBritPath <- liftIO $ Directory.getAppUserDataDirectory "brittany"
|
||||
let defUserConfigPath = userBritPath FilePath.</> "config.yaml"
|
||||
merged <- case configPaths of
|
||||
[] -> do
|
||||
[] -> do
|
||||
liftIO $ Directory.createDirectoryIfMissing False userBritPath
|
||||
return cmdlineConfig
|
||||
>>= readMergePersConfig defLocalConfigPath False
|
||||
>>= readMergePersConfig defUserConfigPath True
|
||||
>>= readMergePersConfig defUserConfigPath True
|
||||
-- TODO: ensure that paths exist ?
|
||||
paths -> foldl (\prev p -> prev >>= readMergePersConfig p False)
|
||||
(return cmdlineConfig)
|
||||
|
|
|
|||
|
|
@ -21,14 +21,23 @@ import TestUtils
|
|||
|
||||
asymptoticPerfTest :: Spec
|
||||
asymptoticPerfTest = do
|
||||
it "1000 do statements" $ roundTripEqualWithTimeout 1000000 $
|
||||
( Text.pack "func = do\n")
|
||||
it "1000 do statements"
|
||||
$ roundTripEqualWithTimeout 1000000
|
||||
$ (Text.pack "func = do\n")
|
||||
<> Text.replicate 1000 (Text.pack " statement\n")
|
||||
it "1000 do nestings" $ roundTripEqualWithTimeout 4000000 $
|
||||
( Text.pack "func = ")
|
||||
<> mconcat ([0..999] <&> \(i::Int) -> (Text.replicate (2*i) (Text.pack " ") <> Text.pack "do\n"))
|
||||
<> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n"
|
||||
<> Text.replicate 2002 (Text.pack " ") <> Text.pack "()"
|
||||
it "1000 AppOps" $ roundTripEqualWithTimeout 1000000 $
|
||||
( Text.pack "func = expr")
|
||||
it "1000 do nestings"
|
||||
$ roundTripEqualWithTimeout 4000000
|
||||
$ (Text.pack "func = ")
|
||||
<> mconcat
|
||||
( [0 .. 999]
|
||||
<&> \(i :: Int) ->
|
||||
(Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
|
||||
)
|
||||
<> Text.replicate 2000 (Text.pack " ")
|
||||
<> Text.pack "return\n"
|
||||
<> Text.replicate 2002 (Text.pack " ")
|
||||
<> Text.pack "()"
|
||||
it "1000 AppOps"
|
||||
$ roundTripEqualWithTimeout 1000000
|
||||
$ (Text.pack "func = expr")
|
||||
<> Text.replicate 200 (Text.pack "\n . expr") --TODO
|
||||
|
|
|
|||
|
|
@ -21,15 +21,17 @@ import Data.Coerce ( coerce )
|
|||
|
||||
|
||||
roundTripEqual :: Text -> Expectation
|
||||
roundTripEqual t = fmap (fmap PPTextWrapper) (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
|
||||
roundTripEqual t =
|
||||
fmap (fmap PPTextWrapper)
|
||||
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
|
||||
`shouldReturn` Right (PPTextWrapper t)
|
||||
|
||||
roundTripEqualWithTimeout :: Int -> Text -> Expectation
|
||||
roundTripEqualWithTimeout time t =
|
||||
timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust)
|
||||
where
|
||||
action = fmap (fmap PPTextWrapper)
|
||||
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
|
||||
timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust)
|
||||
where
|
||||
action = fmap (fmap PPTextWrapper)
|
||||
(parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
|
||||
|
||||
newtype PPTextWrapper = PPTextWrapper Text
|
||||
deriving Eq
|
||||
|
|
@ -39,19 +41,19 @@ instance Show PPTextWrapper where
|
|||
|
||||
defaultTestConfig :: Config
|
||||
defaultTestConfig = Config
|
||||
{ _conf_debug = _conf_debug staticDefaultConfig
|
||||
, _conf_layout = LayoutConfig
|
||||
{ _lconfig_cols = coerce (80 :: Int)
|
||||
, _lconfig_indentPolicy = coerce IndentPolicyFree
|
||||
, _lconfig_indentAmount = coerce (2 :: Int)
|
||||
, _lconfig_indentWhereSpecial = coerce True
|
||||
, _lconfig_indentListSpecial = coerce True
|
||||
, _lconfig_importColumn = coerce (60 :: Int)
|
||||
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
|
||||
, _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously
|
||||
}
|
||||
, _conf_errorHandling = _conf_errorHandling staticDefaultConfig
|
||||
, _conf_forward = ForwardOptions
|
||||
{ _options_ghc = Identity []
|
||||
}
|
||||
{ _conf_debug = _conf_debug staticDefaultConfig
|
||||
, _conf_layout = LayoutConfig
|
||||
{ _lconfig_cols = coerce (80 :: Int)
|
||||
, _lconfig_indentPolicy = coerce IndentPolicyFree
|
||||
, _lconfig_indentAmount = coerce (2 :: Int)
|
||||
, _lconfig_indentWhereSpecial = coerce True
|
||||
, _lconfig_indentListSpecial = coerce True
|
||||
, _lconfig_importColumn = coerce (60 :: Int)
|
||||
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
|
||||
, _lconfig_columnAlignMode = coerce ColumnAlignModeUnanimously
|
||||
}
|
||||
, _conf_errorHandling = _conf_errorHandling staticDefaultConfig
|
||||
, _conf_forward = ForwardOptions
|
||||
{ _options_ghc = Identity []
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -59,8 +59,9 @@ pPrintModule
|
|||
-> GHC.ParsedSource
|
||||
-> ([LayoutError], TextL.Text)
|
||||
pPrintModule conf anns parsedModule =
|
||||
let ((out, errs), debugStrings)
|
||||
= runIdentity
|
||||
let
|
||||
((out, errs), debugStrings) =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
|
|
@ -68,13 +69,18 @@ pPrintModule conf anns parsedModule =
|
|||
$ MultiRWSS.withMultiReader anns
|
||||
$ MultiRWSS.withMultiReader conf
|
||||
$ do
|
||||
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ annsDoc anns
|
||||
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
|
||||
$ annsDoc anns
|
||||
ppModule parsedModule
|
||||
tracer = if Seq.null debugStrings
|
||||
then id
|
||||
else trace ("---- DEBUGMESSAGES ---- ")
|
||||
. foldr (seq . join trace) id debugStrings
|
||||
in tracer $ (errs, Text.Builder.toLazyText out)
|
||||
tracer =
|
||||
if Seq.null debugStrings
|
||||
then
|
||||
id
|
||||
else
|
||||
trace ("---- DEBUGMESSAGES ---- ")
|
||||
. foldr (seq . join trace) id debugStrings
|
||||
in
|
||||
tracer $ (errs, Text.Builder.toLazyText out)
|
||||
-- unless () $ do
|
||||
--
|
||||
-- debugStrings `forM_` \s ->
|
||||
|
|
@ -101,27 +107,25 @@ pPrintModuleAndCheck conf anns parsedModule = do
|
|||
|
||||
|
||||
-- used for testing mostly, currently.
|
||||
parsePrintModule
|
||||
:: Config
|
||||
-> String
|
||||
-> Text
|
||||
-> IO (Either String Text)
|
||||
parsePrintModule :: Config -> String -> Text -> IO (Either String Text)
|
||||
parsePrintModule conf filename input = do
|
||||
let inputStr = Text.unpack input
|
||||
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
|
||||
case parseResult of
|
||||
Left (_, s) -> return $ Left $ "parsing error: " ++ s
|
||||
Left (_ , s ) -> return $ Left $ "parsing error: " ++ s
|
||||
Right (anns, parsedModule) -> do
|
||||
(errs, ltext) <- pPrintModuleAndCheck conf anns parsedModule
|
||||
return $ if null errs
|
||||
then Right $ TextL.toStrict $ ltext
|
||||
else
|
||||
let errStrs = errs <&> \case
|
||||
LayoutErrorUnusedComment str -> str
|
||||
LayoutWarning str -> str
|
||||
LayoutErrorUnknownNode str _ -> str
|
||||
LayoutErrorOutputCheck -> "Output is not syntactically valid."
|
||||
in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
|
||||
let
|
||||
errStrs = errs <&> \case
|
||||
LayoutErrorUnusedComment str -> str
|
||||
LayoutWarning str -> str
|
||||
LayoutErrorUnknownNode str _ -> str
|
||||
LayoutErrorOutputCheck -> "Output is not syntactically valid."
|
||||
in
|
||||
Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
|
||||
|
||||
-- this approach would for with there was a pure GHC.parseDynamicFilePragma.
|
||||
-- Unfortunately that does not exist yet, so we cannot provide a nominally
|
||||
|
|
@ -166,40 +170,40 @@ ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do
|
|||
return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of
|
||||
Nothing -> (anns, [])
|
||||
Just mAnn ->
|
||||
let
|
||||
modAnnsDp = ExactPrint.Types.annsDP mAnn
|
||||
isWhere (ExactPrint.Types.G AnnWhere) = True
|
||||
isWhere _ = False
|
||||
isEof (ExactPrint.Types.G AnnEofPos) = True
|
||||
isEof _ = False
|
||||
whereInd = List.findIndex (isWhere . fst) modAnnsDp
|
||||
eofInd = List.findIndex (isEof . fst) modAnnsDp
|
||||
(pre, post) = case (whereInd, eofInd) of
|
||||
(Nothing, Nothing) -> ([], modAnnsDp)
|
||||
(Just i, Nothing) -> List.splitAt (i+1) modAnnsDp
|
||||
(Nothing, Just _i) -> ([], modAnnsDp)
|
||||
(Just i, Just j) -> List.splitAt (min (i+1) j) modAnnsDp
|
||||
mAnn' = mAnn { ExactPrint.Types.annsDP = pre }
|
||||
anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns
|
||||
in (anns', post)
|
||||
let modAnnsDp = ExactPrint.Types.annsDP mAnn
|
||||
isWhere (ExactPrint.Types.G AnnWhere) = True
|
||||
isWhere _ = False
|
||||
isEof (ExactPrint.Types.G AnnEofPos) = True
|
||||
isEof _ = False
|
||||
whereInd = List.findIndex (isWhere . fst) modAnnsDp
|
||||
eofInd = List.findIndex (isEof . fst) modAnnsDp
|
||||
(pre, post) = case (whereInd, eofInd) of
|
||||
(Nothing, Nothing) -> ([], modAnnsDp)
|
||||
(Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp
|
||||
(Nothing, Just _i) -> ([], modAnnsDp)
|
||||
(Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp
|
||||
mAnn' = mAnn { ExactPrint.Types.annsDP = pre }
|
||||
anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns
|
||||
in (anns', post)
|
||||
MultiRWSS.withMultiReader anns' $ processDefault emptyModule
|
||||
decls `forM_` ppDecl
|
||||
let
|
||||
finalComments = filter (fst .> \case ExactPrint.Types.AnnComment{} -> True
|
||||
_ -> False)
|
||||
post
|
||||
let finalComments = filter ( fst .> \case
|
||||
ExactPrint.Types.AnnComment{} -> True
|
||||
_ -> False
|
||||
)
|
||||
post
|
||||
post `forM_` \case
|
||||
(ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do
|
||||
ppmMoveToExactLoc l
|
||||
mTell $ Text.Builder.fromString cmStr
|
||||
(ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX,eofY))) ->
|
||||
(ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) ->
|
||||
let folder acc (kw, ExactPrint.Types.DP (x, _)) = case kw of
|
||||
ExactPrint.Types.AnnComment cm
|
||||
| GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm
|
||||
-> acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
|
||||
_ -> acc + x
|
||||
cmX = foldl' folder 0 finalComments
|
||||
in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY)
|
||||
in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY)
|
||||
_ -> return ()
|
||||
|
||||
withTransformedAnns :: SYB.Data ast => ast -> PPM () -> PPM ()
|
||||
|
|
@ -229,15 +233,15 @@ ppDecl d@(L loc decl) = case decl of
|
|||
briDoc <- briDocMToPPM $ do
|
||||
eitherNode <- layoutBind (L loc bind)
|
||||
case eitherNode of
|
||||
Left ns -> docLines $ return <$> ns
|
||||
Left ns -> docLines $ return <$> ns
|
||||
Right n -> return n
|
||||
layoutBriDoc d briDoc
|
||||
_ ->
|
||||
briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d
|
||||
_ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d
|
||||
|
||||
_sigHead :: Sig RdrName -> String
|
||||
_sigHead = \case
|
||||
TypeSig names _ -> "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
|
||||
TypeSig names _ ->
|
||||
"TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
|
||||
_ -> "unknown sig"
|
||||
|
||||
_bindHead :: HsBind RdrName -> String
|
||||
|
|
|
|||
|
|
@ -66,65 +66,79 @@ import qualified Control.Monad.Trans.Writer.Strict as WriterS
|
|||
|
||||
|
||||
|
||||
layoutBriDoc :: Data.Data.Data ast
|
||||
=> ast
|
||||
-> BriDocNumbered
|
||||
-> PPM ()
|
||||
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
|
||||
layoutBriDoc ast briDoc = do
|
||||
-- first step: transform the briDoc.
|
||||
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
|
||||
briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do
|
||||
traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw
|
||||
$ briDocToDoc
|
||||
$ unwrapBriDocNumbered
|
||||
$ briDoc
|
||||
-- bridoc transformation: remove alts
|
||||
transformAlts briDoc >>= mSet
|
||||
mGet >>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt . briDocToDoc
|
||||
mGet
|
||||
>>= traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
|
||||
. briDocToDoc
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyFloating >>= mSet
|
||||
mGet >>= traceIfDumpConf "bridoc post-floating" _dconf_dump_bridoc_simpl_floating . briDocToDoc
|
||||
mGet
|
||||
>>= traceIfDumpConf "bridoc post-floating"
|
||||
_dconf_dump_bridoc_simpl_floating
|
||||
. briDocToDoc
|
||||
-- bridoc transformation: par removal
|
||||
mGet <&> transformSimplifyPar >>= mSet
|
||||
mGet >>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par . briDocToDoc
|
||||
mGet
|
||||
>>= traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
|
||||
. briDocToDoc
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyColumns >>= mSet
|
||||
mGet >>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns . briDocToDoc
|
||||
mGet
|
||||
>>= traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
|
||||
. briDocToDoc
|
||||
-- -- bridoc transformation: indent
|
||||
mGet <&> transformSimplifyIndent >>= mSet
|
||||
mGet >>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent . briDocToDoc
|
||||
mGet >>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final . briDocToDoc
|
||||
mGet
|
||||
>>= traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
|
||||
. briDocToDoc
|
||||
mGet
|
||||
>>= traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
|
||||
. briDocToDoc
|
||||
-- -- convert to Simple type
|
||||
-- simpl <- mGet <&> transformToSimple
|
||||
-- return simpl
|
||||
|
||||
|
||||
anns :: ExactPrint.Types.Anns <- mAsk
|
||||
let filteredAnns = filterAnns ast anns
|
||||
|
||||
traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations $ annsDoc filteredAnns
|
||||
|
||||
traceIfDumpConf "bridoc annotations filtered/transformed"
|
||||
_dconf_dump_annotations
|
||||
$ annsDoc filteredAnns
|
||||
|
||||
let state = LayoutState
|
||||
{ _lstate_baseYs = [0]
|
||||
{ _lstate_baseYs = [0]
|
||||
, _lstate_curYOrAddNewline = Right 0 -- important that we use left here
|
||||
-- because moveToAnn stuff of the
|
||||
-- first node needs to do its
|
||||
-- thing properly.
|
||||
, _lstate_indLevels = [0]
|
||||
, _lstate_indLevelLinger = 0
|
||||
, _lstate_comments = filteredAnns
|
||||
, _lstate_commentCol = Nothing
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
, _lstate_indLevels = [0]
|
||||
, _lstate_indLevelLinger = 0
|
||||
, _lstate_comments = filteredAnns
|
||||
, _lstate_commentCol = Nothing
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
}
|
||||
|
||||
state' <- MultiRWSS.withMultiStateS state
|
||||
$ layoutBriDocM briDoc'
|
||||
|
||||
let remainingComments =
|
||||
extractAllComments =<< Map.elems (_lstate_comments state')
|
||||
remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
|
||||
|
||||
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
||||
|
||||
let
|
||||
remainingComments =
|
||||
extractAllComments =<< Map.elems (_lstate_comments state')
|
||||
remainingComments
|
||||
`forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fst)
|
||||
|
||||
return $ ()
|
||||
|
||||
|
||||
data AltCurPos = AltCurPos
|
||||
{ _acp_line :: Int -- chars in the current line
|
||||
, _acp_indent :: Int -- current indentation level
|
||||
|
|
@ -142,16 +156,16 @@ data AltLineModeState
|
|||
deriving (Show)
|
||||
|
||||
altLineModeDecay :: AltLineModeState -> AltLineModeState
|
||||
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
|
||||
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
|
||||
altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True
|
||||
altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone
|
||||
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
|
||||
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
|
||||
altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone
|
||||
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
|
||||
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
|
||||
|
||||
altLineModeRefresh :: AltLineModeState -> AltLineModeState
|
||||
altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone
|
||||
altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False
|
||||
altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL
|
||||
altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone
|
||||
altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False
|
||||
altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL
|
||||
altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction
|
||||
|
||||
mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos
|
||||
|
|
@ -159,7 +173,8 @@ mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of
|
|||
(AltLineModeStateContradiction, _) -> acp
|
||||
(AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x }
|
||||
(AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp
|
||||
(AltLineModeStateForceML{}, AltLineModeStateForceML{}) -> acp { _acp_forceMLFlag = s }
|
||||
(AltLineModeStateForceML{}, AltLineModeStateForceML{}) ->
|
||||
acp { _acp_forceMLFlag = s }
|
||||
_ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction }
|
||||
|
||||
-- removes any BDAlt's from the BriDoc
|
||||
|
|
@ -170,10 +185,12 @@ transformAlts
|
|||
)
|
||||
=> BriDocNumbered
|
||||
-> MultiRWSS.MultiRWS r w s BriDoc
|
||||
transformAlts briDoc
|
||||
= MultiRWSS.withMultiStateA
|
||||
(AltCurPos 0 0 0 AltLineModeStateNone)
|
||||
$ Memo.startEvalMemoT $ fmap unwrapBriDocNumbered $ rec $ briDoc
|
||||
transformAlts briDoc =
|
||||
MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone)
|
||||
$ Memo.startEvalMemoT
|
||||
$ fmap unwrapBriDocNumbered
|
||||
$ rec
|
||||
$ briDoc
|
||||
where
|
||||
-- this funtion is exponential by nature and cannot be improved in any
|
||||
-- way i can think of, and if tried. (stupid StableNames.)
|
||||
|
|
@ -459,7 +476,11 @@ transformAlts briDoc
|
|||
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)
|
||||
= line + sameLine <= confUnpack (_lconfig_cols lconf)
|
||||
|
||||
getSpacing :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m (LineModeValidity VerticalSpacing)
|
||||
getSpacing
|
||||
:: forall m
|
||||
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
|
||||
=> BriDocNumbered
|
||||
-> m (LineModeValidity VerticalSpacing)
|
||||
getSpacing !bridoc = rec bridoc
|
||||
where
|
||||
rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing)
|
||||
|
|
@ -637,8 +658,12 @@ getSpacing !bridoc = rec bridoc
|
|||
VerticalSpacingParNone -> 0
|
||||
VerticalSpacingParAlways i -> i
|
||||
|
||||
getSpacings :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
|
||||
=> Int -> BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
|
||||
getSpacings
|
||||
:: forall m
|
||||
. (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)
|
||||
=> Int
|
||||
-> BriDocNumbered
|
||||
-> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
|
||||
getSpacings limit bridoc = preFilterLimit <$> rec bridoc
|
||||
where
|
||||
preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]
|
||||
|
|
@ -883,21 +908,21 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
|
|||
|
||||
-- note that this is not total, and cannot be with that exact signature.
|
||||
mergeIndents :: BrIndent -> BrIndent -> BrIndent
|
||||
mergeIndents BrIndentNone x = x
|
||||
mergeIndents x BrIndentNone = x
|
||||
mergeIndents BrIndentNone x = x
|
||||
mergeIndents x BrIndentNone = x
|
||||
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j)
|
||||
mergeIndents _ _ = error "mergeIndents"
|
||||
mergeIndents _ _ = error "mergeIndents"
|
||||
|
||||
|
||||
-- TODO: move to uniplate upstream?
|
||||
-- aka `transform`
|
||||
transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
|
||||
transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
|
||||
transformUp f = g where g = f . Uniplate.descend g
|
||||
_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)
|
||||
_transformDown f = g where g = Uniplate.descend g . f
|
||||
transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
|
||||
transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
|
||||
transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x
|
||||
_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
|
||||
_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)
|
||||
_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x
|
||||
|
||||
|
||||
|
|
@ -1078,29 +1103,31 @@ transformSimplifyPar = transformUp $ \case
|
|||
-- Just $ BDPar ind1 line (BDLines [p1, p2])
|
||||
x@(BDPar _ (BDPar _ BDPar{} _) _) -> x
|
||||
BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) ->
|
||||
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1: indenteds))
|
||||
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
|
||||
BDPar ind1 (BDPar ind2 line p1) p2 ->
|
||||
BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])
|
||||
BDLines lines | any (\case BDLines{} -> True
|
||||
BDEmpty{} -> True
|
||||
_ -> False) lines ->
|
||||
case go lines of
|
||||
[] -> BDEmpty
|
||||
[x] -> x
|
||||
xs -> BDLines xs
|
||||
where
|
||||
go = (=<<) $ \case
|
||||
BDLines l -> go l
|
||||
BDEmpty -> []
|
||||
x -> [x]
|
||||
BDLines [] -> BDEmpty
|
||||
BDLines [x] -> x
|
||||
BDLines lines | any ( \case
|
||||
BDLines{} -> True
|
||||
BDEmpty{} -> True
|
||||
_ -> False
|
||||
)
|
||||
lines -> case go lines of
|
||||
[] -> BDEmpty
|
||||
[x] -> x
|
||||
xs -> BDLines xs
|
||||
where
|
||||
go = (=<<) $ \case
|
||||
BDLines l -> go l
|
||||
BDEmpty -> []
|
||||
x -> [x]
|
||||
BDLines [] -> BDEmpty
|
||||
BDLines [x] -> x
|
||||
-- BDCols sig cols | BDPar ind line indented <- List.last cols ->
|
||||
-- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented
|
||||
-- BDPar BrIndentNone line indented ->
|
||||
-- Just $ BDLines [line, indented]
|
||||
BDEnsureIndent BrIndentNone x -> x
|
||||
x -> x
|
||||
x -> x
|
||||
|
||||
isNotEmpty :: BriDoc -> Bool
|
||||
isNotEmpty BDEmpty = False
|
||||
|
|
@ -1243,28 +1270,29 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
|
|||
-- [ BDAddBaseY ind x
|
||||
-- , BDEnsureIndent ind indented
|
||||
-- ]
|
||||
BDLines lines | any (\case BDLines{} -> True
|
||||
BDEmpty{} -> True
|
||||
_ -> False) lines ->
|
||||
BDLines lines | any ( \case
|
||||
BDLines{} -> True
|
||||
BDEmpty{} -> True
|
||||
_ -> False
|
||||
)
|
||||
lines ->
|
||||
Just $ BDLines $ filter isNotEmpty $ lines >>= \case
|
||||
BDLines l -> l
|
||||
x -> [x]
|
||||
BDLines [l] ->
|
||||
Just l
|
||||
x -> [x]
|
||||
BDLines [l] -> Just l
|
||||
BDAddBaseY i (BDAnnotationPrior k x) ->
|
||||
Just $ BDAnnotationPrior k (BDAddBaseY i x)
|
||||
BDAddBaseY i (BDAnnotationKW k kw x) ->
|
||||
BDAddBaseY i (BDAnnotationKW k kw x) ->
|
||||
Just $ BDAnnotationKW k kw (BDAddBaseY i x)
|
||||
BDAddBaseY i (BDAnnotationRest k x) ->
|
||||
BDAddBaseY i (BDAnnotationRest k x) ->
|
||||
Just $ BDAnnotationRest k (BDAddBaseY i x)
|
||||
BDAddBaseY i (BDSeq l) ->
|
||||
Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]
|
||||
BDAddBaseY i (BDCols sig l) ->
|
||||
Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
|
||||
BDAddBaseY _ lit@BDLit{} ->
|
||||
Just lit
|
||||
BDAddBaseY _ lit@BDLit{} -> Just lit
|
||||
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
briDocLineLength :: BriDoc -> Int
|
||||
|
|
@ -1273,35 +1301,35 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
|
|||
-- appended at the current position.
|
||||
where
|
||||
rec = \case
|
||||
BDEmpty -> return $ 0
|
||||
BDLit t -> StateS.put False $> Text.length t
|
||||
BDSeq bds -> sum <$> rec `mapM` bds
|
||||
BDCols _ bds -> sum <$> rec `mapM` bds
|
||||
BDEmpty -> return $ 0
|
||||
BDLit t -> StateS.put False $> Text.length t
|
||||
BDSeq bds -> sum <$> rec `mapM` bds
|
||||
BDCols _ bds -> sum <$> rec `mapM` bds
|
||||
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
|
||||
BDAddBaseY _ bd -> rec bd
|
||||
BDBaseYPushCur bd -> rec bd
|
||||
BDBaseYPop bd -> rec bd
|
||||
BDAddBaseY _ bd -> rec bd
|
||||
BDBaseYPushCur bd -> rec bd
|
||||
BDBaseYPop bd -> rec bd
|
||||
BDIndentLevelPushCur bd -> rec bd
|
||||
BDIndentLevelPop bd -> rec bd
|
||||
BDPar _ line _ -> rec line
|
||||
BDAlt{} -> error "briDocLineLength BDAlt"
|
||||
BDForceMultiline bd -> rec bd
|
||||
BDForceSingleline bd -> rec bd
|
||||
BDForwardLineMode bd -> rec bd
|
||||
BDExternal _ _ _ t -> return $ Text.length t
|
||||
BDAnnotationPrior _ bd -> rec bd
|
||||
BDAnnotationKW _ _ bd -> rec bd
|
||||
BDAnnotationRest _ bd -> rec bd
|
||||
BDLines ls@(_:_) -> do
|
||||
BDIndentLevelPop bd -> rec bd
|
||||
BDPar _ line _ -> rec line
|
||||
BDAlt{} -> error "briDocLineLength BDAlt"
|
||||
BDForceMultiline bd -> rec bd
|
||||
BDForceSingleline bd -> rec bd
|
||||
BDForwardLineMode bd -> rec bd
|
||||
BDExternal _ _ _ t -> return $ Text.length t
|
||||
BDAnnotationPrior _ bd -> rec bd
|
||||
BDAnnotationKW _ _ bd -> rec bd
|
||||
BDAnnotationRest _ bd -> rec bd
|
||||
BDLines ls@(_:_) -> do
|
||||
x <- StateS.get
|
||||
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
|
||||
BDLines [] -> error "briDocLineLength BDLines []"
|
||||
BDEnsureIndent _ bd -> rec bd
|
||||
BDProhibitMTEL bd -> rec bd
|
||||
BDSetParSpacing bd -> rec bd
|
||||
BDForceParSpacing bd -> rec bd
|
||||
BDNonBottomSpacing bd -> rec bd
|
||||
BDDebug _ bd -> rec bd
|
||||
BDLines [] -> error "briDocLineLength BDLines []"
|
||||
BDEnsureIndent _ bd -> rec bd
|
||||
BDProhibitMTEL bd -> rec bd
|
||||
BDSetParSpacing bd -> rec bd
|
||||
BDForceParSpacing bd -> rec bd
|
||||
BDNonBottomSpacing bd -> rec bd
|
||||
BDDebug _ bd -> rec bd
|
||||
|
||||
layoutBriDocM
|
||||
:: forall w m
|
||||
|
|
|
|||
|
|
@ -73,36 +73,42 @@ import Data.Coerce ( Coercible, coerce )
|
|||
configParser :: CmdParser Identity out (ConfigF Option)
|
||||
configParser = do
|
||||
-- TODO: why does the default not trigger; ind never should be []!!
|
||||
ind <- addFlagReadParam "" ["indent"] "AMOUNT"
|
||||
(flagHelpStr "spaces per indentation level")
|
||||
cols <- addFlagReadParam "" ["columns"] "AMOUNT"
|
||||
(flagHelpStr "target max columns (80 is an old default for this)")
|
||||
importCol <- addFlagReadParam "" ["import-col"] "N"
|
||||
(flagHelpStr "column to align import lists at")
|
||||
ind <- addFlagReadParam "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
|
||||
cols <- addFlagReadParam "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")
|
||||
importCol <- addFlagReadParam "" ["import-col"] "N" (flagHelpStr "column to align import lists at")
|
||||
|
||||
dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)")
|
||||
dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")
|
||||
dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
|
||||
dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
|
||||
dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")
|
||||
dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")
|
||||
dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")
|
||||
dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")
|
||||
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
|
||||
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
|
||||
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
|
||||
dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)")
|
||||
dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")
|
||||
dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
|
||||
dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
|
||||
dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")
|
||||
dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")
|
||||
dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")
|
||||
dumpBriDocFloating <- addSimpleBoolFlag ""
|
||||
["dump-bridoc-floating"]
|
||||
(flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")
|
||||
dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")
|
||||
dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")
|
||||
dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")
|
||||
|
||||
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible")
|
||||
wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
|
||||
wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
|
||||
|
||||
optionsGhc <- addFlagStringParam
|
||||
""
|
||||
["ghc-options"]
|
||||
"STRING"
|
||||
( flagHelp
|
||||
$ parDoc
|
||||
"allows to define default language extensions. The parameter is forwarded to ghc. Note that currently these options are applied _after_ the pragmas read in from the input."
|
||||
)
|
||||
|
||||
optionsGhc <- addFlagStringParam "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc. Note that currently these options are applied _after_ the pragmas read in from the input.")
|
||||
|
||||
return $ Config
|
||||
{ _conf_debug = DebugConfig
|
||||
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
|
||||
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
|
||||
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
|
||||
, _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
|
||||
{ _conf_debug = DebugConfig
|
||||
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
|
||||
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
|
||||
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
|
||||
, _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
|
||||
, _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw
|
||||
, _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt
|
||||
, _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar
|
||||
|
|
@ -111,7 +117,7 @@ configParser = do
|
|||
, _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent
|
||||
, _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal
|
||||
}
|
||||
, _conf_layout = LayoutConfig
|
||||
, _conf_layout = LayoutConfig
|
||||
{ _lconfig_cols = optionConcat cols
|
||||
, _lconfig_indentPolicy = mempty
|
||||
, _lconfig_indentAmount = optionConcat ind
|
||||
|
|
@ -126,18 +132,16 @@ configParser = do
|
|||
, _econf_Werror = wrapLast $ falseToNothing wError
|
||||
, _econf_CPPMode = mempty
|
||||
}
|
||||
, _conf_forward = ForwardOptions
|
||||
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs
|
||||
| not $ null optionsGhc
|
||||
]
|
||||
, _conf_forward = ForwardOptions
|
||||
{ _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ]
|
||||
}
|
||||
}
|
||||
where falseToNothing = Option . Bool.bool Nothing (Just True)
|
||||
wrapLast :: Option a -> Option (Semigroup.Last a)
|
||||
wrapLast = fmap Semigroup.Last
|
||||
optionConcat
|
||||
:: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a)
|
||||
optionConcat = mconcat . fmap (pure . pure)
|
||||
where
|
||||
falseToNothing = Option . Bool.bool Nothing (Just True)
|
||||
wrapLast :: Option a -> Option (Semigroup.Last a)
|
||||
wrapLast = fmap Semigroup.Last
|
||||
optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a)
|
||||
optionConcat = mconcat . fmap (pure . pure)
|
||||
|
||||
-- configParser :: Parser Config
|
||||
-- configParser = Config
|
||||
|
|
|
|||
|
|
@ -227,38 +227,38 @@ data CPPMode = CPPModeAbort -- abort program on seeing -XCPP
|
|||
|
||||
staticDefaultConfig :: Config
|
||||
staticDefaultConfig = Config
|
||||
{ _conf_debug = DebugConfig
|
||||
{ _dconf_dump_config = coerce False
|
||||
, _dconf_dump_annotations = coerce False
|
||||
, _dconf_dump_ast_unknown = coerce False
|
||||
, _dconf_dump_ast_full = coerce False
|
||||
, _dconf_dump_bridoc_raw = coerce False
|
||||
, _dconf_dump_bridoc_simpl_alt = coerce False
|
||||
, _dconf_dump_bridoc_simpl_floating = coerce False
|
||||
, _dconf_dump_bridoc_simpl_par = coerce False
|
||||
, _dconf_dump_bridoc_simpl_columns = coerce False
|
||||
, _dconf_dump_bridoc_simpl_indent = coerce False
|
||||
, _dconf_dump_bridoc_final = coerce False
|
||||
}
|
||||
, _conf_layout = LayoutConfig
|
||||
{ _lconfig_cols = coerce (80 :: Int)
|
||||
, _lconfig_indentPolicy = coerce IndentPolicyFree
|
||||
, _lconfig_indentAmount = coerce (2 :: Int)
|
||||
, _lconfig_indentWhereSpecial = coerce True
|
||||
, _lconfig_indentListSpecial = coerce True
|
||||
, _lconfig_importColumn = coerce (60 :: Int)
|
||||
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
|
||||
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
|
||||
}
|
||||
, _conf_errorHandling = ErrorHandlingConfig
|
||||
{ _econf_produceOutputOnErrors = coerce False
|
||||
, _econf_Werror = coerce False
|
||||
, _econf_CPPMode = coerce CPPModeAbort
|
||||
}
|
||||
, _conf_forward = ForwardOptions
|
||||
{ _options_ghc = Identity []
|
||||
}
|
||||
{ _conf_debug = DebugConfig
|
||||
{ _dconf_dump_config = coerce False
|
||||
, _dconf_dump_annotations = coerce False
|
||||
, _dconf_dump_ast_unknown = coerce False
|
||||
, _dconf_dump_ast_full = coerce False
|
||||
, _dconf_dump_bridoc_raw = coerce False
|
||||
, _dconf_dump_bridoc_simpl_alt = coerce False
|
||||
, _dconf_dump_bridoc_simpl_floating = coerce False
|
||||
, _dconf_dump_bridoc_simpl_par = coerce False
|
||||
, _dconf_dump_bridoc_simpl_columns = coerce False
|
||||
, _dconf_dump_bridoc_simpl_indent = coerce False
|
||||
, _dconf_dump_bridoc_final = coerce False
|
||||
}
|
||||
, _conf_layout = LayoutConfig
|
||||
{ _lconfig_cols = coerce (80 :: Int)
|
||||
, _lconfig_indentPolicy = coerce IndentPolicyFree
|
||||
, _lconfig_indentAmount = coerce (2 :: Int)
|
||||
, _lconfig_indentWhereSpecial = coerce True
|
||||
, _lconfig_indentListSpecial = coerce True
|
||||
, _lconfig_importColumn = coerce (60 :: Int)
|
||||
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
|
||||
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
|
||||
}
|
||||
, _conf_errorHandling = ErrorHandlingConfig
|
||||
{ _econf_produceOutputOnErrors = coerce False
|
||||
, _econf_Werror = coerce False
|
||||
, _econf_CPPMode = coerce CPPModeAbort
|
||||
}
|
||||
, _conf_forward = ForwardOptions
|
||||
{ _options_ghc = Identity []
|
||||
}
|
||||
}
|
||||
|
||||
-- TODO: automate writing instances for this to get
|
||||
-- the above Monoid instance for free.
|
||||
|
|
|
|||
|
|
@ -149,31 +149,34 @@ commentAnnFixTransformGlob ast = do
|
|||
let priors = ExactPrint.annPriorComments ann1
|
||||
follows = ExactPrint.annFollowingComments ann1
|
||||
assocs = ExactPrint.annsDP ann1
|
||||
let processCom
|
||||
:: (ExactPrint.Comment, ExactPrint.DeltaPos)
|
||||
-> ExactPrint.TransformT Identity Bool
|
||||
processCom comPair@(com, _) =
|
||||
case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of
|
||||
GHC.UnhelpfulLoc{} -> return True -- retain comment at current node.
|
||||
GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of
|
||||
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
|
||||
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
|
||||
move $> False
|
||||
(x,y) | x==y -> move $> False
|
||||
_ -> return True
|
||||
where
|
||||
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
|
||||
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
|
||||
loc1 = GHC.srcSpanStart annKeyLoc1
|
||||
loc2 = GHC.srcSpanStart annKeyLoc2
|
||||
move = ExactPrint.modifyAnnsT $ \anns ->
|
||||
let ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
|
||||
ann2' = ann2
|
||||
{ ExactPrint.annFollowingComments =
|
||||
ExactPrint.annFollowingComments ann2 ++ [comPair]
|
||||
}
|
||||
in Map.insert annKey2 ann2' anns
|
||||
_ -> return True -- retain comment at current node.
|
||||
let
|
||||
processCom
|
||||
:: (ExactPrint.Comment, ExactPrint.DeltaPos)
|
||||
-> ExactPrint.TransformT Identity Bool
|
||||
processCom comPair@(com, _) =
|
||||
case GHC.srcSpanStart $ ExactPrint.commentIdentifier com of
|
||||
GHC.UnhelpfulLoc{} -> return True -- retain comment at current node.
|
||||
GHC.RealSrcLoc comLoc -> case Map.lookupLE comLoc annsMap of
|
||||
Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of
|
||||
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
|
||||
move $> False
|
||||
(x, y) | x == y -> move $> False
|
||||
_ -> return True
|
||||
where
|
||||
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
|
||||
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
|
||||
loc1 = GHC.srcSpanStart annKeyLoc1
|
||||
loc2 = GHC.srcSpanStart annKeyLoc2
|
||||
move = ExactPrint.modifyAnnsT $ \anns ->
|
||||
let
|
||||
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
|
||||
ann2' = ann2
|
||||
{ ExactPrint.annFollowingComments =
|
||||
ExactPrint.annFollowingComments ann2 ++ [comPair]
|
||||
}
|
||||
in
|
||||
Map.insert annKey2 ann2' anns
|
||||
_ -> return True -- retain comment at current node.
|
||||
priors' <- flip filterM priors processCom
|
||||
follows' <- flip filterM follows $ processCom
|
||||
assocs' <- flip filterM assocs $ \case
|
||||
|
|
|
|||
|
|
@ -135,11 +135,13 @@ traceLocal x = do
|
|||
traceLocal _ = return ()
|
||||
#endif
|
||||
|
||||
processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiReader ExactPrint.Types.Anns m)
|
||||
=> GenLocated SrcSpan ast
|
||||
-> m ()
|
||||
processDefault
|
||||
:: ( ExactPrint.Annotate.Annotate ast
|
||||
, MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiReader ExactPrint.Types.Anns m
|
||||
)
|
||||
=> GenLocated SrcSpan ast
|
||||
-> m ()
|
||||
processDefault x = do
|
||||
anns <- mAsk
|
||||
let str = ExactPrint.exactPrint x anns
|
||||
|
|
@ -152,55 +154,66 @@ processDefault x = do
|
|||
"\n" -> return ()
|
||||
_ -> mTell $ Text.Builder.fromString $ str
|
||||
|
||||
briDocByExact :: (ExactPrint.Annotate.Annotate ast) => GenLocated SrcSpan ast -> ToBriDocM BriDocNumbered
|
||||
-- | 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)
|
||||
=> GenLocated SrcSpan ast
|
||||
-> ToBriDocM BriDocNumbered
|
||||
briDocByExact ast = do
|
||||
anns <- mAsk
|
||||
traceIfDumpConf "ast" _dconf_dump_ast_unknown
|
||||
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
||||
traceIfDumpConf "ast"
|
||||
_dconf_dump_ast_unknown
|
||||
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
||||
docExt ast anns True
|
||||
|
||||
briDocByExactNoComment :: (ExactPrint.Annotate.Annotate ast) => GenLocated SrcSpan ast -> ToBriDocM BriDocNumbered
|
||||
-- | Use ExactPrint's output for this node.
|
||||
briDocByExactNoComment
|
||||
:: (ExactPrint.Annotate.Annotate ast)
|
||||
=> GenLocated SrcSpan ast
|
||||
-> ToBriDocM BriDocNumbered
|
||||
briDocByExactNoComment ast = do
|
||||
anns <- mAsk
|
||||
traceIfDumpConf "ast" _dconf_dump_ast_unknown
|
||||
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
||||
traceIfDumpConf "ast"
|
||||
_dconf_dump_ast_unknown
|
||||
(printTreeWithCustom 100 (customLayouterF anns) ast)
|
||||
docExt ast anns False
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
lrdrNameToTextAnn :: ( MonadMultiReader Config m
|
||||
, MonadMultiReader (Map AnnKey Annotation) m
|
||||
)
|
||||
=> GenLocated SrcSpan RdrName
|
||||
-> m Text
|
||||
lrdrNameToTextAnn
|
||||
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
|
||||
=> GenLocated SrcSpan RdrName
|
||||
-> m Text
|
||||
lrdrNameToTextAnn ast@(L _ n) = do
|
||||
anns <- mAsk
|
||||
let t = rdrNameToText n
|
||||
let hasUni x (ExactPrint.Types.G y, _) = x==y
|
||||
hasUni _ _ = False
|
||||
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
|
||||
Nothing -> t
|
||||
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
|
||||
Exact{} | t == Text.pack "()" -> t
|
||||
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
|
||||
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
|
||||
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
|
||||
_ | otherwise -> t
|
||||
|
||||
lrdrNameToTextAnnTypeEqualityIsSpecial
|
||||
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
|
||||
|
|
@ -209,18 +222,19 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
|
|||
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
|
||||
x <- lrdrNameToTextAnn ast
|
||||
return $ if x == Text.pack "Data.Type.Equality~"
|
||||
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
|
||||
else x
|
||||
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
|
||||
else x
|
||||
|
||||
askIndent :: (MonadMultiReader Config m) => m Int
|
||||
askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
|
||||
|
||||
layoutWriteAppend :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> Text
|
||||
-> m ()
|
||||
layoutWriteAppend
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> Text
|
||||
-> m ()
|
||||
layoutWriteAppend t = do
|
||||
traceLocal ("layoutWriteAppend", t)
|
||||
state <- mGet
|
||||
|
|
@ -250,32 +264,32 @@ layoutWriteAppend t = do
|
|||
, _lstate_addSepSpace = Nothing
|
||||
}
|
||||
|
||||
layoutWriteAppendSpaces :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> Int
|
||||
-> m ()
|
||||
layoutWriteAppendSpaces
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> Int
|
||||
-> m ()
|
||||
layoutWriteAppendSpaces i = do
|
||||
traceLocal ("layoutWriteAppendSpaces", i)
|
||||
unless (i==0) $ do
|
||||
unless (i == 0) $ do
|
||||
state <- mGet
|
||||
mSet $ state { _lstate_addSepSpace = Just
|
||||
$ maybe i (+i)
|
||||
$ _lstate_addSepSpace state
|
||||
}
|
||||
mSet $ state
|
||||
{ _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state
|
||||
}
|
||||
|
||||
layoutWriteAppendMultiline :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> Text
|
||||
-> m ()
|
||||
layoutWriteAppendMultiline
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> Text
|
||||
-> m ()
|
||||
layoutWriteAppendMultiline t = do
|
||||
traceLocal ("layoutWriteAppendMultiline", t)
|
||||
case Text.lines t of
|
||||
[] ->
|
||||
layoutWriteAppend t -- need to write empty, too.
|
||||
[] -> layoutWriteAppend t -- need to write empty, too.
|
||||
(l:lr) -> do
|
||||
layoutWriteAppend l
|
||||
lr `forM_` \x -> do
|
||||
|
|
@ -283,17 +297,18 @@ layoutWriteAppendMultiline t = do
|
|||
layoutWriteAppend x
|
||||
|
||||
-- adds a newline and adds spaces to reach the base column.
|
||||
layoutWriteNewlineBlock :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> m ()
|
||||
layoutWriteNewlineBlock
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> m ()
|
||||
layoutWriteNewlineBlock = do
|
||||
traceLocal ("layoutWriteNewlineBlock")
|
||||
state <- mGet
|
||||
mSet $ state { _lstate_curYOrAddNewline = Right 1
|
||||
, _lstate_addSepSpace = Just $ lstate_baseY state
|
||||
, _lstate_inhibitMTEL = False
|
||||
, _lstate_addSepSpace = Just $ lstate_baseY state
|
||||
, _lstate_inhibitMTEL = False
|
||||
}
|
||||
|
||||
-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
|
||||
|
|
@ -310,13 +325,12 @@ layoutWriteNewlineBlock = do
|
|||
-- else _lstate_indLevelLinger state + i - _lstate_curY state
|
||||
-- }
|
||||
|
||||
layoutSetCommentCol :: ( MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m )
|
||||
=> m ()
|
||||
layoutSetCommentCol
|
||||
:: (MonadMultiState LayoutState m, MonadMultiWriter (Seq String) m) => m ()
|
||||
layoutSetCommentCol = do
|
||||
state <- mGet
|
||||
let col = case _lstate_curYOrAddNewline state of
|
||||
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
|
||||
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
|
||||
Right{} -> lstate_baseY state
|
||||
traceLocal ("layoutSetCommentCol", col)
|
||||
unless (Data.Maybe.isJust $ _lstate_commentCol state)
|
||||
|
|
@ -337,90 +351,93 @@ layoutMoveToCommentPos y x = do
|
|||
then do
|
||||
mSet state
|
||||
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
|
||||
Left i -> if y==0 then Left i else Right y
|
||||
Left i -> if y == 0 then Left i else Right y
|
||||
Right{} -> Right y
|
||||
, _lstate_addSepSpace = Just $ case _lstate_curYOrAddNewline state of
|
||||
Left{} -> if y==0
|
||||
then x
|
||||
else _lstate_indLevelLinger state + x
|
||||
Right{} -> _lstate_indLevelLinger state + x
|
||||
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
|
||||
Right{} -> _lstate_indLevelLinger state + x
|
||||
}
|
||||
else do
|
||||
mSet state
|
||||
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
|
||||
Left i -> if y==0 then Left i else Right y
|
||||
Left i -> if y == 0 then Left i else Right y
|
||||
Right{} -> Right y
|
||||
, _lstate_addSepSpace = Just $ if y==0
|
||||
then x
|
||||
else _lstate_indLevelLinger state + x
|
||||
, _lstate_addSepSpace = Just
|
||||
$ if y == 0 then x else _lstate_indLevelLinger state + x
|
||||
, _lstate_commentCol = Just $ case _lstate_curYOrAddNewline state of
|
||||
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
|
||||
Right{} -> lstate_baseY state
|
||||
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
|
||||
Right{} -> lstate_baseY state
|
||||
}
|
||||
|
||||
-- | does _not_ add spaces to again reach the current base column.
|
||||
layoutWriteNewline :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> m ()
|
||||
layoutWriteNewline
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> m ()
|
||||
layoutWriteNewline = do
|
||||
traceLocal ("layoutWriteNewline")
|
||||
state <- mGet
|
||||
mSet $ state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
|
||||
Left{} -> Right 1
|
||||
Right i -> Right (i+1)
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
}
|
||||
mSet $ state
|
||||
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
|
||||
Left{} -> Right 1
|
||||
Right i -> Right (i + 1)
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
}
|
||||
|
||||
layoutWriteEnsureNewlineBlock :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> m ()
|
||||
layoutWriteEnsureNewlineBlock
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> m ()
|
||||
layoutWriteEnsureNewlineBlock = do
|
||||
traceLocal ("layoutWriteEnsureNewlineBlock")
|
||||
state <- mGet
|
||||
mSet $ state
|
||||
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
|
||||
Left{} -> Right 1
|
||||
Right i -> Right $ max 1 i
|
||||
, _lstate_addSepSpace = Just $ lstate_baseY state
|
||||
, _lstate_inhibitMTEL = False
|
||||
, _lstate_commentCol = Nothing
|
||||
Left{} -> Right 1
|
||||
Right i -> Right $ max 1 i
|
||||
, _lstate_addSepSpace = Just $ lstate_baseY state
|
||||
, _lstate_inhibitMTEL = False
|
||||
, _lstate_commentCol = Nothing
|
||||
}
|
||||
|
||||
layoutWriteEnsureBlock :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> m ()
|
||||
layoutWriteEnsureBlock
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> m ()
|
||||
layoutWriteEnsureBlock = do
|
||||
traceLocal ("layoutWriteEnsureBlock")
|
||||
state <- mGet
|
||||
let
|
||||
diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of
|
||||
(Nothing, Left i) -> lstate_baseY state - i
|
||||
(Nothing, Left i ) -> lstate_baseY state - i
|
||||
(Nothing, Right{}) -> lstate_baseY state
|
||||
(Just sp, Left i) -> max sp (lstate_baseY state - i)
|
||||
(Just sp, Left i ) -> max sp (lstate_baseY state - i)
|
||||
(Just sp, Right{}) -> max sp (lstate_baseY state)
|
||||
-- when (diff>0) $ layoutWriteNewlineBlock
|
||||
when (diff > 0) $ do
|
||||
mSet $ state { _lstate_addSepSpace = Just $ diff }
|
||||
|
||||
layoutWriteEnsureAbsoluteN :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> Int -> m ()
|
||||
layoutWriteEnsureAbsoluteN
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> Int
|
||||
-> m ()
|
||||
layoutWriteEnsureAbsoluteN n = do
|
||||
state <- mGet
|
||||
let diff = case _lstate_curYOrAddNewline state of
|
||||
Left i -> n-i
|
||||
Left i -> n - i
|
||||
Right{} -> n
|
||||
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
|
||||
when (diff>0) $ do
|
||||
when (diff > 0) $ do
|
||||
mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to
|
||||
-- at least (Just 1), so we won't
|
||||
-- overwrite any old value in any
|
||||
|
|
@ -448,7 +465,7 @@ layoutIndentLevelPushInternal
|
|||
layoutIndentLevelPushInternal i = do
|
||||
traceLocal ("layoutIndentLevelPushInternal", i)
|
||||
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
|
||||
, _lstate_indLevels = i : _lstate_indLevels s
|
||||
, _lstate_indLevels = i : _lstate_indLevels s
|
||||
}
|
||||
|
||||
layoutIndentLevelPopInternal
|
||||
|
|
@ -456,7 +473,7 @@ layoutIndentLevelPopInternal
|
|||
layoutIndentLevelPopInternal = do
|
||||
traceLocal ("layoutIndentLevelPopInternal")
|
||||
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
|
||||
, _lstate_indLevels = List.tail $ _lstate_indLevels s
|
||||
, _lstate_indLevels = List.tail $ _lstate_indLevels s
|
||||
}
|
||||
|
||||
layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m
|
||||
|
|
@ -469,13 +486,14 @@ layoutRemoveIndentLevelLinger = do
|
|||
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
|
||||
}
|
||||
|
||||
layoutWithAddBaseCol :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
,MonadMultiReader Config m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> m ()
|
||||
-> m ()
|
||||
layoutWithAddBaseCol
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiReader Config m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> m ()
|
||||
-> m ()
|
||||
layoutWithAddBaseCol m = do
|
||||
#if INSERTTRACES
|
||||
tellDebugMessShow ("layoutWithAddBaseCol")
|
||||
|
|
@ -521,13 +539,14 @@ layoutWithAddBaseColNBlock amount m = do
|
|||
m
|
||||
layoutBaseYPopInternal
|
||||
|
||||
layoutWithAddBaseColN :: (MonadMultiWriter
|
||||
Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> Int
|
||||
-> m ()
|
||||
-> m ()
|
||||
layoutWithAddBaseColN
|
||||
:: ( MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> Int
|
||||
-> m ()
|
||||
-> m ()
|
||||
layoutWithAddBaseColN amount m = do
|
||||
#if INSERTTRACES
|
||||
tellDebugMessShow ("layoutWithAddBaseColN", amount)
|
||||
|
|
@ -543,10 +562,11 @@ layoutBaseYPushCur = do
|
|||
traceLocal ("layoutBaseYPushCur")
|
||||
state <- mGet
|
||||
case _lstate_commentCol state of
|
||||
Nothing -> case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
|
||||
(Left i, Just j) -> layoutBaseYPushInternal (i+j)
|
||||
(Left i, Nothing) -> layoutBaseYPushInternal i
|
||||
(Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
|
||||
Nothing ->
|
||||
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
|
||||
(Left i , Just j ) -> layoutBaseYPushInternal (i + j)
|
||||
(Left i , Nothing) -> layoutBaseYPushInternal i
|
||||
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state
|
||||
Just cCol -> layoutBaseYPushInternal cCol
|
||||
|
||||
layoutBaseYPop
|
||||
|
|
@ -561,9 +581,9 @@ layoutIndentLevelPushCur = do
|
|||
traceLocal ("layoutIndentLevelPushCur")
|
||||
state <- mGet
|
||||
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
|
||||
(Left i, Just j) -> i + j
|
||||
(Left i, Nothing) -> i
|
||||
(Right{}, Just j) -> j
|
||||
(Left i , Just j ) -> i + j
|
||||
(Left i , Nothing) -> i
|
||||
(Right{}, Just j ) -> j
|
||||
(Right{}, Nothing) -> 0
|
||||
layoutIndentLevelPushInternal y
|
||||
layoutBaseYPushInternal y
|
||||
|
|
@ -588,7 +608,8 @@ layoutAddSepSpace = do
|
|||
tellDebugMessShow ("layoutAddSepSpace")
|
||||
#endif
|
||||
state <- mGet
|
||||
mSet $ state { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state }
|
||||
mSet $ state
|
||||
{ _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state }
|
||||
|
||||
-- TODO: when refactoring is complete, the other version of this method
|
||||
-- can probably be removed.
|
||||
|
|
@ -604,22 +625,25 @@ moveToExactAnn annKey = do
|
|||
traceLocal ("moveToExactAnn", annKey)
|
||||
anns <- mAsk
|
||||
case Map.lookup annKey anns of
|
||||
Nothing -> return ()
|
||||
Nothing -> return ()
|
||||
Just ann -> do
|
||||
-- curY <- mGet <&> _lstate_curY
|
||||
let ExactPrint.Types.DP (y, _x) = ExactPrint.Types.annEntryDelta ann
|
||||
-- mModify $ \state -> state { _lstate_addNewline = Just x }
|
||||
mModify $ \state ->
|
||||
let upd = case _lstate_curYOrAddNewline state of
|
||||
Left i -> if y==0 then Left i else Right y
|
||||
Left i -> if y == 0 then Left i else Right y
|
||||
Right i -> Right $ max y i
|
||||
in state
|
||||
{ _lstate_curYOrAddNewline = upd
|
||||
, _lstate_addSepSpace = if Data.Either.isRight upd
|
||||
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just (lstate_baseY state)
|
||||
else Nothing
|
||||
, _lstate_commentCol = Nothing
|
||||
}
|
||||
in state
|
||||
{ _lstate_curYOrAddNewline = upd
|
||||
, _lstate_addSepSpace = if Data.Either.isRight upd
|
||||
then
|
||||
_lstate_commentCol state
|
||||
<|> _lstate_addSepSpace state
|
||||
<|> Just (lstate_baseY state)
|
||||
else Nothing
|
||||
, _lstate_commentCol = Nothing
|
||||
}
|
||||
-- fixMoveToLineByIsNewline :: MonadMultiState
|
||||
-- LayoutState m => Int -> m Int
|
||||
-- fixMoveToLineByIsNewline x = do
|
||||
|
|
@ -628,18 +652,22 @@ moveToExactAnn annKey = do
|
|||
-- then x-1
|
||||
-- else x
|
||||
|
||||
ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m
|
||||
=> ExactPrint.Types.DeltaPos
|
||||
-> m ()
|
||||
ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do
|
||||
ppmMoveToExactLoc
|
||||
:: MonadMultiWriter Text.Builder.Builder m
|
||||
=> ExactPrint.Types.DeltaPos
|
||||
-> m ()
|
||||
ppmMoveToExactLoc (ExactPrint.Types.DP (x, y)) = do
|
||||
replicateM_ x $ mTell $ Text.Builder.fromString "\n"
|
||||
replicateM_ y $ mTell $ Text.Builder.fromString " "
|
||||
|
||||
layoutWritePriorComments :: (Data.Data.Data ast,
|
||||
MonadMultiWriter Text.Builder.Builder m,
|
||||
MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m)
|
||||
=> GenLocated SrcSpan ast -> m ()
|
||||
layoutWritePriorComments
|
||||
:: ( Data.Data.Data ast
|
||||
, MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiState LayoutState m
|
||||
, MonadMultiWriter (Seq String) m
|
||||
)
|
||||
=> GenLocated SrcSpan ast
|
||||
-> m ()
|
||||
layoutWritePriorComments ast = do
|
||||
mAnn <- do
|
||||
state <- mGet
|
||||
|
|
@ -743,49 +771,43 @@ extractAllComments
|
|||
extractAllComments ann =
|
||||
ExactPrint.annPriorComments ann
|
||||
++ ExactPrint.annFollowingComments ann
|
||||
++ (ExactPrint.annsDP ann >>= \case
|
||||
++ ( ExactPrint.annsDP ann >>= \case
|
||||
(ExactPrint.AnnComment com, dp) -> [(com, dp)]
|
||||
_ -> []
|
||||
_ -> []
|
||||
)
|
||||
|
||||
|
||||
foldedAnnKeys :: Data.Data.Data ast
|
||||
=> ast
|
||||
-> Set ExactPrint.AnnKey
|
||||
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
|
||||
foldedAnnKeys ast = everything
|
||||
Set.union
|
||||
(\x -> maybe
|
||||
Set.empty
|
||||
Set.singleton
|
||||
[ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x
|
||||
| locTyCon == typeRepTyCon (typeOf x)
|
||||
, l <- gmapQi 0 cast x
|
||||
]
|
||||
( \x -> maybe Set.empty
|
||||
Set.singleton
|
||||
[ gmapQi 1 (\t -> ExactPrint.mkAnnKey $ L l t) x
|
||||
| locTyCon == typeRepTyCon (typeOf x)
|
||||
, l <- gmapQi 0 cast x
|
||||
]
|
||||
)
|
||||
ast
|
||||
where
|
||||
locTyCon = typeRepTyCon (typeOf (L () ()))
|
||||
|
||||
filterAnns :: Data.Data.Data ast
|
||||
=> ast
|
||||
-> ExactPrint.Anns
|
||||
-> ExactPrint.Anns
|
||||
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
|
||||
filterAnns ast anns =
|
||||
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns
|
||||
|
||||
hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool
|
||||
hasAnyCommentsBelow ast@(L l _) = do
|
||||
anns <- filterAnns ast <$> mAsk
|
||||
return $ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
|
||||
$ (=<<) extractAllComments
|
||||
$ Map.elems
|
||||
$ anns
|
||||
return
|
||||
$ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l)
|
||||
$ (=<<) extractAllComments
|
||||
$ Map.elems
|
||||
$ anns
|
||||
|
||||
-- new BriDoc stuff
|
||||
|
||||
allocateNode :: MonadMultiState NodeAllocIndex m
|
||||
=> BriDocFInt
|
||||
-> m BriDocNumbered
|
||||
allocateNode
|
||||
:: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered
|
||||
allocateNode bd = do
|
||||
i <- allocNodeIndex
|
||||
return (i, bd)
|
||||
|
|
@ -793,7 +815,7 @@ allocateNode bd = do
|
|||
allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int
|
||||
allocNodeIndex = do
|
||||
NodeAllocIndex i <- mGet
|
||||
mSet $ NodeAllocIndex (i+1)
|
||||
mSet $ NodeAllocIndex (i + 1)
|
||||
return i
|
||||
|
||||
-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered
|
||||
|
|
@ -901,13 +923,17 @@ docEmpty = allocateNode BDFEmpty
|
|||
docLit :: Text -> ToBriDocM BriDocNumbered
|
||||
docLit t = allocateNode $ BDFLit t
|
||||
|
||||
docExt :: (ExactPrint.Annotate.Annotate ast)
|
||||
=> GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> Bool -> ToBriDocM BriDocNumbered
|
||||
docExt
|
||||
:: (ExactPrint.Annotate.Annotate ast)
|
||||
=> GenLocated SrcSpan 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)
|
||||
(ExactPrint.Types.mkAnnKey x)
|
||||
(foldedAnnKeys x)
|
||||
shouldAddComment
|
||||
(Text.pack $ ExactPrint.exactPrint x anns)
|
||||
|
||||
docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
||||
docAlt l = allocateNode . BDFAlt =<< sequence l
|
||||
|
|
@ -955,7 +981,10 @@ docAnnotationPrior
|
|||
docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
|
||||
|
||||
docAnnotationKW
|
||||
:: AnnKey -> Maybe AnnKeywordId -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
||||
:: AnnKey
|
||||
-> Maybe AnnKeywordId
|
||||
-> ToBriDocM BriDocNumbered
|
||||
-> ToBriDocM BriDocNumbered
|
||||
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
|
||||
|
||||
docAnnotationRest
|
||||
|
|
@ -1110,11 +1139,12 @@ instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where
|
|||
|
||||
|
||||
|
||||
docPar :: ToBriDocM BriDocNumbered
|
||||
-> ToBriDocM BriDocNumbered
|
||||
-> ToBriDocM BriDocNumbered
|
||||
docPar
|
||||
:: ToBriDocM BriDocNumbered
|
||||
-> ToBriDocM BriDocNumbered
|
||||
-> ToBriDocM BriDocNumbered
|
||||
docPar lineM indentedM = do
|
||||
line <- lineM
|
||||
line <- lineM
|
||||
indented <- indentedM
|
||||
allocateNode $ BDFPar BrIndentNone line indented
|
||||
|
||||
|
|
@ -1124,7 +1154,8 @@ docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm
|
|||
docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
||||
docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm
|
||||
|
||||
docEnsureIndent :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
||||
docEnsureIndent
|
||||
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
||||
docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd
|
||||
|
||||
unknownNodeError
|
||||
|
|
@ -1140,13 +1171,14 @@ spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]
|
|||
briDocMToPPM :: ToBriDocM a -> PPM a
|
||||
briDocMToPPM m = do
|
||||
readers <- MultiRWSS.mGetRawR
|
||||
let ((x, errs), debugs) = runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
|
||||
$ MultiRWSS.withMultiReaders readers
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ m
|
||||
let ((x, errs), debugs) =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
|
||||
$ MultiRWSS.withMultiReaders readers
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ m
|
||||
mTell debugs
|
||||
mTell errs
|
||||
return x
|
||||
|
|
|
|||
|
|
@ -41,52 +41,63 @@ layoutSig lsig@(L _loc sig) = case sig of
|
|||
TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do
|
||||
nameStrs <- names `forM` lrdrNameToTextAnn
|
||||
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
|
||||
typeDoc <- docSharedWrapper layoutType typ
|
||||
typeDoc <- docSharedWrapper layoutType typ
|
||||
hasComments <- hasAnyCommentsBelow lsig
|
||||
docAlt $
|
||||
[ docSeq
|
||||
[ appSep $ docWrapNodeRest lsig $ docLit nameStr
|
||||
, appSep $ docLit $ Text.pack "::"
|
||||
, docForceSingleline typeDoc
|
||||
]
|
||||
| not hasComments
|
||||
] ++
|
||||
[ docAddBaseY BrIndentRegular
|
||||
$ docPar
|
||||
(docWrapNodeRest lsig $ docLit nameStr)
|
||||
( docCols ColTyOpPrefix
|
||||
[ docLit $ Text.pack ":: "
|
||||
, docAddBaseY (BrIndentSpecial 3) $ typeDoc
|
||||
]
|
||||
)
|
||||
]
|
||||
_ -> briDocByExactNoComment lsig -- TODO
|
||||
docAlt
|
||||
$ [ docSeq
|
||||
[ appSep $ docWrapNodeRest lsig $ docLit nameStr
|
||||
, appSep $ docLit $ Text.pack "::"
|
||||
, docForceSingleline typeDoc
|
||||
]
|
||||
| not hasComments
|
||||
]
|
||||
++ [ docAddBaseY BrIndentRegular $ docPar
|
||||
(docWrapNodeRest lsig $ docLit nameStr)
|
||||
( docCols
|
||||
ColTyOpPrefix
|
||||
[ docLit $ Text.pack ":: "
|
||||
, docAddBaseY (BrIndentSpecial 3) $ typeDoc
|
||||
]
|
||||
)
|
||||
]
|
||||
_ -> briDocByExactNoComment lsig -- TODO
|
||||
|
||||
layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName))
|
||||
layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
|
||||
BodyStmt body _ _ _ -> layoutExpr body
|
||||
BodyStmt body _ _ _ -> layoutExpr body
|
||||
BindStmt lPat expr _ _ _ -> do
|
||||
patDoc <- docSharedWrapper layoutPat lPat
|
||||
expDoc <- docSharedWrapper layoutExpr expr
|
||||
docCols ColBindStmt
|
||||
[ appSep $ colsWrapPat =<< patDoc
|
||||
, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
|
||||
]
|
||||
_ -> unknownNodeError "" lgstmt -- TODO
|
||||
[ appSep $ colsWrapPat =<< patDoc
|
||||
, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
|
||||
]
|
||||
_ -> unknownNodeError "" lgstmt -- TODO
|
||||
|
||||
layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered)
|
||||
layoutBind
|
||||
:: ToBriDocC
|
||||
(HsBindLR RdrName RdrName)
|
||||
(Either [BriDocNumbered] BriDocNumbered)
|
||||
layoutBind lbind@(L _ bind) = case bind of
|
||||
FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do
|
||||
idStr <- lrdrNameToTextAnn fId
|
||||
binderDoc <- docLit $ Text.pack "="
|
||||
funcPatDocs <- docWrapNode lbind $ docWrapNode lmatches $ layoutPatternBind (Just idStr) binderDoc `mapM` matches
|
||||
idStr <- lrdrNameToTextAnn fId
|
||||
binderDoc <- docLit $ Text.pack "="
|
||||
funcPatDocs <-
|
||||
docWrapNode lbind
|
||||
$ docWrapNode lmatches
|
||||
$ layoutPatternBind (Just idStr) binderDoc
|
||||
`mapM` matches
|
||||
return $ Left $ funcPatDocs
|
||||
PatBind pat (GRHSs grhss whereBinds) _ _ ([], []) -> do
|
||||
patDocs <- colsWrapPat =<< layoutPat pat
|
||||
patDocs <- colsWrapPat =<< layoutPat pat
|
||||
clauseDocs <- layoutGrhs `mapM` grhss
|
||||
mWhereDocs <- layoutLocalBinds whereBinds
|
||||
binderDoc <- docLit $ Text.pack "="
|
||||
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing binderDoc (Just patDocs) clauseDocs mWhereDocs
|
||||
binderDoc <- docLit $ Text.pack "="
|
||||
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing
|
||||
binderDoc
|
||||
(Just patDocs)
|
||||
clauseDocs
|
||||
mWhereDocs
|
||||
_ -> Right <$> unknownNodeError "" lbind
|
||||
|
||||
data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName)
|
||||
|
|
@ -96,210 +107,250 @@ bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan
|
|||
bindOrSigtoSrcSpan (BagBind (L l _)) = l
|
||||
bindOrSigtoSrcSpan (BagSig (L l _)) = l
|
||||
|
||||
layoutLocalBinds :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered])
|
||||
layoutLocalBinds
|
||||
:: ToBriDocC (HsLocalBindsLR RdrName RdrName) (Maybe [BriDocNumbered])
|
||||
layoutLocalBinds lbinds@(L _ binds) = case binds of
|
||||
-- HsValBinds (ValBindsIn lhsBindsLR []) ->
|
||||
-- Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering
|
||||
-- x@(HsValBinds (ValBindsIn{})) ->
|
||||
-- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
|
||||
HsValBinds (ValBindsIn bindlrs sigs) -> do
|
||||
let unordered = [BagBind b | b <- Data.Foldable.toList bindlrs] ++ [BagSig s | s <- sigs]
|
||||
ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered
|
||||
let
|
||||
unordered
|
||||
= [ BagBind b | b <- Data.Foldable.toList bindlrs ]
|
||||
++ [ BagSig s | s <- sigs ]
|
||||
ordered = sortBy (comparing bindOrSigtoSrcSpan) unordered
|
||||
docs <- docWrapNode lbinds $ join <$> ordered `forM` \case
|
||||
BagBind b -> either id return <$> layoutBind b
|
||||
BagSig s -> return <$> layoutSig s
|
||||
BagBind b -> either id return <$> layoutBind b
|
||||
BagSig s -> return <$> layoutSig s
|
||||
return $ Just $ docs
|
||||
x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
|
||||
-- i _think_ this case never occurs in non-processed ast
|
||||
Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x
|
||||
x@(HsIPBinds _ipBinds) ->
|
||||
Just . (:[]) <$> unknownNodeError "HsIPBinds" x
|
||||
EmptyLocalBinds ->
|
||||
return $ Nothing
|
||||
x@(HsIPBinds _ipBinds) -> Just . (:[]) <$> unknownNodeError "HsIPBinds" x
|
||||
EmptyLocalBinds -> return $ Nothing
|
||||
|
||||
-- TODO: we don't need the `LHsExpr RdrName` anymore, now that there is
|
||||
-- parSpacing stuff.B
|
||||
layoutGrhs :: LGRHS RdrName (LHsExpr RdrName) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)
|
||||
layoutGrhs lgrhs@(L _ (GRHS guards body))
|
||||
= do
|
||||
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
|
||||
bodyDoc <- layoutExpr body
|
||||
return (guardDocs, bodyDoc, body)
|
||||
layoutGrhs
|
||||
:: LGRHS RdrName (LHsExpr RdrName)
|
||||
-> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)
|
||||
layoutGrhs lgrhs@(L _ (GRHS guards body)) = do
|
||||
guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards
|
||||
bodyDoc <- layoutExpr body
|
||||
return (guardDocs, bodyDoc, body)
|
||||
|
||||
layoutPatternBind :: Maybe Text -> BriDocNumbered -> LMatch RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered
|
||||
layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds)))
|
||||
= do
|
||||
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
|
||||
let isInfix = isInfixMatch match
|
||||
patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
|
||||
(Just idStr, p1:pr) | isInfix -> docCols ColPatternsFuncInfix
|
||||
( [ appSep $ docForceSingleline p1
|
||||
, appSep $ docLit idStr
|
||||
]
|
||||
++ (spacifyDocs $ docForceSingleline <$> pr)
|
||||
)
|
||||
(Just idStr, []) -> docLit idStr
|
||||
(Just idStr, ps) -> docCols ColPatternsFuncPrefix
|
||||
layoutPatternBind
|
||||
:: Maybe Text
|
||||
-> BriDocNumbered
|
||||
-> LMatch RdrName (LHsExpr RdrName)
|
||||
-> ToBriDocM BriDocNumbered
|
||||
layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do
|
||||
patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
|
||||
let isInfix = isInfixMatch match
|
||||
patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
|
||||
(Just idStr, p1:pr) | isInfix -> docCols
|
||||
ColPatternsFuncInfix
|
||||
( [appSep $ docForceSingleline p1, appSep $ docLit idStr]
|
||||
++ (spacifyDocs $ docForceSingleline <$> pr)
|
||||
)
|
||||
(Just idStr, [] ) -> docLit idStr
|
||||
(Just idStr, ps) ->
|
||||
docCols ColPatternsFuncPrefix
|
||||
$ appSep (docLit $ idStr)
|
||||
: (spacifyDocs $ docForceSingleline <$> ps)
|
||||
(Nothing, ps) -> docCols ColPatterns
|
||||
(Nothing, ps) ->
|
||||
docCols ColPatterns
|
||||
$ (List.intersperse docSeparator $ docForceSingleline <$> ps)
|
||||
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
|
||||
mWhereDocs <- layoutLocalBinds whereBinds
|
||||
let alignmentToken = if null pats then Nothing else mIdStr
|
||||
layoutPatternBindFinal alignmentToken binderDoc (Just patDoc) clauseDocs mWhereDocs
|
||||
clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss
|
||||
mWhereDocs <- layoutLocalBinds whereBinds
|
||||
let alignmentToken = if null pats then Nothing else mIdStr
|
||||
layoutPatternBindFinal alignmentToken
|
||||
binderDoc
|
||||
(Just patDoc)
|
||||
clauseDocs
|
||||
mWhereDocs
|
||||
|
||||
layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)] -> Maybe [BriDocNumbered] -> ToBriDocM BriDocNumbered
|
||||
layoutPatternBindFinal
|
||||
:: Maybe Text
|
||||
-> BriDocNumbered
|
||||
-> Maybe BriDocNumbered
|
||||
-> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)]
|
||||
-> Maybe [BriDocNumbered]
|
||||
-> ToBriDocM BriDocNumbered
|
||||
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs = do
|
||||
let patPartInline = case mPatDoc of
|
||||
Nothing -> []
|
||||
let patPartInline = case mPatDoc of
|
||||
Nothing -> []
|
||||
Just patDoc -> [appSep $ docForceSingleline $ return patDoc]
|
||||
patPartParWrap = case mPatDoc of
|
||||
Nothing -> id
|
||||
Nothing -> id
|
||||
Just patDoc -> docPar (return patDoc)
|
||||
whereIndent <- mAsk
|
||||
<&> _conf_layout
|
||||
.> _lconfig_indentWhereSpecial
|
||||
.> confUnpack
|
||||
.> Bool.bool BrIndentRegular (BrIndentSpecial 1)
|
||||
whereIndent <-
|
||||
mAsk
|
||||
<&> _conf_layout
|
||||
.> _lconfig_indentWhereSpecial
|
||||
.> confUnpack
|
||||
.> Bool.bool BrIndentRegular (BrIndentSpecial 1)
|
||||
-- TODO: apart from this, there probably are more nodes below which could
|
||||
-- be shared between alternatives.
|
||||
wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of
|
||||
Nothing -> return $ []
|
||||
Just ws -> fmap (fmap return) $ sequence $ return @[]
|
||||
$ docEnsureIndent whereIndent
|
||||
$ docLines
|
||||
Nothing -> return $ []
|
||||
Just ws ->
|
||||
fmap (fmap return)
|
||||
$ sequence
|
||||
$ return @[]
|
||||
$ docEnsureIndent whereIndent
|
||||
$ docLines
|
||||
[ docLit $ Text.pack "where"
|
||||
, docEnsureIndent whereIndent
|
||||
$ docSetIndentLevel
|
||||
$ docNonBottomSpacing
|
||||
$ docLines
|
||||
$ return <$> ws
|
||||
$ docSetIndentLevel
|
||||
$ docNonBottomSpacing
|
||||
$ docLines
|
||||
$ return
|
||||
<$> ws
|
||||
]
|
||||
docAlt $
|
||||
-- one-line solution
|
||||
[ docCols (ColBindingLine alignmentToken)
|
||||
[ docSeq
|
||||
(patPartInline ++ [guardPart])
|
||||
, docSeq
|
||||
[ appSep $ return binderDoc
|
||||
, docForceSingleline $ return body
|
||||
, wherePart
|
||||
]
|
||||
]
|
||||
| [(guards, body, _bodyRaw)] <- [clauseDocs]
|
||||
, let guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
|
||||
gs -> docSeq
|
||||
$ [appSep $ docLit $ Text.pack "|"]
|
||||
++ List.intersperse docCommaSep (return <$> gs)
|
||||
++ [docSeparator]
|
||||
, wherePart <- case mWhereDocs of
|
||||
Nothing -> return @[] $ docEmpty
|
||||
Just [w] -> return @[] $ docSeq
|
||||
[ docSeparator
|
||||
, appSep $ docLit $ Text.pack "where"
|
||||
, docSetIndentLevel $ docForceSingleline $ return w
|
||||
docAlt
|
||||
$ -- one-line solution
|
||||
[ docCols
|
||||
(ColBindingLine alignmentToken)
|
||||
[ docSeq (patPartInline ++ [guardPart])
|
||||
, docSeq
|
||||
[ appSep $ return binderDoc
|
||||
, docForceSingleline $ return body
|
||||
, wherePart
|
||||
]
|
||||
]
|
||||
| [(guards, body, _bodyRaw)] <- [clauseDocs]
|
||||
, let
|
||||
guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] ->
|
||||
docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
|
||||
gs ->
|
||||
docSeq
|
||||
$ [appSep $ docLit $ Text.pack "|"]
|
||||
++ List.intersperse docCommaSep (return <$> gs)
|
||||
++ [docSeparator]
|
||||
, wherePart <- case mWhereDocs of
|
||||
Nothing -> return @[] $ docEmpty
|
||||
Just [w] -> return @[] $ docSeq
|
||||
[ docSeparator
|
||||
, appSep $ docLit $ Text.pack "where"
|
||||
, docSetIndentLevel $ docForceSingleline $ return w
|
||||
]
|
||||
_ -> []
|
||||
]
|
||||
++ -- one-line solution + where in next line(s)
|
||||
[ docLines
|
||||
$ [ docCols
|
||||
(ColBindingLine alignmentToken)
|
||||
[ docSeq (patPartInline ++ [guardPart])
|
||||
, docSeq
|
||||
[appSep $ return binderDoc, docForceParSpacing $ return body]
|
||||
]
|
||||
]
|
||||
++ wherePartMultiLine
|
||||
| [(guards, body, _bodyRaw)] <- [clauseDocs]
|
||||
, let
|
||||
guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] ->
|
||||
docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
|
||||
gs ->
|
||||
docSeq
|
||||
$ [appSep $ docLit $ Text.pack "|"]
|
||||
++ List.intersperse docCommaSep (return <$> gs)
|
||||
++ [docSeparator]
|
||||
, Data.Maybe.isJust mWhereDocs
|
||||
]
|
||||
++ -- two-line solution + where in next line(s)
|
||||
[ docLines
|
||||
$ [ docForceSingleline
|
||||
$ docSeq (patPartInline ++ [guardPart, return binderDoc])
|
||||
, docEnsureIndent BrIndentRegular $ docForceSingleline $ return body
|
||||
]
|
||||
++ wherePartMultiLine
|
||||
| [(guards, body, _bodyRaw)] <- [clauseDocs]
|
||||
, let
|
||||
guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] ->
|
||||
docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
|
||||
gs ->
|
||||
docSeq
|
||||
$ [appSep $ docLit $ Text.pack "|"]
|
||||
++ List.intersperse docCommaSep (return <$> gs)
|
||||
++ [docSeparator]
|
||||
]
|
||||
++ -- pattern and exactly one clause in single line, body as par;
|
||||
-- where in following lines
|
||||
[ docLines
|
||||
$ [ docCols
|
||||
(ColBindingLine alignmentToken)
|
||||
[ docSeq (patPartInline ++ [appSep guardPart])
|
||||
, docSeq
|
||||
[ appSep $ return binderDoc
|
||||
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
|
||||
]
|
||||
]
|
||||
]
|
||||
_ -> []
|
||||
] ++
|
||||
-- one-line solution + where in next line(s)
|
||||
[ docLines
|
||||
$ [ docCols (ColBindingLine alignmentToken)
|
||||
[ docSeq
|
||||
(patPartInline ++ [guardPart])
|
||||
, docSeq
|
||||
[ appSep $ return binderDoc
|
||||
, docForceParSpacing $ return body
|
||||
]
|
||||
]
|
||||
] ++ wherePartMultiLine
|
||||
| [(guards, body, _bodyRaw)] <- [clauseDocs]
|
||||
, let guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
|
||||
gs -> docSeq
|
||||
$ [appSep $ docLit $ Text.pack "|"]
|
||||
++ List.intersperse docCommaSep (return <$> gs)
|
||||
++ [docSeparator]
|
||||
, Data.Maybe.isJust mWhereDocs
|
||||
] ++
|
||||
-- two-line solution + where in next line(s)
|
||||
[ docLines
|
||||
$ [ docForceSingleline
|
||||
$ docSeq (patPartInline ++ [guardPart, return binderDoc])
|
||||
, docEnsureIndent BrIndentRegular
|
||||
$ docForceSingleline
|
||||
$ return body
|
||||
] ++ wherePartMultiLine
|
||||
| [(guards, body, _bodyRaw)] <- [clauseDocs]
|
||||
, let guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
|
||||
gs -> docSeq
|
||||
$ [appSep $ docLit $ Text.pack "|"]
|
||||
++ List.intersperse docCommaSep (return <$> gs)
|
||||
++ [docSeparator]
|
||||
] ++
|
||||
-- pattern and exactly one clause in single line, body as par;
|
||||
-- where in following lines
|
||||
[ docLines
|
||||
$ [ docCols (ColBindingLine alignmentToken)
|
||||
[ docSeq
|
||||
(patPartInline ++ [appSep guardPart])
|
||||
, docSeq
|
||||
[ appSep $ return binderDoc
|
||||
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
|
||||
-- , lineMod $ docAlt
|
||||
-- [ docSetBaseY $ return body
|
||||
-- , docAddBaseY BrIndentRegular $ return body
|
||||
-- ]
|
||||
]
|
||||
]
|
||||
] ++ wherePartMultiLine
|
||||
| [(guards, body, _bodyRaw)] <- [clauseDocs]
|
||||
, let guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
|
||||
gs -> docSeq
|
||||
$ [appSep $ docLit $ Text.pack "|"]
|
||||
++ List.intersperse docCommaSep (return <$> gs)
|
||||
] ++
|
||||
-- pattern and exactly one clause in single line, body in new line.
|
||||
[ docLines
|
||||
$ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc])
|
||||
, docEnsureIndent BrIndentRegular
|
||||
$ docNonBottomSpacing
|
||||
$ (docAddBaseY BrIndentRegular $ return body)
|
||||
] ++ wherePartMultiLine
|
||||
| [(guards, body, _)] <- [clauseDocs]
|
||||
, let guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
|
||||
gs -> docSeq
|
||||
$ [appSep $ docLit $ Text.pack "|"]
|
||||
++ List.intersperse docCommaSep (return <$> gs)
|
||||
] ++
|
||||
-- conservative approach: everything starts on the left.
|
||||
[ docLines $
|
||||
[ patPartParWrap
|
||||
$ docLines
|
||||
$ fmap (docEnsureIndent BrIndentRegular)
|
||||
$ clauseDocs >>= \(guardDocs, bodyDoc, _) ->
|
||||
(case guardDocs of
|
||||
[] -> []
|
||||
[g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]]
|
||||
(g1:gr) ->
|
||||
( docSeq [appSep $ docLit $ Text.pack "|", return g1]
|
||||
: ( gr <&> \g ->
|
||||
docSeq [appSep $ docLit $ Text.pack ",", return g]
|
||||
)
|
||||
)
|
||||
) ++
|
||||
[docCols ColOpPrefix
|
||||
[ appSep $ return binderDoc
|
||||
, docAddBaseY BrIndentRegular $ return bodyDoc]
|
||||
++ wherePartMultiLine
|
||||
| [(guards, body, _bodyRaw)] <- [clauseDocs]
|
||||
, let
|
||||
guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
|
||||
gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse
|
||||
docCommaSep
|
||||
(return <$> gs)
|
||||
]
|
||||
++ -- pattern and exactly one clause in single line, body in new line.
|
||||
[ docLines
|
||||
$ [ docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc])
|
||||
, docEnsureIndent BrIndentRegular
|
||||
$ docNonBottomSpacing
|
||||
$ (docAddBaseY BrIndentRegular $ return body)
|
||||
]
|
||||
] ++ wherePartMultiLine
|
||||
]
|
||||
++ wherePartMultiLine
|
||||
| [(guards, body, _)] <- [clauseDocs]
|
||||
, let
|
||||
guardPart = case guards of
|
||||
[] -> docEmpty
|
||||
[g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
|
||||
gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse
|
||||
docCommaSep
|
||||
(return <$> gs)
|
||||
]
|
||||
++ -- conservative approach: everything starts on the left.
|
||||
[ docLines
|
||||
$ [ patPartParWrap
|
||||
$ docLines
|
||||
$ fmap (docEnsureIndent BrIndentRegular)
|
||||
$ clauseDocs
|
||||
>>= \(guardDocs, bodyDoc, _) ->
|
||||
( case guardDocs of
|
||||
[] -> []
|
||||
[g] ->
|
||||
[docSeq [appSep $ docLit $ Text.pack "|", return g]]
|
||||
(g1:gr) ->
|
||||
( docSeq [appSep $ docLit $ Text.pack "|", return g1]
|
||||
: ( gr
|
||||
<&> \g ->
|
||||
docSeq
|
||||
[appSep $ docLit $ Text.pack ",", return g]
|
||||
)
|
||||
)
|
||||
)
|
||||
++ [ docCols
|
||||
ColOpPrefix
|
||||
[ appSep $ return binderDoc
|
||||
, docAddBaseY BrIndentRegular $ return bodyDoc
|
||||
]
|
||||
]
|
||||
]
|
||||
++ wherePartMultiLine
|
||||
]
|
||||
|
|
|
|||
|
|
@ -777,19 +777,19 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
|
|||
|
||||
litBriDoc :: HsLit -> BriDocFInt
|
||||
litBriDoc = \case
|
||||
HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
|
||||
HsCharPrim t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
|
||||
HsString t _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString
|
||||
HsStringPrim t _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString
|
||||
HsInt t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsIntPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsWordPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsInt64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsWord64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsInteger t _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsRat (FL t _) _type -> BDFLit $ Text.pack t
|
||||
HsFloatPrim (FL t _) -> BDFLit $ Text.pack t
|
||||
HsDoublePrim (FL t _) -> BDFLit $ Text.pack t
|
||||
HsChar t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
|
||||
HsCharPrim t _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
|
||||
HsString t _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString
|
||||
HsStringPrim t _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString
|
||||
HsInt t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsIntPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsWordPrim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsInt64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsWord64Prim t _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsInteger t _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
|
||||
HsRat (FL t _) _type -> BDFLit $ Text.pack t
|
||||
HsFloatPrim (FL t _) -> BDFLit $ Text.pack t
|
||||
HsDoublePrim (FL t _) -> BDFLit $ Text.pack t
|
||||
|
||||
overLitValBriDoc :: OverLitVal -> BriDocFInt
|
||||
overLitValBriDoc = \case
|
||||
|
|
|
|||
|
|
@ -28,51 +28,50 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr
|
|||
|
||||
layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))
|
||||
layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
|
||||
LastStmt body False _ -> do
|
||||
LastStmt body False _ -> do
|
||||
layoutExpr body
|
||||
BindStmt lPat expr _ _ _ -> do
|
||||
patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat
|
||||
expDoc <- docSharedWrapper layoutExpr expr
|
||||
docAlt
|
||||
[ docCols ColBindStmt
|
||||
[ docCols
|
||||
ColBindStmt
|
||||
[ appSep patDoc
|
||||
, docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc]
|
||||
]
|
||||
, docCols ColBindStmt
|
||||
, docCols
|
||||
ColBindStmt
|
||||
[ appSep patDoc
|
||||
, docAddBaseY BrIndentRegular
|
||||
$ docPar (docLit $ Text.pack "<-")
|
||||
(expDoc)
|
||||
$ docPar (docLit $ Text.pack "<-") (expDoc)
|
||||
]
|
||||
]
|
||||
LetStmt binds -> layoutLocalBinds binds >>= \case
|
||||
Nothing ->
|
||||
docLit $ Text.pack "let" -- i just tested
|
||||
LetStmt binds -> layoutLocalBinds binds >>= \case
|
||||
Nothing -> docLit $ Text.pack "let" -- i just tested
|
||||
-- it, and it is
|
||||
-- indeed allowed.
|
||||
-- heh.
|
||||
Just [] ->
|
||||
docLit $ Text.pack "let" -- this probably never happens
|
||||
Just [] -> docLit $ Text.pack "let" -- this probably never happens
|
||||
Just [bindDoc] -> docAlt
|
||||
[ docCols ColDoLet
|
||||
[ docCols
|
||||
ColDoLet
|
||||
[ appSep $ docLit $ Text.pack "let"
|
||||
, docSetBaseAndIndent $ return bindDoc
|
||||
]
|
||||
, docAddBaseY BrIndentRegular $ docPar
|
||||
(docLit $ Text.pack "let")
|
||||
(docSetBaseAndIndent $ return bindDoc)
|
||||
, docAddBaseY BrIndentRegular
|
||||
$ docPar (docLit $ Text.pack "let")
|
||||
(docSetBaseAndIndent $ return bindDoc)
|
||||
]
|
||||
Just bindDocs -> docAlt
|
||||
Just bindDocs -> docAlt
|
||||
[ docSeq
|
||||
[ appSep $ docLit $ Text.pack "let"
|
||||
, docSetBaseAndIndent $ docLines $ return <$> bindDocs
|
||||
]
|
||||
, docAddBaseY BrIndentRegular
|
||||
$ docPar
|
||||
, docAddBaseY BrIndentRegular $ docPar
|
||||
(docLit $ Text.pack "let")
|
||||
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
|
||||
]
|
||||
BodyStmt expr _ _ _ -> do
|
||||
BodyStmt expr _ _ _ -> do
|
||||
expDoc <- docSharedWrapper layoutExpr expr
|
||||
docAddBaseY BrIndentRegular $ expDoc
|
||||
_ -> unknownNodeError "" lstmt
|
||||
_ -> unknownNodeError "" lstmt
|
||||
|
|
|
|||
|
|
@ -296,88 +296,89 @@ instance Uniplate.Uniplate BriDoc where
|
|||
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 (BDBaseYPop bd) = plate BDBaseYPop |* bd
|
||||
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
|
||||
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
|
||||
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
|
||||
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* 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 (BDAlt alts) = plate BDAlt ||* alts
|
||||
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
|
||||
uniplate x@BDExternal{} = plate x
|
||||
uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd
|
||||
uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd
|
||||
uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd
|
||||
uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* 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 (BDForceMultiline bd) = plate BDForceMultiline |* bd
|
||||
uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd
|
||||
uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd
|
||||
uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd
|
||||
uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd
|
||||
uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd
|
||||
uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd
|
||||
uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd
|
||||
uniplate (BDProhibitMTEL bd) = plate BDProhibitMTEL |* bd
|
||||
uniplate (BDDebug s bd) = plate BDDebug |- s |* bd
|
||||
|
||||
newtype NodeAllocIndex = NodeAllocIndex Int
|
||||
|
||||
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
|
||||
BDFBaseYPop bd -> BDBaseYPop $ 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 k ks c t -> BDExternal k ks c t
|
||||
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
|
||||
BDFBaseYPop bd -> BDBaseYPop $ 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 k ks c t -> BDExternal k ks c t
|
||||
BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
|
||||
BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
|
||||
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ 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 bd -> BDNonBottomSpacing $ rec bd
|
||||
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
|
||||
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
|
||||
BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd
|
||||
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
|
||||
BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ 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 bd -> BDNonBottomSpacing $ rec bd
|
||||
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
|
||||
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
|
||||
BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd
|
||||
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
|
||||
where
|
||||
rec = unwrapBriDocNumbered
|
||||
|
||||
-- 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
|
||||
BDBaseYPop bd -> briDocSeqSpine bd
|
||||
BDIndentLevelPushCur bd -> briDocSeqSpine bd
|
||||
BDIndentLevelPop bd -> briDocSeqSpine bd
|
||||
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
|
||||
BDBaseYPop 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{} -> ()
|
||||
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
|
||||
BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts
|
||||
BDForwardLineMode bd -> briDocSeqSpine bd
|
||||
BDExternal{} -> ()
|
||||
BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
|
||||
BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd
|
||||
BDAnnotationRest _annKey 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
|
||||
BDProhibitMTEL bd -> briDocSeqSpine bd
|
||||
BDDebug _s bd -> briDocSeqSpine bd
|
||||
BDAnnotationRest _annKey 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
|
||||
BDProhibitMTEL bd -> briDocSeqSpine bd
|
||||
BDDebug _s bd -> briDocSeqSpine bd
|
||||
|
||||
briDocForceSpine :: BriDoc -> BriDoc
|
||||
briDocForceSpine bd = briDocSeqSpine bd `seq` bd
|
||||
|
|
|
|||
|
|
@ -76,13 +76,11 @@ showGhc :: (GHC.Outputable a) => a -> String
|
|||
showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags
|
||||
|
||||
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
|
||||
fromMaybeIdentity x y = Data.Coerce.coerce
|
||||
$ fromMaybe (Data.Coerce.coerce x) y
|
||||
fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
|
||||
|
||||
fromOptionIdentity :: Identity a -> Option a -> Identity a
|
||||
fromOptionIdentity x y = Data.Coerce.coerce
|
||||
$ fromMaybe (Data.Coerce.coerce x)
|
||||
$ getOption y
|
||||
fromOptionIdentity x y =
|
||||
Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) $ getOption y
|
||||
|
||||
-- maximum monoid over N+0
|
||||
-- or more than N, because Num is allowed.
|
||||
|
|
@ -101,61 +99,68 @@ data A x = A ShowIsId x deriving Data
|
|||
|
||||
customLayouterF :: ExactPrint.Types.Anns -> LayouterF
|
||||
customLayouterF anns layoutF =
|
||||
DataToLayouter $ f `extQ` showIsId
|
||||
`extQ` fastString
|
||||
`extQ` bytestring
|
||||
`extQ` occName
|
||||
`extQ` srcSpan
|
||||
`ext2Q` located
|
||||
where
|
||||
DataToLayouter f = defaultLayouterF layoutF
|
||||
simpleLayouter :: String -> NodeLayouter
|
||||
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
|
||||
showIsId :: ShowIsId -> NodeLayouter
|
||||
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
|
||||
Left True -> PP.parens $ PP.text s
|
||||
Left False -> PP.text s
|
||||
Right _ -> PP.text s
|
||||
fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter
|
||||
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
|
||||
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
|
||||
srcSpan :: GHC.SrcSpan -> NodeLayouter
|
||||
srcSpan ss = simpleLayouter
|
||||
-- $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
|
||||
$ "{" ++ showGhc ss ++ "}"
|
||||
located :: (Data b,Data loc) => GHC.GenLocated loc b -> NodeLayouter
|
||||
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
|
||||
where
|
||||
annStr = case cast ss of
|
||||
Just (s :: GHC.SrcSpan) -> ShowIsId
|
||||
$ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
|
||||
Nothing -> ShowIsId "nnnnnnnn"
|
||||
DataToLayouter
|
||||
$ f
|
||||
`extQ` showIsId
|
||||
`extQ` fastString
|
||||
`extQ` bytestring
|
||||
`extQ` occName
|
||||
`extQ` srcSpan
|
||||
`ext2Q` located
|
||||
where
|
||||
DataToLayouter f = defaultLayouterF layoutF
|
||||
simpleLayouter :: String -> NodeLayouter
|
||||
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
|
||||
showIsId :: ShowIsId -> NodeLayouter
|
||||
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
|
||||
Left True -> PP.parens $ PP.text s
|
||||
Left False -> PP.text s
|
||||
Right _ -> PP.text s
|
||||
fastString =
|
||||
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
|
||||
-> NodeLayouter
|
||||
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
|
||||
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
|
||||
srcSpan :: GHC.SrcSpan -> NodeLayouter
|
||||
srcSpan ss = simpleLayouter
|
||||
-- $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
|
||||
$ "{" ++ showGhc ss ++ "}"
|
||||
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
|
||||
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
|
||||
where
|
||||
annStr = case cast ss of
|
||||
Just (s :: GHC.SrcSpan) ->
|
||||
ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)
|
||||
Nothing -> ShowIsId "nnnnnnnn"
|
||||
|
||||
customLayouterNoAnnsF :: LayouterF
|
||||
customLayouterNoAnnsF layoutF =
|
||||
DataToLayouter $ f `extQ` showIsId
|
||||
`extQ` fastString
|
||||
`extQ` bytestring
|
||||
`extQ` occName
|
||||
`extQ` srcSpan
|
||||
`ext2Q` located
|
||||
where
|
||||
DataToLayouter f = defaultLayouterF layoutF
|
||||
simpleLayouter :: String -> NodeLayouter
|
||||
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
|
||||
showIsId :: ShowIsId -> NodeLayouter
|
||||
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
|
||||
Left True -> PP.parens $ PP.text s
|
||||
Left False -> PP.text s
|
||||
Right _ -> PP.text s
|
||||
fastString = simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString -> NodeLayouter
|
||||
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
|
||||
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
|
||||
srcSpan :: GHC.SrcSpan -> NodeLayouter
|
||||
srcSpan ss = simpleLayouter
|
||||
$ "{"++ showSDoc_ (GHC.ppr ss)++"}"
|
||||
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
|
||||
located (GHC.L _ss a) = runDataToLayouter layoutF a
|
||||
DataToLayouter
|
||||
$ f
|
||||
`extQ` showIsId
|
||||
`extQ` fastString
|
||||
`extQ` bytestring
|
||||
`extQ` occName
|
||||
`extQ` srcSpan
|
||||
`ext2Q` located
|
||||
where
|
||||
DataToLayouter f = defaultLayouterF layoutF
|
||||
simpleLayouter :: String -> NodeLayouter
|
||||
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
|
||||
showIsId :: ShowIsId -> NodeLayouter
|
||||
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
|
||||
Left True -> PP.parens $ PP.text s
|
||||
Left False -> PP.text s
|
||||
Right _ -> PP.text s
|
||||
fastString =
|
||||
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString
|
||||
-> NodeLayouter
|
||||
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
|
||||
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
|
||||
srcSpan :: GHC.SrcSpan -> NodeLayouter
|
||||
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
|
||||
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
|
||||
located (GHC.L _ss a) = runDataToLayouter layoutF a
|
||||
|
||||
-- displayBriDocTree :: BriDoc -> PP.Doc
|
||||
-- displayBriDocTree = \case
|
||||
|
|
@ -205,13 +210,12 @@ customLayouterNoAnnsF layoutF =
|
|||
-- : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr]
|
||||
-- ++ [PP.text "]"]
|
||||
|
||||
traceIfDumpConf :: (MonadMultiReader
|
||||
Config m,
|
||||
Show a)
|
||||
=> String
|
||||
-> (DebugConfig -> Identity (Semigroup.Last Bool))
|
||||
-> a
|
||||
-> m ()
|
||||
traceIfDumpConf
|
||||
:: (MonadMultiReader Config m, Show a)
|
||||
=> String
|
||||
-> (DebugConfig -> Identity (Semigroup.Last Bool))
|
||||
-> a
|
||||
-> m ()
|
||||
traceIfDumpConf s accessor val = do
|
||||
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
|
||||
trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
|
||||
|
|
@ -237,8 +241,8 @@ briDocToDoc = astToDoc . removeAnnotations
|
|||
removeAnnotations = Uniplate.transform $ \case
|
||||
BDAnnotationPrior _ x -> x
|
||||
BDAnnotationKW _ _ x -> x
|
||||
BDAnnotationRest _ x -> x
|
||||
x -> x
|
||||
BDAnnotationRest _ x -> x
|
||||
x -> x
|
||||
|
||||
briDocToDocWithAnns :: BriDoc -> PP.Doc
|
||||
briDocToDocWithAnns = astToDoc
|
||||
|
|
@ -246,16 +250,16 @@ briDocToDocWithAnns = astToDoc
|
|||
annsDoc :: ExactPrint.Types.Anns -> PP.Doc
|
||||
annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
|
||||
|
||||
breakEither :: (a -> Either b c) -> [a] -> ([b],[c])
|
||||
breakEither _ [] = ([],[])
|
||||
breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
|
||||
breakEither _ [] = ([], [])
|
||||
breakEither fn (a1:aR) = case fn a1 of
|
||||
Left b -> (b:bs,cs)
|
||||
Right c -> (bs,c:cs)
|
||||
where
|
||||
(bs,cs) = breakEither fn aR
|
||||
Left b -> (b : bs, cs)
|
||||
Right c -> (bs, c : cs)
|
||||
where
|
||||
(bs, cs) = breakEither fn aR
|
||||
|
||||
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
|
||||
spanMaybe f (x1:xR) | Just y <- f x1 = (y:ys, xs)
|
||||
where
|
||||
(ys, xs) = spanMaybe f xR
|
||||
spanMaybe _ xs = ([], xs)
|
||||
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
|
||||
spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs)
|
||||
where
|
||||
(ys, xs) = spanMaybe f xR
|
||||
spanMaybe _ xs = ([], xs)
|
||||
|
|
|
|||
Loading…
Reference in New Issue