Update showcases / Add more example layouts
parent
00ad6c71b9
commit
da692a4341
|
|
@ -3,10 +3,11 @@ haskell source code formatter
|
|||
|
||||
|
||||
|
||||
(see another demonstration in [Showcase.md](Showcase.md))
|
||||
(see [more examples and comparisons](/doc/showcases))
|
||||
|
||||
This project's goals roughly are to:
|
||||
|
||||
- Always retain the semantics of the source being transformed;
|
||||
- Be idempotent (this also directly ensures that only valid haskell is
|
||||
produced);
|
||||
- Support the full ghc-haskell syntax including syntactic extensions;
|
||||
|
|
|
|||
288
Showcase.md
288
Showcase.md
|
|
@ -1,288 +0,0 @@
|
|||
# brittany showcase
|
||||
|
||||
We will try to take the following module and try to fit it into 80 columns.
|
||||
|
||||
## input
|
||||
|
||||
~~~~ .hs
|
||||
-- 10 20 30 40 50 60 70 80
|
||||
module Language.Haskell.Brittany.BriLayouter
|
||||
( layoutBriDoc
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
|
||||
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
|
||||
layoutBriDoc ast briDoc = do
|
||||
-- first step: transform the briDoc.
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyFloating >>= mSet
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyColumns >>= mSet
|
||||
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
|
||||
-- -- convert to Simple type
|
||||
-- simpl <- mGet <&> transformToSimple
|
||||
-- return simpl
|
||||
|
||||
anns :: ExactPrint.Types.Anns <- mAsk
|
||||
let filteredAnns = filterAnns ast anns
|
||||
|
||||
let state = LayoutState
|
||||
{ _lstate_baseY = 0
|
||||
, _lstate_curY = 0
|
||||
, _lstate_indLevel = 0
|
||||
, _lstate_indLevelLinger = 0
|
||||
, _lstate_commentsPrior = extractCommentsPrior filteredAnns
|
||||
, _lstate_commentsPost = extractCommentsPost filteredAnns
|
||||
, _lstate_commentCol = Nothing
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
, _lstate_isNewline = NewLineStateInit
|
||||
}
|
||||
|
||||
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
||||
|
||||
let remainingComments = Map.elems (_lstate_commentsPrior state') ++ Map.elems (_lstate_commentsPost state')
|
||||
remainingComments `forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fmap fst)
|
||||
|
||||
return $ ()
|
||||
~~~~
|
||||
|
||||
## `brittany` output
|
||||
|
||||
~~~~ .hs
|
||||
-- 10 20 30 40 50 60 70 80
|
||||
module Language.Haskell.Brittany.BriLayouter
|
||||
( layoutBriDoc
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
|
||||
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
|
||||
layoutBriDoc ast briDoc = do
|
||||
-- first step: transform the briDoc.
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyFloating >>= mSet
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyColumns >>= mSet
|
||||
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
|
||||
-- -- convert to Simple type
|
||||
-- simpl <- mGet <&> transformToSimple
|
||||
-- return simpl
|
||||
|
||||
anns :: ExactPrint.Types.Anns <- mAsk
|
||||
let filteredAnns = filterAnns ast anns
|
||||
|
||||
let state = LayoutState
|
||||
{ _lstate_baseY = 0
|
||||
, _lstate_curY = 0
|
||||
, _lstate_indLevel = 0
|
||||
, _lstate_indLevelLinger = 0
|
||||
, _lstate_commentsPrior = extractCommentsPrior filteredAnns
|
||||
, _lstate_commentsPost = extractCommentsPost filteredAnns
|
||||
, _lstate_commentCol = Nothing
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
, _lstate_isNewline = NewLineStateInit
|
||||
}
|
||||
|
||||
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
||||
|
||||
let remainingComments = Map.elems (_lstate_commentsPrior state')
|
||||
++ Map.elems (_lstate_commentsPost state')
|
||||
remainingComments
|
||||
`forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fmap fst)
|
||||
|
||||
return $ ()
|
||||
~~~~
|
||||
|
||||
In contrast, let us look at Chris Done's `hindent` (version `5.2.1`) re-formatting results for the same input:
|
||||
|
||||
## `hindent` output
|
||||
|
||||
~~~~ .hs
|
||||
-- 10 20 30 40 50 60 70 80
|
||||
module Language.Haskell.Brittany.BriLayouter
|
||||
( layoutBriDoc
|
||||
) where
|
||||
|
||||
layoutBriDoc
|
||||
:: Data.Data.Data ast
|
||||
=> ast -> BriDocNumbered -> PPM ()
|
||||
layoutBriDoc ast briDoc
|
||||
-- first step: transform the briDoc.
|
||||
= 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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyFloating >>= mSet
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyColumns >>= mSet
|
||||
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
|
||||
-- -- convert to Simple type
|
||||
-- simpl <- mGet <&> transformToSimple
|
||||
-- return simpl
|
||||
anns :: ExactPrint.Types.Anns <- mAsk
|
||||
let filteredAnns = filterAnns ast anns
|
||||
let state =
|
||||
LayoutState
|
||||
{ _lstate_baseY = 0
|
||||
, _lstate_curY = 0
|
||||
, _lstate_indLevel = 0
|
||||
, _lstate_indLevelLinger = 0
|
||||
, _lstate_commentsPrior = extractCommentsPrior filteredAnns
|
||||
, _lstate_commentsPost = extractCommentsPost filteredAnns
|
||||
, _lstate_commentCol = Nothing
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
, _lstate_isNewline = NewLineStateInit
|
||||
}
|
||||
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
||||
let remainingComments =
|
||||
Map.elems (_lstate_commentsPrior state') ++
|
||||
Map.elems (_lstate_commentsPost state')
|
||||
remainingComments `forM_`
|
||||
(mTell . (: []) . LayoutErrorUnusedComment . show . fmap fst)
|
||||
return $ ()
|
||||
~~~~
|
||||
|
||||
and haskell-formatter (version 1.0.0)
|
||||
|
||||
## `haskell-formatter` output
|
||||
|
||||
~~~~ .hs
|
||||
-- 10 20 30 40 50 60 70 80
|
||||
module Language.Haskell.Brittany.BriLayouter (layoutBriDoc) where
|
||||
|
||||
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
|
||||
layoutBriDoc ast briDoc
|
||||
-- first step: transform the briDoc.
|
||||
= 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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyFloating >>= mSet
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyColumns >>= mSet
|
||||
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
|
||||
-- -- convert to Simple type
|
||||
-- simpl <- mGet <&> transformToSimple
|
||||
-- return simpl
|
||||
anns :: ExactPrint.Types.Anns <- mAsk
|
||||
let filteredAnns = filterAnns ast anns
|
||||
let state
|
||||
= LayoutState{_lstate_baseY = 0, _lstate_curY = 0,
|
||||
_lstate_indLevel = 0, _lstate_indLevelLinger = 0,
|
||||
_lstate_commentsPrior =
|
||||
extractCommentsPrior filteredAnns,
|
||||
_lstate_commentsPost =
|
||||
extractCommentsPost filteredAnns,
|
||||
_lstate_commentCol = Nothing,
|
||||
_lstate_addSepSpace = Nothing,
|
||||
_lstate_inhibitMTEL = False,
|
||||
_lstate_isNewline = NewLineStateInit}
|
||||
|
||||
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
||||
let remainingComments
|
||||
= Map.elems (_lstate_commentsPrior state') ++
|
||||
Map.elems (_lstate_commentsPost state')
|
||||
remainingComments `forM_`
|
||||
(mTell . (: []) . LayoutErrorUnusedComment . show . fmap fst)
|
||||
return $ ()
|
||||
~~~~
|
||||
|
|
@ -0,0 +1,522 @@
|
|||
|
||||
versions used:
|
||||
|
||||
- brittany-0.8.0.1
|
||||
- hindent-5.2.3
|
||||
- haskell-formatter-1.0.0
|
||||
|
||||
## simple nested ifs
|
||||
|
||||
~~~~.hs
|
||||
--------------------------------------------------------------- vvv brittany vvv
|
||||
mybinding = if condition1
|
||||
then if condition2
|
||||
then if condition3 then 0 else 1
|
||||
else if condition3 then 2 else 3
|
||||
else 4
|
||||
---------------------------------------------------------------- vvv hindent vvv
|
||||
mybinding =
|
||||
if condition1
|
||||
then if condition2
|
||||
then if condition3
|
||||
then 0
|
||||
else 1
|
||||
else if condition3
|
||||
then 2
|
||||
else 3
|
||||
else 4
|
||||
------------------------------------------------------ vvv haskell-formatter vvv
|
||||
mybinding
|
||||
= if condition1 then
|
||||
if condition2 then if condition3 then 0 else 1 else
|
||||
if condition3 then 2 else 3
|
||||
else 4
|
||||
--------------------------------------------------------------------------------
|
||||
~~~~
|
||||
|
||||
## monad comprehension + alignment
|
||||
|
||||
~~~~.hs
|
||||
-- 10 20 30 40 50 60 70 80
|
||||
--------------------------------------------------------------- vvv brittany vvv
|
||||
myBinding =
|
||||
[ [ [ LeguEosb r1 (n2 - r1) fxvoNz ymuSreje v
|
||||
, LeguEosb n2 (f3 - n2) oyphEmedn ymuSreje v
|
||||
, LeguEosb f3 (i4 - f3) fxvoNz ymuSreje v
|
||||
, LeguEosb i4 (v5 - i4) oieha ymuSreje v
|
||||
, LeguEosb v5 (j6 - v5) fxvoNz ymuSreje v
|
||||
]
|
||||
| oyphEmedn <- sdliWmguje
|
||||
, oieha <- ohzvIp
|
||||
]
|
||||
| v5 < j6
|
||||
, sdliWmguje <- zedoaregeuKilb tua1
|
||||
, ohzvIp <- zedoaregeuKilb (0 - loy2)
|
||||
]
|
||||
---------------------------------------------------------------- vvv hindent vvv
|
||||
myBinding =
|
||||
[ [ [ LeguEosb r1 (n2 - r1) fxvoNz ymuSreje v
|
||||
, LeguEosb n2 (f3 - n2) oyphEmedn ymuSreje v
|
||||
, LeguEosb f3 (i4 - f3) fxvoNz ymuSreje v
|
||||
, LeguEosb i4 (v5 - i4) oieha ymuSreje v
|
||||
, LeguEosb v5 (j6 - v5) fxvoNz ymuSreje v
|
||||
]
|
||||
| oyphEmedn <- sdliWmguje
|
||||
, oieha <- ohzvIp
|
||||
]
|
||||
| v5 < j6
|
||||
, sdliWmguje <- zedoaregeuKilb tua1
|
||||
, ohzvIp <- zedoaregeuKilb (0 - loy2)
|
||||
]
|
||||
------------------------------------------------------ vvv haskell-formatter vvv
|
||||
myBinding
|
||||
= [[[LeguEosb r1 (n2 - r1) fxvoNz ymuSreje v,
|
||||
LeguEosb n2 (f3 - n2) oyphEmedn ymuSreje v,
|
||||
LeguEosb f3 (i4 - f3) fxvoNz ymuSreje v,
|
||||
LeguEosb i4 (v5 - i4) oieha ymuSreje v,
|
||||
LeguEosb v5 (j6 - v5) fxvoNz ymuSreje v]
|
||||
|
||||
| oyphEmedn <- sdliWmguje, oieha <- ohzvIp]
|
||||
|
||||
| v5 < j6, sdliWmguje <- zedoaregeuKilb tua1,
|
||||
ohzvIp <- zedoaregeuKilb (0 - loy2)]
|
||||
--------------------------------------------------------------------------------
|
||||
~~~~
|
||||
|
||||
## tricky full line usage
|
||||
|
||||
~~~~.hs
|
||||
-- 10 20 30 40 50 60 70 80
|
||||
--------------------------------------------------------------- vvv brittany vvv
|
||||
mybinding = RH.performEvent_ $ postBuild <&> \() -> liftIO $ do
|
||||
runMaybeT postCliInit >>= \case
|
||||
Nothing -> return ()
|
||||
Just () -> do
|
||||
_ <- forkIO $ postCliInitAsync `catch` \(e :: SomeException) ->
|
||||
writeLogS LogLevelError (show e)
|
||||
return ()
|
||||
---------------------------------------------------------------- vvv hindent vvv
|
||||
mybinding =
|
||||
RH.performEvent_ $
|
||||
postBuild <&> \() ->
|
||||
liftIO $ do
|
||||
runMaybeT postCliInit >>= \case
|
||||
Nothing -> return ()
|
||||
Just () -> do
|
||||
_ <-
|
||||
forkIO $
|
||||
postCliInitAsync `catch` \(e :: SomeException) ->
|
||||
writeLogS LogLevelError (show e)
|
||||
return ()
|
||||
------------------------------------------------------ vvv haskell-formatter vvv
|
||||
mybinding
|
||||
= RH.performEvent_ $
|
||||
postBuild <&>
|
||||
\ () ->
|
||||
liftIO $
|
||||
do runMaybeT postCliInit >>=
|
||||
\case
|
||||
Nothing -> return ()
|
||||
Just () -> do _ <- forkIO $
|
||||
postCliInitAsync `catch`
|
||||
\ (e :: SomeException) ->
|
||||
writeLogS LogLevelError (show e)
|
||||
return ()
|
||||
--------------------------------------------------------------------------------
|
||||
~~~~
|
||||
|
||||
## long type signature
|
||||
|
||||
~~~~.hs
|
||||
-- 10 20 30 40 50 60 70 80
|
||||
--------------------------------------------------------------- vvv brittany vvv
|
||||
linewise
|
||||
:: forall n t
|
||||
. (Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t))
|
||||
=> ( R.Event t Text -- command string executed by user
|
||||
-> R.Dynamic t (Maybe Text, Int, Text)
|
||||
-> R.Behavior t (Seq Text) -- history
|
||||
-> R.Event t () -- post-shutdown
|
||||
-> RH.AppHost
|
||||
t
|
||||
( R.Event t () -- shutdown trigger
|
||||
, R.Behavior t String -- tab-completion value
|
||||
, R.Dynamic t (Widget n)
|
||||
)
|
||||
)
|
||||
-> RH.AppHost t ()
|
||||
---------------------------------------------------------------- vvv hindent vvv
|
||||
-- (overflowing columns)
|
||||
linewise ::
|
||||
forall n t.
|
||||
(Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t))
|
||||
=> (R.Event t Text -- command string executed by user
|
||||
-> R.Dynamic t (Maybe Text, Int, Text) -> R.Behavior t (Seq Text) -- history
|
||||
-> R.Event t () -- post-shutdown
|
||||
-> RH.AppHost t ( R.Event t () -- shutdown trigger
|
||||
, R.Behavior t String -- tab-completion value
|
||||
, R.Dynamic t (Widget n)))
|
||||
-> RH.AppHost t ()
|
||||
------------------------------------------------------ vvv haskell-formatter vvv
|
||||
linewise ::
|
||||
forall n t .
|
||||
(Ord n, R.ReflexHost t, MonadIO (R.PushM t),
|
||||
MonadIO (R.HostFrame t)) =>
|
||||
(R.Event t Text ->
|
||||
-- command string executed by user
|
||||
R.Dynamic t (Maybe Text, Int, Text) ->
|
||||
R.Behavior t (Seq Text) ->
|
||||
-- history
|
||||
R.Event t () ->
|
||||
-- post-shutdown
|
||||
RH.AppHost t
|
||||
-- shutdown trigger
|
||||
(R.Event t (), R.Behavior t String,
|
||||
-- tab-completion value
|
||||
R.Dynamic t (Widget n)))
|
||||
|
||||
-> RH.AppHost t ()
|
||||
--------------------------------------------------------------------------------
|
||||
~~~~
|
||||
|
||||
## slighly longer mix of different constructs
|
||||
|
||||
~~~~.hs
|
||||
-- 10 20 30 40 50 60 70 80
|
||||
--------------------------------------------------------------- vvv brittany vvv
|
||||
completion :: String -> CommandDesc a -> String -> String
|
||||
completion cmdline desc pcRest =
|
||||
List.drop (List.length lastWord) $ case choices of
|
||||
[] -> ""
|
||||
(c1:cr) ->
|
||||
headDef ""
|
||||
$ filter (\s -> List.all (s`isPrefixOf`) cr)
|
||||
$ reverse
|
||||
$ List.inits c1
|
||||
where
|
||||
nameDesc = case _cmd_mParent desc of
|
||||
Nothing -> desc
|
||||
Just (_, parent) | null pcRest -> parent
|
||||
Just{} -> desc
|
||||
lastWord = reverse $ takeWhile (not . isSpace) $ reverse $ cmdline
|
||||
choices = join
|
||||
[ [ r
|
||||
| Just r <- Foldable.toList (_cmd_children nameDesc)
|
||||
<&> \(s, _) -> [ s | lastWord `isPrefixOf` s ]
|
||||
]
|
||||
, [ s
|
||||
| s <- transPartDesc =<< _cmd_parts nameDesc
|
||||
, lastWord `isPrefixOf` s
|
||||
]
|
||||
]
|
||||
transPartDesc :: PartDesc -> [String]
|
||||
transPartDesc = \case
|
||||
PartLiteral s -> [s]
|
||||
PartVariable _ -> []
|
||||
PartOptional x -> transPartDesc x
|
||||
PartAlts alts -> alts >>= transPartDesc
|
||||
PartSeq [] -> []
|
||||
PartSeq (x:_) -> transPartDesc x
|
||||
PartDefault _ x -> transPartDesc x
|
||||
PartSuggestion ss x -> ss ++ transPartDesc x
|
||||
PartRedirect _ x -> transPartDesc x
|
||||
PartReorder xs -> xs >>= transPartDesc
|
||||
PartMany x -> transPartDesc x
|
||||
PartWithHelp _h x -> transPartDesc x
|
||||
---------------------------------------------------------------- vvv hindent vvv
|
||||
completion :: String -> CommandDesc a -> String -> String
|
||||
completion cmdline desc pcRest =
|
||||
List.drop (List.length lastWord) $
|
||||
case choices of
|
||||
[] -> ""
|
||||
(c1:cr) ->
|
||||
headDef "" $
|
||||
filter (\s -> List.all (s `isPrefixOf`) cr) $ reverse $ List.inits c1
|
||||
where
|
||||
nameDesc =
|
||||
case _cmd_mParent desc of
|
||||
Nothing -> desc
|
||||
Just (_, parent)
|
||||
| null pcRest -> parent
|
||||
Just {} -> desc
|
||||
lastWord = reverse $ takeWhile (not . isSpace) $ reverse $ cmdline
|
||||
choices =
|
||||
join
|
||||
[ [ r
|
||||
| Just r <-
|
||||
Foldable.toList (_cmd_children nameDesc) <&> \(s, _) ->
|
||||
[s | lastWord `isPrefixOf` s]
|
||||
]
|
||||
, [ s
|
||||
| s <- transPartDesc =<< _cmd_parts nameDesc
|
||||
, lastWord `isPrefixOf` s
|
||||
]
|
||||
]
|
||||
transPartDesc :: PartDesc -> [String]
|
||||
transPartDesc =
|
||||
\case
|
||||
PartLiteral s -> [s]
|
||||
PartVariable _ -> []
|
||||
PartOptional x -> transPartDesc x
|
||||
PartAlts alts -> alts >>= transPartDesc
|
||||
PartSeq [] -> []
|
||||
PartSeq (x:_) -> transPartDesc x
|
||||
PartDefault _ x -> transPartDesc x
|
||||
PartSuggestion ss x -> ss ++ transPartDesc x
|
||||
PartRedirect _ x -> transPartDesc x
|
||||
PartReorder xs -> xs >>= transPartDesc
|
||||
PartMany x -> transPartDesc x
|
||||
PartWithHelp _h x -> transPartDesc x
|
||||
------------------------------------------------------ vvv haskell-formatter vvv
|
||||
completion :: String -> CommandDesc a -> String -> String
|
||||
completion cmdline desc pcRest
|
||||
= List.drop (List.length lastWord) $
|
||||
case choices of
|
||||
[] -> ""
|
||||
(c1 : cr) -> headDef "" $
|
||||
filter (\ s -> List.all (s `isPrefixOf`) cr) $
|
||||
reverse $ List.inits c1
|
||||
|
||||
where nameDesc
|
||||
= case _cmd_mParent desc of
|
||||
Nothing -> desc
|
||||
Just (_, parent) | null pcRest -> parent
|
||||
Just{} -> desc
|
||||
lastWord = reverse $ takeWhile (not . isSpace) $ reverse $ cmdline
|
||||
choices
|
||||
= join
|
||||
[[r |
|
||||
Just r <- Foldable.toList (_cmd_children nameDesc) <&>
|
||||
\ (s, _) -> [s | lastWord `isPrefixOf` s]],
|
||||
|
||||
[s | s <- transPartDesc =<< _cmd_parts nameDesc,
|
||||
lastWord `isPrefixOf` s]]
|
||||
|
||||
transPartDesc :: PartDesc -> [String]
|
||||
transPartDesc
|
||||
= \case
|
||||
PartLiteral s -> [s]
|
||||
PartVariable _ -> []
|
||||
PartOptional x -> transPartDesc x
|
||||
PartAlts alts -> alts >>= transPartDesc
|
||||
PartSeq [] -> []
|
||||
PartSeq (x : _) -> transPartDesc x
|
||||
PartDefault _ x -> transPartDesc x
|
||||
PartSuggestion ss x -> ss ++ transPartDesc x
|
||||
PartRedirect _ x -> transPartDesc x
|
||||
PartReorder xs -> xs >>= transPartDesc
|
||||
PartMany x -> transPartDesc x
|
||||
PartWithHelp _h x -> transPartDesc x
|
||||
--------------------------------------------------------------------------------
|
||||
~~~~
|
||||
|
||||
## another long example; full module
|
||||
|
||||
~~~~.hs
|
||||
-- 10 20 30 40 50 60 70 80
|
||||
--------------------------------------------------------------- vvv brittany vvv
|
||||
module Language.Haskell.Brittany.BriLayouter
|
||||
( layoutBriDoc
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
|
||||
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
|
||||
layoutBriDoc ast briDoc = do
|
||||
-- first step: transform the briDoc.
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyFloating >>= mSet
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyColumns >>= mSet
|
||||
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
|
||||
-- -- convert to Simple type
|
||||
-- simpl <- mGet <&> transformToSimple
|
||||
-- return simpl
|
||||
|
||||
anns :: ExactPrint.Types.Anns <- mAsk
|
||||
let filteredAnns = filterAnns ast anns
|
||||
|
||||
let state = LayoutState
|
||||
{ _lstate_baseY = 0
|
||||
, _lstate_curY = 0
|
||||
, _lstate_indLevel = 0
|
||||
, _lstate_indLevelLinger = 0
|
||||
, _lstate_commentsPrior = extractCommentsPrior filteredAnns
|
||||
, _lstate_commentsPost = extractCommentsPost filteredAnns
|
||||
, _lstate_commentCol = Nothing
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
, _lstate_isNewline = NewLineStateInit
|
||||
}
|
||||
|
||||
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
||||
|
||||
let remainingComments = Map.elems (_lstate_commentsPrior state')
|
||||
++ Map.elems (_lstate_commentsPost state')
|
||||
remainingComments
|
||||
`forM_` (mTell . (:[]) . LayoutErrorUnusedComment . show . fmap fst)
|
||||
|
||||
return $ ()
|
||||
---------------------------------------------------------------- vvv hindent vvv
|
||||
-- (overflowing columns)
|
||||
module Language.Haskell.Brittany.BriLayouter
|
||||
( layoutBriDoc
|
||||
) where
|
||||
|
||||
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
|
||||
layoutBriDoc ast briDoc
|
||||
-- first step: transform the briDoc.
|
||||
= 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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyFloating >>= mSet
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyColumns >>= mSet
|
||||
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
|
||||
-- -- convert to Simple type
|
||||
-- simpl <- mGet <&> transformToSimple
|
||||
-- return simpl
|
||||
anns :: ExactPrint.Types.Anns <- mAsk
|
||||
let filteredAnns = filterAnns ast anns
|
||||
let state =
|
||||
LayoutState
|
||||
{ _lstate_baseY = 0
|
||||
, _lstate_curY = 0
|
||||
, _lstate_indLevel = 0
|
||||
, _lstate_indLevelLinger = 0
|
||||
, _lstate_commentsPrior = extractCommentsPrior filteredAnns
|
||||
, _lstate_commentsPost = extractCommentsPost filteredAnns
|
||||
, _lstate_commentCol = Nothing
|
||||
, _lstate_addSepSpace = Nothing
|
||||
, _lstate_inhibitMTEL = False
|
||||
, _lstate_isNewline = NewLineStateInit
|
||||
}
|
||||
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
||||
let remainingComments =
|
||||
Map.elems (_lstate_commentsPrior state') ++
|
||||
Map.elems (_lstate_commentsPost state')
|
||||
remainingComments `forM_`
|
||||
(mTell . (: []) . LayoutErrorUnusedComment . show . fmap fst)
|
||||
return $ ()
|
||||
------------------------------------------------------ vvv haskell-formatter vvv
|
||||
module Language.Haskell.Brittany.BriLayouter (layoutBriDoc) where
|
||||
|
||||
layoutBriDoc :: Data.Data.Data ast => ast -> BriDocNumbered -> PPM ()
|
||||
layoutBriDoc ast briDoc
|
||||
-- first step: transform the briDoc.
|
||||
= 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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyFloating >>= mSet
|
||||
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
|
||||
-- bridoc transformation: float stuff in
|
||||
mGet <&> transformSimplifyColumns >>= mSet
|
||||
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
|
||||
-- -- convert to Simple type
|
||||
-- simpl <- mGet <&> transformToSimple
|
||||
-- return simpl
|
||||
anns :: ExactPrint.Types.Anns <- mAsk
|
||||
let filteredAnns = filterAnns ast anns
|
||||
let state
|
||||
= LayoutState{_lstate_baseY = 0, _lstate_curY = 0,
|
||||
_lstate_indLevel = 0, _lstate_indLevelLinger = 0,
|
||||
_lstate_commentsPrior =
|
||||
extractCommentsPrior filteredAnns,
|
||||
_lstate_commentsPost =
|
||||
extractCommentsPost filteredAnns,
|
||||
_lstate_commentCol = Nothing,
|
||||
_lstate_addSepSpace = Nothing,
|
||||
_lstate_inhibitMTEL = False,
|
||||
_lstate_isNewline = NewLineStateInit}
|
||||
|
||||
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
|
||||
let remainingComments
|
||||
= Map.elems (_lstate_commentsPrior state') ++
|
||||
Map.elems (_lstate_commentsPost state')
|
||||
remainingComments `forM_`
|
||||
(mTell . (: []) . LayoutErrorUnusedComment . show . fmap fst)
|
||||
return $ ()
|
||||
~~~~
|
||||
|
|
@ -0,0 +1,98 @@
|
|||
# Horizontal alignment example layouts
|
||||
|
||||
Last updated for brittany version `0.8.0.1`.
|
||||
|
||||
Brittany would layout the following bindings as displayed here. If you change
|
||||
only the layout of these bindings in some way (e.g. if you initially entered
|
||||
these without any alignment) and pass it through brittany, you would (again)
|
||||
get the below versions.
|
||||
|
||||
|
||||
#### basic nested alignment example
|
||||
|
||||
~~~~.hs
|
||||
func (MyLongFoo abc def) = 1
|
||||
func (Bar a d ) = 2
|
||||
func _ = 3
|
||||
~~~~
|
||||
|
||||
#### alignment of function args and monadcomp bindings
|
||||
|
||||
~~~~.hs
|
||||
myBinding =
|
||||
[ [ [ LeguEosb r1 (n2 - r1) fxvoNz ymuSreje v
|
||||
, LeguEosb n2 (f3 - n2) oyphEmedn ymuSreje v
|
||||
, LeguEosb f3 (i4 - f3) fxvoNz ymuSreje v
|
||||
, LeguEosb i4 (v5 - i4) oieha ymuSreje v
|
||||
, LeguEosb v5 (j6 - v5) fxvoNz ymuSreje v
|
||||
]
|
||||
| oyphEmedn <- sdliWmguje
|
||||
, oieha <- ohzvIp
|
||||
]
|
||||
| v5 < j6
|
||||
, sdliWmguje <- zedoaregeuKilb tua1
|
||||
, ohzvIp <- zedoaregeuKilb (0 - loy2)
|
||||
]
|
||||
~~~~
|
||||
|
||||
#### pattern matching
|
||||
|
||||
If same number of pattern args, there is sub-alignment.
|
||||
Types are not inspected in any way for this.
|
||||
|
||||
~~~~.hs
|
||||
transPartDesc = \case
|
||||
PartLiteral s -> [s]
|
||||
PartVariable _ -> []
|
||||
PartOptional x -> transPartDesc x
|
||||
PartAlts alts -> alts >>= transPartDesc
|
||||
PartSeq [] -> []
|
||||
PartSeq (x:_) -> transPartDesc x
|
||||
PartDefault _ x -> transPartDesc x
|
||||
PartSuggestion ss x -> ss ++ transPartDesc x
|
||||
PartRedirect _ x -> transPartDesc x
|
||||
PartReorder xs -> xs >>= transPartDesc
|
||||
PartMany x -> transPartDesc x
|
||||
PartWithHelp _h x -> transPartDesc x
|
||||
~~~~
|
||||
|
||||
#### record syntax, field alignment
|
||||
|
||||
~~~~.hs
|
||||
action = do
|
||||
startA <- transRelPos start
|
||||
s1 <- get
|
||||
modify $ \s2 -> s2 { _ts_sequencePos = Nothing
|
||||
, _ts_curNote = _ts_curNote s1
|
||||
, _ts_curTrans = _ts_curTrans s1
|
||||
, _ts_curBar = _ts_curBar s1
|
||||
, _ts_curBase = _ts_curBase s1
|
||||
}
|
||||
~~~~
|
||||
|
||||
#### items that are not single-line break up alignment
|
||||
|
||||
~~~~.hs
|
||||
action = do
|
||||
_ <- string "set"
|
||||
bindId <- onlySpaces *> ((,) <$> getPosition <*> parserIdent)
|
||||
marg <- onlySpaces *> optionMaybe (char '(' *> parserParamDef <* char ')')
|
||||
localId <-
|
||||
onlySpaces *> (optionMaybe $ string "in" *> onlySpaces *> parserIdent)
|
||||
_ <- onlySpaces *> string "="
|
||||
expr <- spaces *> parserExpr
|
||||
pure $ CompNotParseItemBind bindId marg expr localId
|
||||
~~~~
|
||||
|
||||
consequently these `<-` are not aligned at all:
|
||||
|
||||
~~~~.hs
|
||||
action = do
|
||||
normVal :: Float <- expectParamE
|
||||
=<< expectDynamic (Text.pack "foldInNormalize")
|
||||
ResponseNode folderC folderN <- uncurry callBExpectS
|
||||
=<< getKalinAndParams (Text.pack "foldInFolder")
|
||||
ResponseNode foldeeC foldeeN <- uncurry callBExpectS
|
||||
=<< getKalinAndParams (Text.pack "foldInFoldee")
|
||||
pure $ calc normVal folderC folderN foldeeC foldeeN
|
||||
~~~~
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
# Syntactical element interaction example layouts
|
||||
|
||||
Last updated for brittany version `0.8.0.1`.
|
||||
|
||||
Brittany would layout the following bindings as displayed here. If you change
|
||||
only the layout of these bindings in some way (e.g. if some lines overflowed
|
||||
80 columns) and pass it through brittany, you would again get the below
|
||||
versions.
|
||||
|
||||
|
||||
#### Nested ifs
|
||||
|
||||
~~~~.hs
|
||||
mybinding = if condition1
|
||||
then if condition2
|
||||
then if condition3 then 0 else 1
|
||||
else if condition3 then 2 else 3
|
||||
else 4
|
||||
~~~~
|
||||
|
||||
#### if -> case -> do
|
||||
|
||||
~~~~.hs
|
||||
mybinding = if GHC.xopt GHC.Cpp dynFlags
|
||||
then case cppMode of
|
||||
CPPModeAbort -> do
|
||||
return $ Left "Encountered -XCPP. Aborting."
|
||||
CPPModeWarn -> do
|
||||
putStrErrLn
|
||||
$ "Warning: Encountered -XCPP."
|
||||
++ " Be warned that -XCPP is not supported and that"
|
||||
++ " brittany cannot check that its output is syntactically"
|
||||
++ " valid in its presence."
|
||||
return $ Right True
|
||||
CPPModeNowarn -> return $ Right True
|
||||
else return $ Right False
|
||||
~~~~
|
||||
|
||||
#### single line ending with start of do-block
|
||||
|
||||
~~~~.hs
|
||||
mybinding = RH.performEvent_ $ postBuild <&> \() -> liftIO $ do
|
||||
runMaybeT postCliInit >>= \case
|
||||
Nothing -> return ()
|
||||
Just () -> do
|
||||
_ <- forkIO $ postCliInitAsync `catch` \(e :: SomeException) ->
|
||||
writeLogS LogLevelError (show e)
|
||||
return ()
|
||||
~~~~
|
||||
|
||||
#### record-syntax + do-block
|
||||
|
||||
~~~~.hs
|
||||
myBinding = Booh
|
||||
{ booh_id = name
|
||||
, booh_parser = name
|
||||
, booh_query = someLongFunction name ["thingy"] $ do
|
||||
cps <- zu (Text.pack "thingy")
|
||||
SampleRate sri <- askConfig' conf_defaultSampleRate
|
||||
buildLinearState myBinding [cps]
|
||||
}
|
||||
~~~~
|
||||
|
||||
|
|
@ -0,0 +1,65 @@
|
|||
# Example type signature layouts
|
||||
|
||||
Last updated for brittany version `0.8.0.1`.
|
||||
|
||||
Brittany would layout the following signatures as displayed here. If you change
|
||||
only the layout of these signatures in some way (e.g. if you initially entered
|
||||
them as one-liners) and pass it through brittany, you would (again) get the
|
||||
below versions.
|
||||
|
||||
~~~~.hs
|
||||
docExt
|
||||
:: (ExactPrint.Annotate.Annotate ast)
|
||||
=> Located ast
|
||||
-> ExactPrint.Types.Anns
|
||||
-> Bool
|
||||
-> ToBriDocM BriDocNumbered
|
||||
~~~~
|
||||
|
||||
~~~~.hs
|
||||
processDefault
|
||||
:: ( ExactPrint.Annotate.Annotate ast
|
||||
, MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiReader ExactPrint.Types.Anns m
|
||||
)
|
||||
=> Located ast
|
||||
-> m ()
|
||||
~~~~
|
||||
|
||||
~~~~.hs
|
||||
linewise
|
||||
:: forall n t
|
||||
. (Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t))
|
||||
=> ( R.Event t Text -- command string executed by user
|
||||
-> R.Dynamic t (Maybe Text, Int, Text)
|
||||
-> R.Behavior t (Seq Text) -- history
|
||||
-> R.Event t () -- post-shutdown
|
||||
-> RH.AppHost
|
||||
t
|
||||
( R.Event t () -- shutdown trigger
|
||||
, R.Behavior t String -- tab-completion value
|
||||
, R.Dynamic t (Widget n)
|
||||
)
|
||||
)
|
||||
-> RH.AppHost t ()
|
||||
~~~~
|
||||
|
||||
linewise ::
|
||||
forall n t.
|
||||
(Ord n, R.ReflexHost t, MonadIO (R.PushM t), MonadIO (R.HostFrame t))
|
||||
=> (R.Event t Text -- command string executed by user
|
||||
-> R.Dynamic t (Maybe Text, Int, Text) -> R.Behavior t (Seq Text) -- history
|
||||
-> R.Event t () -- post-shutdown
|
||||
-> RH.AppHost t ( R.Event t () -- shutdown trigger
|
||||
, R.Behavior t String -- tab-completion value
|
||||
, R.Dynamic t (Widget n)))
|
||||
-> RH.AppHost t ()
|
||||
|
||||
|
||||
processDefault ::
|
||||
( ExactPrint.Annotate.Annotate ast
|
||||
, MonadMultiWriter Text.Builder.Builder m
|
||||
, MonadMultiReader ExactPrint.Types.Anns m
|
||||
)
|
||||
=> Located ast
|
||||
-> m ()
|
||||
|
|
@ -0,0 +1,168 @@
|
|||
|
||||
### Input
|
||||
|
||||
contains some very long lines and strange formatting of the
|
||||
list/monad-comprehension:
|
||||
|
||||
~~~~.hs
|
||||
parseCalUnits :: forall m . (MonadMultiReader ParserWrapperGuard m, MonadMultiState ParserFileCache m, MonadIO m) => [GenericParser] -> [FilePath] -> m (Either Text [CalUnit])
|
||||
parseCalUnits parsers inputs = fmap (fmap join . sequence) $ inputs `forM` \path -> do
|
||||
readCachedFile path (\raw -> parseChunks $ createChunks $ (Text.pack path, raw))
|
||||
where
|
||||
|
||||
createChunks :: (Text, Text) -> [(Text, [(Int, InputLine)])]
|
||||
createChunks (file, input) = fmap ((,) file) $ groupBy (\a b -> grouper (snd a) (snd b)) $ dropWhile (lineIsSpace . snd) $ zip [1 ..] $ lineMapper <$> Text.lines input
|
||||
where
|
||||
headerParser :: Parser (Text, Bool, Text)
|
||||
headerParser =
|
||||
[ (Text.pack name, isMain, Text.pack typ)
|
||||
| _ <- string "node", _ <- many1 $ oneOf " \t",
|
||||
isMain <- fmap isJust $ optionMaybe (string "*" *> many1 (oneOf " \t")),
|
||||
name <- many1 $ noneOf " \t\r\n:",
|
||||
_ <- many $ oneOf " \t",
|
||||
_ <- char ':',
|
||||
_ <- many $ oneOf " \t",
|
||||
typ <- many1 $ satisfy $ not . isSpace,
|
||||
_ <- many $ oneOf " \t",
|
||||
_ <- eof ]
|
||||
lineMapper :: Text -> InputLine
|
||||
lineMapper line = case runParser headerParser () "" line of
|
||||
Left _e -> NormalLine line
|
||||
Right (n, m, t) -> HeaderLine n m t
|
||||
lineIsSpace :: InputLine -> Bool
|
||||
lineIsSpace (NormalLine x) = Text.null $ Text.strip x
|
||||
lineIsSpace _ = False
|
||||
grouper :: InputLine -> InputLine -> Bool
|
||||
grouper _ HeaderLine{} = False
|
||||
grouper _ _ = True
|
||||
|
||||
parseChunks :: [(Text, [(Int, InputLine)])] -> m (Either Text [CalUnit])
|
||||
parseChunks nodes = runEitherT $ sequence (uncurry parseNode <$> nodes)
|
||||
where
|
||||
findParser :: Text -> Maybe GenericParser
|
||||
findParser pid = find (\(GenericParser p) -> parser_ident p == pid) parsers
|
||||
parseNode :: Text -> [(Int, InputLine)] -> EitherT Text m CalUnit
|
||||
parseNode file ((n, HeaderLine name isMain typ):rlines) = do
|
||||
(GenericParser p) <- case findParser typ of
|
||||
Nothing -> left $ Text.pack "could not find parser for node \"" <> name <> Text.pack "\" of type \"" <> typ <> Text.pack "\" at " <> file <> Text.pack (": " ++ show n ++ ".")
|
||||
Just x -> return x
|
||||
let firstLine = fromMaybe 0 $ fst <$> listToMaybe rlines
|
||||
ParserDataStore dstore version <- _pfc_store <$> mGet
|
||||
let postfix = Text.pack "\n(When parsing node \"" <> name <> Text.pack "\")"
|
||||
parsed <- bimapEitherT (<>postfix) id $ hoistEither $ parser_parse p file firstLine $ Text.unlines $ [ fst $ Text.breakOn (Text.pack "--") line | (_, NormalLine line) <- rlines ]
|
||||
let oldDat = case M.lookup name dstore of
|
||||
Nothing -> parser_zero p $> version
|
||||
Just s -> case decodeOrFail s of
|
||||
Right (rest, _, decoded) | BSL.null rest -> decoded
|
||||
_ -> parser_zero p $> version
|
||||
let (newDat, delta) = parser_diff p version oldDat (parsed $> version)
|
||||
pfc <- mGet
|
||||
mSet $ pfc { _pfc_store = ParserDataStore (M.insert name (encode newDat) dstore) version }
|
||||
let calUnit = parser_build p version name (newDat, delta)
|
||||
return $ CalUnit isMain calUnit
|
||||
parseNode file ((n, _):_) = left $ Text.pack "expected node definition at " <> file <> Text.pack (": " ++ show n ++ ".")
|
||||
parseNode file _ = left $ Text.pack "expected node definition at " <> file <> Text.pack "."
|
||||
~~~~.hs
|
||||
|
||||
### Brittany 0.8.0.1 output on default settings
|
||||
|
||||
~~~~.hs
|
||||
parseCalUnits
|
||||
:: forall m
|
||||
. ( MonadMultiReader ParserWrapperGuard m
|
||||
, MonadMultiState ParserFileCache m
|
||||
, MonadIO m
|
||||
)
|
||||
=> [GenericParser]
|
||||
-> [FilePath]
|
||||
-> m (Either Text [CalUnit])
|
||||
parseCalUnits parsers inputs =
|
||||
fmap (fmap join . sequence) $ inputs `forM` \path -> do
|
||||
readCachedFile
|
||||
path
|
||||
(\raw -> parseChunks $ createChunks $ (Text.pack path, raw))
|
||||
where
|
||||
|
||||
createChunks :: (Text, Text) -> [(Text, [(Int, InputLine)])]
|
||||
createChunks (file, input) =
|
||||
fmap ((,) file)
|
||||
$ groupBy (\a b -> grouper (snd a) (snd b))
|
||||
$ dropWhile (lineIsSpace . snd)
|
||||
$ zip [1 ..]
|
||||
$ lineMapper
|
||||
<$> Text.lines input
|
||||
where
|
||||
headerParser :: Parser (Text, Bool, Text)
|
||||
headerParser =
|
||||
[ (Text.pack name, isMain, Text.pack typ)
|
||||
| _ <- string "node"
|
||||
, _ <- many1 $ oneOf " \t"
|
||||
, isMain <- fmap isJust $ optionMaybe (string "*" *> many1 (oneOf " \t"))
|
||||
, name <- many1 $ noneOf " \t\r\n:"
|
||||
, _ <- many $ oneOf " \t"
|
||||
, _ <- char ':'
|
||||
, _ <- many $ oneOf " \t"
|
||||
, typ <- many1 $ satisfy $ not . isSpace
|
||||
, _ <- many $ oneOf " \t"
|
||||
, _ <- eof
|
||||
]
|
||||
lineMapper :: Text -> InputLine
|
||||
lineMapper line = case runParser headerParser () "" line of
|
||||
Left _e -> NormalLine line
|
||||
Right (n, m, t) -> HeaderLine n m t
|
||||
lineIsSpace :: InputLine -> Bool
|
||||
lineIsSpace (NormalLine x) = Text.null $ Text.strip x
|
||||
lineIsSpace _ = False
|
||||
grouper :: InputLine -> InputLine -> Bool
|
||||
grouper _ HeaderLine{} = False
|
||||
grouper _ _ = True
|
||||
|
||||
parseChunks :: [(Text, [(Int, InputLine)])] -> m (Either Text [CalUnit])
|
||||
parseChunks nodes = runEitherT $ sequence (uncurry parseNode <$> nodes)
|
||||
where
|
||||
findParser :: Text -> Maybe GenericParser
|
||||
findParser pid = find (\(GenericParser p) -> parser_ident p == pid) parsers
|
||||
parseNode :: Text -> [(Int, InputLine)] -> EitherT Text m CalUnit
|
||||
parseNode file ((n, HeaderLine name isMain typ):rlines) = do
|
||||
(GenericParser p) <- case findParser typ of
|
||||
Nothing ->
|
||||
left
|
||||
$ Text.pack "could not find parser for node \""
|
||||
<> name
|
||||
<> Text.pack "\" of type \""
|
||||
<> typ
|
||||
<> Text.pack "\" at "
|
||||
<> file
|
||||
<> Text.pack (": " ++ show n ++ ".")
|
||||
Just x -> return x
|
||||
let firstLine = fromMaybe 0 $ fst <$> listToMaybe rlines
|
||||
ParserDataStore dstore version <- _pfc_store <$> mGet
|
||||
let postfix =
|
||||
Text.pack "\n(When parsing node \"" <> name <> Text.pack "\")"
|
||||
parsed <-
|
||||
bimapEitherT (<>postfix) id
|
||||
$ hoistEither
|
||||
$ parser_parse p file firstLine
|
||||
$ Text.unlines
|
||||
$ [ fst $ Text.breakOn (Text.pack "--") line
|
||||
| (_, NormalLine line) <- rlines
|
||||
]
|
||||
let oldDat = case M.lookup name dstore of
|
||||
Nothing -> parser_zero p $> version
|
||||
Just s -> case decodeOrFail s of
|
||||
Right (rest, _, decoded) | BSL.null rest -> decoded
|
||||
_ -> parser_zero p $> version
|
||||
let (newDat, delta) = parser_diff p version oldDat (parsed $> version)
|
||||
pfc <- mGet
|
||||
mSet $ pfc
|
||||
{ _pfc_store = ParserDataStore (M.insert name (encode newDat) dstore)
|
||||
version
|
||||
}
|
||||
let calUnit = parser_build p version name (newDat, delta)
|
||||
return $ CalUnit isMain calUnit
|
||||
parseNode file ((n, _):_) =
|
||||
left $ Text.pack "expected node definition at " <> file <> Text.pack
|
||||
(": " ++ show n ++ ".")
|
||||
parseNode file _ =
|
||||
left $ Text.pack "expected node definition at " <> file <> Text.pack "."
|
||||
~~~~
|
||||
Loading…
Reference in New Issue