Apply autoformatting and Refactor slightly
parent
0f5aa00bb3
commit
548f2ccd8f
|
|
@ -5,7 +5,6 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module UI.Butcher.Monadic.Internal.Core
|
||||
( addCmdSynopsis
|
||||
, addCmdHelp
|
||||
|
|
@ -39,14 +38,21 @@ where
|
|||
|
||||
#include "prelude.inc"
|
||||
import Control.Monad.Free
|
||||
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
|
||||
import qualified Control.Monad.Trans.MultiState.Strict as MultiStateS
|
||||
import qualified Control.Monad.Trans.MultiRWS.Strict
|
||||
as MultiRWSS
|
||||
import qualified Control.Monad.Trans.MultiState.Strict
|
||||
as MultiStateS
|
||||
|
||||
import qualified Lens.Micro as Lens
|
||||
import Lens.Micro ( (%~), (.~) )
|
||||
import Lens.Micro ( (%~)
|
||||
, (.~)
|
||||
)
|
||||
|
||||
import qualified Text.PrettyPrint as PP
|
||||
import Text.PrettyPrint ( (<+>), ($$), ($+$) )
|
||||
import Text.PrettyPrint ( (<+>)
|
||||
, ($$)
|
||||
, ($+$)
|
||||
)
|
||||
|
||||
import Data.HList.ContainsType
|
||||
|
||||
|
|
@ -67,12 +73,10 @@ mModify f = mGet >>= mSet . f
|
|||
-- arising around s in the signatures below. That's the price of not having
|
||||
-- the functional dependency in MonadMulti*T.
|
||||
|
||||
(.=+) :: MonadMultiState s m
|
||||
=> Lens.ASetter s s a b -> b -> m ()
|
||||
(.=+) :: MonadMultiState s m => Lens.ASetter s s a b -> b -> m ()
|
||||
l .=+ b = mModify $ l .~ b
|
||||
|
||||
(%=+) :: MonadMultiState s m
|
||||
=> Lens.ASetter s s a b -> (a -> b) -> m ()
|
||||
(%=+) :: MonadMultiState s m => Lens.ASetter s s a b -> (a -> b) -> m ()
|
||||
l %=+ f = mModify (l %~ f)
|
||||
|
||||
-- inflateStateProxy :: (Monad m, ContainsType s ss)
|
||||
|
|
@ -306,29 +310,35 @@ descStackAdd d = \case
|
|||
-- This method also yields a _complete_ @CommandDesc@ output, where the other
|
||||
-- runCmdParser* functions all traverse only a shallow structure around the
|
||||
-- parts of the 'CmdParser' touched while parsing the current input.
|
||||
checkCmdParser :: forall f out
|
||||
checkCmdParser
|
||||
:: forall f out
|
||||
. Maybe String -- ^ top-level command name
|
||||
-> CmdParser f out () -- ^ parser to check
|
||||
-> Either String (CommandDesc ())
|
||||
checkCmdParser mTopLevel cmdParser
|
||||
= (>>= final)
|
||||
checkCmdParser mTopLevel cmdParser =
|
||||
(>>= final)
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiStateAS (StackBottom mempty)
|
||||
$ MultiRWSS.withMultiStateS emptyCommandDesc
|
||||
$ processMain cmdParser
|
||||
where
|
||||
final :: (CommandDesc out, CmdDescStack)
|
||||
-> Either String (CommandDesc ())
|
||||
final (desc, stack)
|
||||
= case stack of
|
||||
StackBottom descs -> Right
|
||||
$ descFixParentsWithTopM (mTopLevel <&> \n -> (Just n, emptyCommandDesc))
|
||||
$ () <$ desc
|
||||
{ _cmd_parts = Data.Foldable.toList descs
|
||||
}
|
||||
final :: (CommandDesc out, CmdDescStack) -> Either String (CommandDesc ())
|
||||
final (desc, stack) = case stack of
|
||||
StackBottom descs ->
|
||||
Right
|
||||
$ descFixParentsWithTopM
|
||||
(mTopLevel <&> \n -> (Just n, emptyCommandDesc))
|
||||
$ ()
|
||||
<$ desc { _cmd_parts = Data.Foldable.toList descs }
|
||||
StackLayer _ _ _ -> Left "unclosed ReorderStart or GroupStart"
|
||||
processMain :: CmdParser f out ()
|
||||
-> MultiRWSS.MultiRWST '[] '[] '[CommandDesc out, CmdDescStack] (Either String) ()
|
||||
processMain
|
||||
:: CmdParser f out ()
|
||||
-> MultiRWSS.MultiRWST
|
||||
'[]
|
||||
'[]
|
||||
'[CommandDesc out, CmdDescStack]
|
||||
(Either String)
|
||||
()
|
||||
processMain = \case
|
||||
Pure x -> return x
|
||||
Free (CmdParserHelp h next) -> do
|
||||
|
|
@ -398,7 +408,9 @@ checkCmdParser mTopLevel cmdParser
|
|||
StackLayer _descs "" _up -> do
|
||||
lift $ Left $ "GroupEnd found, but expected ReorderStop first"
|
||||
StackLayer descs groupName up -> do
|
||||
mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up
|
||||
mSet $ descStackAdd
|
||||
(PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))
|
||||
up
|
||||
processMain $ next
|
||||
Free (CmdParserReorderStop next) -> do
|
||||
stackCur <- mGet
|
||||
|
|
@ -406,7 +418,8 @@ checkCmdParser mTopLevel cmdParser
|
|||
StackBottom{} -> lift $ Left $ "ReorderStop without reorderStart"
|
||||
StackLayer descs "" up -> do
|
||||
mSet $ descStackAdd (PartReorder (Data.Foldable.toList descs)) up
|
||||
StackLayer{} -> lift $ Left $ "Found ReorderStop, but need GroupEnd first"
|
||||
StackLayer{} ->
|
||||
lift $ Left $ "Found ReorderStop, but need GroupEnd first"
|
||||
processMain next
|
||||
Free (CmdParserReorderStart next) -> do
|
||||
stackCur <- mGet
|
||||
|
|
@ -414,7 +427,10 @@ checkCmdParser mTopLevel cmdParser
|
|||
processMain next
|
||||
|
||||
monadMisuseError :: a
|
||||
monadMisuseError = error "CmdParser definition error - used Monad powers where only Applicative/Arrow is allowed"
|
||||
monadMisuseError =
|
||||
error
|
||||
$ "CmdParser definition error -"
|
||||
++ " used Monad powers where only Applicative/Arrow is allowed"
|
||||
|
||||
newtype PastCommandInput = PastCommandInput Input
|
||||
|
||||
|
|
@ -433,9 +449,8 @@ runCmdParser
|
|||
-> Input -- ^ input to be processed
|
||||
-> CmdParser Identity out () -- ^ parser to use
|
||||
-> (CommandDesc (), Either ParsingError (CommandDesc out))
|
||||
runCmdParser mTopLevel inputInitial cmdParser
|
||||
= runIdentity
|
||||
$ runCmdParserA mTopLevel inputInitial cmdParser
|
||||
runCmdParser mTopLevel inputInitial cmdParser =
|
||||
runIdentity $ runCmdParserA mTopLevel inputInitial cmdParser
|
||||
|
||||
-- | Like 'runCmdParser', but also returning all input after the last
|
||||
-- successfully parsed subcommand. E.g. for some input
|
||||
|
|
@ -446,31 +461,34 @@ runCmdParserExt
|
|||
-> Input -- ^ input to be processed
|
||||
-> CmdParser Identity out () -- ^ parser to use
|
||||
-> (CommandDesc (), Input, Either ParsingError (CommandDesc out))
|
||||
runCmdParserExt mTopLevel inputInitial cmdParser
|
||||
= runIdentity
|
||||
$ runCmdParserAExt mTopLevel inputInitial cmdParser
|
||||
runCmdParserExt mTopLevel inputInitial cmdParser =
|
||||
runIdentity $ runCmdParserAExt mTopLevel inputInitial cmdParser
|
||||
|
||||
-- | The Applicative-enabled version of 'runCmdParser'.
|
||||
runCmdParserA :: forall f out
|
||||
runCmdParserA
|
||||
:: forall f out
|
||||
. Applicative f
|
||||
=> Maybe String -- ^ program name to be used for the top-level @CommandDesc@
|
||||
-> Input -- ^ input to be processed
|
||||
-> CmdParser f out () -- ^ parser to use
|
||||
-> f ( CommandDesc ()
|
||||
, Either ParsingError (CommandDesc out)
|
||||
)
|
||||
-> f (CommandDesc (), Either ParsingError (CommandDesc out))
|
||||
runCmdParserA mTopLevel inputInitial cmdParser =
|
||||
(\(x, _, z) -> (x, z)) <$> runCmdParserAExt mTopLevel inputInitial cmdParser
|
||||
|
||||
-- | The Applicative-enabled version of 'runCmdParserExt'.
|
||||
runCmdParserAExt
|
||||
:: forall f out . Applicative f
|
||||
:: forall f out
|
||||
. Applicative f
|
||||
=> Maybe String -- ^ program name to be used for the top-level @CommandDesc@
|
||||
-> Input -- ^ input to be processed
|
||||
-> CmdParser f out () -- ^ parser to use
|
||||
-> f (CommandDesc (), Input, Either ParsingError (CommandDesc out))
|
||||
runCmdParserAExt mTopLevel inputInitial cmdParser
|
||||
= runIdentity
|
||||
-> f
|
||||
( CommandDesc ()
|
||||
, Input
|
||||
, Either ParsingError (CommandDesc out)
|
||||
)
|
||||
runCmdParserAExt mTopLevel inputInitial cmdParser =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ (<&> captureFinal)
|
||||
$ MultiRWSS.withMultiWriterWA
|
||||
|
|
@ -482,13 +500,20 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
$ processMain cmdParser
|
||||
where
|
||||
initialCommandDesc = emptyCommandDesc
|
||||
{ _cmd_mParent = mTopLevel <&> \n -> (Just n, emptyCommandDesc) }
|
||||
{ _cmd_mParent = mTopLevel <&> \n -> (Just n, emptyCommandDesc)
|
||||
}
|
||||
captureFinal
|
||||
:: ([String], (CmdDescStack, (Input, (PastCommandInput, (CommandDesc out, f())))))
|
||||
:: ( [String]
|
||||
, (CmdDescStack, (Input, (PastCommandInput, (CommandDesc out, f ()))))
|
||||
)
|
||||
-> f (CommandDesc (), Input, Either ParsingError (CommandDesc out))
|
||||
captureFinal (errs, (descStack, (inputRest, (PastCommandInput pastCmdInput, (cmd, act))))) =
|
||||
act $> (() <$ cmd', pastCmdInput, res)
|
||||
captureFinal tuple1 = act $> (() <$ cmd', pastCmdInput, res)
|
||||
where
|
||||
(errs , tuple2) = tuple1
|
||||
(descStack , tuple3) = tuple2
|
||||
(inputRest , tuple4) = tuple3
|
||||
(PastCommandInput pastCmdInput, tuple5) = tuple4
|
||||
(cmd , act ) = tuple5
|
||||
errs' = errs ++ inputErrs ++ stackErrs
|
||||
inputErrs = case inputRest of
|
||||
InputString s | all Char.isSpace s -> []
|
||||
|
|
@ -499,14 +524,17 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
StackBottom{} -> []
|
||||
_ -> ["butcher interface error: unclosed group"]
|
||||
cmd' = postProcessCmd descStack cmd
|
||||
res = if null errs'
|
||||
then Right cmd'
|
||||
else Left $ ParsingError errs' inputRest
|
||||
processMain :: CmdParser f out ()
|
||||
res =
|
||||
if null errs' then Right cmd' else Left $ ParsingError errs' inputRest
|
||||
processMain
|
||||
:: CmdParser f out ()
|
||||
-> MultiRWSS.MultiRWS
|
||||
'[]
|
||||
'[[String]]
|
||||
'[CommandDesc out, PastCommandInput, Input, CmdDescStack, CmdParser f out ()]
|
||||
'[CommandDesc out, PastCommandInput, Input, CmdDescStack, CmdParser
|
||||
f
|
||||
out
|
||||
()]
|
||||
(f ())
|
||||
processMain = \case
|
||||
Pure () -> return $ pure $ ()
|
||||
|
|
@ -525,13 +553,15 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
-- run the rest without affecting the actual stack
|
||||
-- to retrieve the complete cmddesc.
|
||||
cmdCur :: CommandDesc out <- mGet
|
||||
let (cmd :: CommandDesc out, stack)
|
||||
= runIdentity
|
||||
let (cmd :: CommandDesc out, stack) =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiStateSA emptyCommandDesc
|
||||
{ _cmd_mParent = _cmd_mParent cmdCur } -- partialDesc
|
||||
{ _cmd_mParent = _cmd_mParent cmdCur
|
||||
} -- partialDesc
|
||||
$ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack
|
||||
$ iterM processCmdShallow $ parser
|
||||
$ iterM processCmdShallow
|
||||
$ parser
|
||||
processMain $ nextF $ () <$ postProcessCmd stack cmd
|
||||
Free (CmdParserPeekInput nextF) -> do
|
||||
processMain $ nextF $ inputToString inputInitial
|
||||
|
|
@ -642,32 +672,37 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
)
|
||||
(child_name_list, child_map) =
|
||||
foldl' child_fold (mempty, MapS.empty) gatheredChildren
|
||||
combined_child_list = Data.Foldable.toList child_name_list <&> \n ->
|
||||
(n, child_map MapS.! n)
|
||||
let mRest = asum $ combined_child_list <&> \(mname, (child, act, vis)) ->
|
||||
combined_child_list =
|
||||
Data.Foldable.toList child_name_list <&> \n -> (n, child_map MapS.! n)
|
||||
let
|
||||
mRest = asum $ combined_child_list <&> \(mname, (child, act, vis)) ->
|
||||
case (mname, input) of
|
||||
(Just name, InputString str) | name == str ->
|
||||
Just $ (Just name, child, act, vis, InputString "")
|
||||
(Just name, InputString str) | (name ++ " ") `isPrefixOf` str ->
|
||||
Just $ (Just name, child, act, vis, InputString $ drop (length name + 1) str)
|
||||
Just
|
||||
$ ( Just name
|
||||
, child
|
||||
, act
|
||||
, vis
|
||||
, InputString $ drop (length name + 1) str
|
||||
)
|
||||
(Just name, InputArgs (str:strr)) | name == str ->
|
||||
Just $ (Just name, child, act, vis, InputArgs strr)
|
||||
(Nothing, _) ->
|
||||
Just $ (Nothing, child, act, vis, input)
|
||||
(Nothing, _) -> Just $ (Nothing, child, act, vis, input)
|
||||
_ -> Nothing
|
||||
case mRest of
|
||||
Nothing -> do -- a child not matching what we have in the input
|
||||
let initialDesc :: CommandDesc out = emptyCommandDesc
|
||||
-- get the shallow desc for the child in a separate env.
|
||||
combined_child_list `forM_` \(child_name, (child, _, vis)) -> do
|
||||
let (subCmd, subStack)
|
||||
= runIdentity
|
||||
let (subCmd, subStack) =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiStateSA initialDesc
|
||||
$ MultiRWSS.withMultiStateS (StackBottom mempty)
|
||||
$ iterM processCmdShallow child
|
||||
cmd_children
|
||||
%=+ Deque.snoc
|
||||
cmd_children %=+ Deque.snoc
|
||||
( child_name
|
||||
, postProcessCmd subStack subCmd { _cmd_visibility = vis }
|
||||
)
|
||||
|
|
@ -684,8 +719,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
return $ postProcessCmd prevStack c
|
||||
mSet $ rest
|
||||
mSet $ PastCommandInput rest
|
||||
mSet $ emptyCommandDesc
|
||||
{ _cmd_mParent = Just (name, cmd)
|
||||
mSet $ emptyCommandDesc { _cmd_mParent = Just (name, cmd)
|
||||
, _cmd_visibility = vis
|
||||
}
|
||||
mSet $ child
|
||||
|
|
@ -707,21 +741,28 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
mTell $ ["butcher interface error: group end without group start"]
|
||||
return $ pure () -- hard abort should be fine for this case.
|
||||
StackLayer descs groupName up -> do
|
||||
mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up
|
||||
mSet $ descStackAdd
|
||||
(PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))
|
||||
up
|
||||
processMain $ next
|
||||
Free (CmdParserReorderStop next) -> do
|
||||
mTell $ ["butcher interface error: reorder stop without reorder start"]
|
||||
processMain next
|
||||
Free (CmdParserReorderStart next) -> do
|
||||
reorderData <- MultiRWSS.withMultiStateA (1::Int)
|
||||
reorderData <-
|
||||
MultiRWSS.withMultiStateA (1 :: Int)
|
||||
$ MultiRWSS.withMultiWriterW
|
||||
$ iterM reorderPartGather $ next
|
||||
$ iterM reorderPartGather
|
||||
$ next
|
||||
let
|
||||
reorderMapInit :: Map Int (PartGatherData f)
|
||||
reorderMapInit = MapS.fromList $ reorderData <&> \d -> (_pgd_id d, d)
|
||||
tryParsePartData :: Input -> PartGatherData f -> First (Int, Dynamic, Input, Bool, f ())
|
||||
tryParsePartData input (PartGatherData pid _ pfe act allowMany) =
|
||||
First [ (pid, toDyn r, rest, allowMany, act r)
|
||||
tryParsePartData
|
||||
:: Input
|
||||
-> PartGatherData f
|
||||
-> First (Int, Dynamic, Input, Bool, f ())
|
||||
tryParsePartData input (PartGatherData pid _ pfe act allowMany) = First
|
||||
[ (pid, toDyn r, rest, allowMany, act r)
|
||||
| (r, rest) <- case pfe of
|
||||
Left pfStr -> case input of
|
||||
InputString str -> case pfStr str of
|
||||
|
|
@ -749,7 +790,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
mSet $ MapS.delete pid m
|
||||
actRest <- parseLoop
|
||||
return $ act *> actRest
|
||||
(finalMap, (fr, acts)) <- MultiRWSS.withMultiStateSA (MapS.empty :: PartParsedData)
|
||||
(finalMap, (fr, acts)) <-
|
||||
MultiRWSS.withMultiStateSA (MapS.empty :: PartParsedData)
|
||||
$ MultiRWSS.withMultiStateA reorderMapInit
|
||||
$ do
|
||||
acts <- parseLoop -- filling the map
|
||||
|
|
@ -833,13 +875,15 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
-- run the rest without affecting the actual stack
|
||||
-- to retrieve the complete cmddesc.
|
||||
cmdCur :: CommandDesc out <- mGet
|
||||
let (cmd :: CommandDesc out, stack)
|
||||
= runIdentity
|
||||
let (cmd :: CommandDesc out, stack) =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiStateSA emptyCommandDesc
|
||||
{ _cmd_mParent = _cmd_mParent cmdCur } -- partialDesc
|
||||
{ _cmd_mParent = _cmd_mParent cmdCur
|
||||
} -- partialDesc
|
||||
$ MultiRWSS.withMultiStateS (StackBottom mempty) -- partialStack
|
||||
$ iterM processCmdShallow $ parser
|
||||
$ iterM processCmdShallow
|
||||
$ parser
|
||||
childrenGather $ nextF $ () <$ postProcessCmd stack cmd
|
||||
something -> return something
|
||||
|
||||
|
|
@ -859,10 +903,13 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
=> CmdParser f out a
|
||||
-> m (CmdParser f out a)
|
||||
processParsedParts = \case
|
||||
Free (CmdParserPart desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF
|
||||
Free (CmdParserPartInp desc _ _ (nextF :: p -> CmdParser f out a)) -> part desc nextF
|
||||
Free (CmdParserPart desc _ _ (nextF :: p -> CmdParser f out a)) ->
|
||||
part desc nextF
|
||||
Free (CmdParserPartInp desc _ _ (nextF :: p -> CmdParser f out a)) ->
|
||||
part desc nextF
|
||||
Free (CmdParserPartMany bound desc _ _ nextF) -> partMany bound desc nextF
|
||||
Free (CmdParserPartManyInp bound desc _ _ nextF) -> partMany bound desc nextF
|
||||
Free (CmdParserPartManyInp bound desc _ _ nextF) ->
|
||||
partMany bound desc nextF
|
||||
Free (CmdParserReorderStop next) -> do
|
||||
stackCur <- mGet
|
||||
case stackCur of
|
||||
|
|
@ -882,7 +929,9 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
mTell $ ["butcher interface error: group end without group start"]
|
||||
return $ next -- hard abort should be fine for this case.
|
||||
StackLayer descs groupName up -> do
|
||||
mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up
|
||||
mSet $ descStackAdd
|
||||
(PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))
|
||||
up
|
||||
processParsedParts $ next
|
||||
Pure x -> return $ return $ x
|
||||
f -> do
|
||||
|
|
@ -905,8 +954,10 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
mSet $ MapS.delete pid parsedMap
|
||||
partMap :: Map Int (PartGatherData f) <- mGet
|
||||
input :: Input <- mGet
|
||||
let errorResult = do
|
||||
mTell ["could not parse expected input "
|
||||
let
|
||||
errorResult = do
|
||||
mTell
|
||||
[ "could not parse expected input "
|
||||
++ getPartSeqDescPositionName desc
|
||||
++ " with remaining input: "
|
||||
++ show input
|
||||
|
|
@ -914,8 +965,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
failureCurrentShallowRerun
|
||||
processParsedParts $ nextF monadMisuseError
|
||||
continueOrMisuse :: Maybe p -> m (CmdParser f out a)
|
||||
continueOrMisuse = maybe monadMisuseError
|
||||
(processParsedParts . nextF)
|
||||
continueOrMisuse = maybe monadMisuseError (processParsedParts . nextF)
|
||||
case MapS.lookup pid parsedMap of
|
||||
Nothing -> case MapS.lookup pid partMap of
|
||||
Nothing -> monadMisuseError -- it would still be in the map
|
||||
|
|
@ -954,9 +1004,8 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
|
||||
-- this does no error reporting at all.
|
||||
-- user needs to use check for that purpose instead.
|
||||
processCmdShallow :: ( MonadMultiState (CommandDesc out) m
|
||||
, MonadMultiState CmdDescStack m
|
||||
)
|
||||
processCmdShallow
|
||||
:: (MonadMultiState (CommandDesc out) m, MonadMultiState CmdDescStack m)
|
||||
=> CmdParserF f out (m ())
|
||||
-> m ()
|
||||
processCmdShallow = \case
|
||||
|
|
@ -1013,7 +1062,9 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
StackLayer _descs "" _up -> do
|
||||
return ()
|
||||
StackLayer descs groupName up -> do
|
||||
mSet $ descStackAdd (PartRedirect groupName (PartSeq (Data.Foldable.toList descs))) up
|
||||
mSet $ descStackAdd
|
||||
(PartRedirect groupName (PartSeq (Data.Foldable.toList descs)))
|
||||
up
|
||||
next
|
||||
CmdParserReorderStop next -> do
|
||||
stackCur <- mGet
|
||||
|
|
@ -1038,21 +1089,23 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
=> m ()
|
||||
failureCurrentShallowRerun = do
|
||||
parser <- mGet
|
||||
cmd :: CommandDesc out
|
||||
<- MultiRWSS.withMultiStateS emptyCommandDesc
|
||||
cmd :: CommandDesc out <-
|
||||
MultiRWSS.withMultiStateS emptyCommandDesc
|
||||
$ iterM processCmdShallow parser
|
||||
mSet cmd
|
||||
|
||||
postProcessCmd :: CmdDescStack -> CommandDesc out -> CommandDesc out
|
||||
postProcessCmd descStack cmd
|
||||
= descFixParents
|
||||
$ cmd { _cmd_parts = case descStack of
|
||||
postProcessCmd descStack cmd = descFixParents $ cmd
|
||||
{ _cmd_parts = case descStack of
|
||||
StackBottom l -> Data.Foldable.toList l
|
||||
StackLayer{} -> []
|
||||
}
|
||||
|
||||
monadMisuseError :: a
|
||||
monadMisuseError = error "CmdParser definition error - used Monad powers where only Applicative/Arrow is allowed"
|
||||
monadMisuseError =
|
||||
error
|
||||
$ "CmdParser definition error -"
|
||||
++ " used Monad powers where only Applicative/Arrow is allowed"
|
||||
|
||||
|
||||
getPartSeqDescPositionName :: PartDesc -> String
|
||||
|
|
@ -1070,9 +1123,7 @@ runCmdParserAExt mTopLevel inputInitial cmdParser
|
|||
PartSeq ds -> List.unwords $ f <$> ds
|
||||
PartReorder ds -> List.unwords $ f <$> ds
|
||||
PartHidden d -> f d
|
||||
|
||||
where
|
||||
f = getPartSeqDescPositionName
|
||||
where f = getPartSeqDescPositionName
|
||||
|
||||
dropSpaces :: MonadMultiState Input m => m ()
|
||||
dropSpaces = do
|
||||
|
|
@ -1090,7 +1141,8 @@ dequeLookupRemove key deque = case Deque.uncons deque of
|
|||
Nothing -> (Nothing, mempty)
|
||||
Just ((k, v), rest) -> if k == key
|
||||
then (Just v, rest)
|
||||
else let (r, rest') = dequeLookupRemove key rest
|
||||
else
|
||||
let (r, rest') = dequeLookupRemove key rest
|
||||
in (r, Deque.cons (k, v) rest')
|
||||
|
||||
takeCommandChild
|
||||
|
|
@ -1156,27 +1208,36 @@ descFixParents = descFixParentsWithTopM Nothing
|
|||
-- descFixParentsWithTop :: String -> CommandDesc a -> CommandDesc a
|
||||
-- descFixParentsWithTop s = descFixParentsWithTopM (Just (s, emptyCommandDesc))
|
||||
|
||||
descFixParentsWithTopM :: Maybe (Maybe String, CommandDesc a) -> CommandDesc a -> CommandDesc a
|
||||
descFixParentsWithTopM
|
||||
:: Maybe (Maybe String, CommandDesc a) -> CommandDesc a -> CommandDesc a
|
||||
descFixParentsWithTopM mTop topDesc = Data.Function.fix $ \fixed -> topDesc
|
||||
{ _cmd_mParent = goUp fixed <$> (mTop <|> _cmd_mParent topDesc)
|
||||
, _cmd_children = _cmd_children topDesc <&> goDown fixed
|
||||
}
|
||||
where
|
||||
goUp :: CommandDesc a -> (Maybe String, CommandDesc a) -> (Maybe String, CommandDesc a)
|
||||
goUp child (childName, parent) = (,) childName $ Data.Function.fix $ \fixed -> parent
|
||||
goUp
|
||||
:: CommandDesc a
|
||||
-> (Maybe String, CommandDesc a)
|
||||
-> (Maybe String, CommandDesc a)
|
||||
goUp child (childName, parent) =
|
||||
(,) childName $ Data.Function.fix $ \fixed -> parent
|
||||
{ _cmd_mParent = goUp fixed <$> _cmd_mParent parent
|
||||
, _cmd_children = _cmd_children parent <&> \(n, c) -> if n==childName
|
||||
then (n, child)
|
||||
else (n, c)
|
||||
, _cmd_children = _cmd_children parent
|
||||
<&> \(n, c) -> if n == childName then (n, child) else (n, c)
|
||||
}
|
||||
goDown :: CommandDesc a -> (Maybe String, CommandDesc a) -> (Maybe String, CommandDesc a)
|
||||
goDown parent (childName, child) = (,) childName $ Data.Function.fix $ \fixed -> child
|
||||
goDown
|
||||
:: CommandDesc a
|
||||
-> (Maybe String, CommandDesc a)
|
||||
-> (Maybe String, CommandDesc a)
|
||||
goDown parent (childName, child) =
|
||||
(,) childName $ Data.Function.fix $ \fixed -> child
|
||||
{ _cmd_mParent = Just (childName, parent)
|
||||
, _cmd_children = _cmd_children child <&> goDown fixed
|
||||
}
|
||||
|
||||
|
||||
_tooLongText :: Int -- max length
|
||||
_tooLongText
|
||||
:: Int -- max length
|
||||
-> String -- alternative if actual length is bigger than max.
|
||||
-> String -- text to print, if length is fine.
|
||||
-> PP.Doc
|
||||
|
|
|
|||
Loading…
Reference in New Issue