hexagoxel
/
butcher
1
0
Fork 0
Code Issues 2 Pull Requests Packages Projects Releases Wiki Activity

Apply autoformatting and Refactor slightly

pull/5/head
Lennart Spitzner 2018-01-10 00:53:51 +01:00
parent 0f5aa00bb3
commit 548f2ccd8f
1 changed files with 784 additions and 723 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

275
src/UI/Butcher/Monadic/Internal/Core.hs
View File

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