Applicative.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}

module UI.Butcher.Applicative where



#include "prelude.inc"

import           UI.Butcher.Applicative.Types
import           Control.Applicative.Free
import qualified Text.PrettyPrint              as PP


data DescState = DescState
  { parts    :: Deque PartDesc
  , children :: Deque (String, CommandDesc)
  , help     :: Maybe PP.Doc
  , reorder  :: Maybe (Deque PartDesc)
  }

toCmdDesc :: forall out . CmdParser out out -> CommandDesc
toCmdDesc cmdParser =
  let final = appEndo (runAp_ f cmdParser) initialState
  in  CommandDesc { _cmd_mParent    = Nothing
                  , _cmd_synopsis   = Nothing
                  , _cmd_help       = help final
                  , _cmd_parts      = Data.Foldable.toList $ parts final
                  , _cmd_children   = Data.Foldable.toList $ children final
                  , _cmd_visibility = Visible
                  }
 where
  f :: CmdParserF out a -> Endo (DescState)
  f x = Endo $ \s -> case x of
    CmdParserHelp     doc _         -> s { help = Just doc }
    CmdParserSynopsis _   _         -> error "todo"
    CmdParserPeekInput _            -> s
    CmdParserPart desc _ _          -> appendPart s desc
    CmdParserPartMany _ desc _ _    -> appendPart s desc
    CmdParserPartInp desc _ _       -> appendPart s desc
    CmdParserPartManyInp _ desc _ _ -> appendPart s desc
    CmdParserChild name parser _    -> appendChild s $ (name, toCmdDesc parser)
    CmdParserReorderStart _         -> s { reorder = reorder s <|> Just empty }
    CmdParserReorderStop  _         -> case reorder s of
      Nothing -> s
      Just ps -> s { parts = parts s <> ps, reorder = Nothing }
   where
    appendPart s p = s { parts = Deque.snoc p (parts s) }
    appendChild s c = s { children = Deque.snoc c (children s) }
  initialState = DescState { parts    = mempty
                           , children = mempty
                           , help     = Nothing
                           , reorder  = mempty
                           }

data ParserState out = ParserState
  { p_parts    :: Deque PartDesc
  , p_children :: Deque (String, CommandDesc)
  , p_help     :: Maybe PP.Doc
  , p_reorder  :: Maybe (Deque PartDesc)
  , p_input    :: Input
  }

runCmdParser
  :: Input -> CmdParser out out -> (CommandDesc, Either ParsingError out)
runCmdParser initialInput initialParser =
  let topDesc = toCmdDesc initialParser
  in  (topDesc, go initialInput topDesc initialParser)
 where
  go :: Input -> CommandDesc -> CmdParser out out -> Either ParsingError out
  go input desc parser =
    -- TODO use x?
    let initialState = ParserState { p_parts    = mempty
                                   , p_children = mempty
                                   , p_help     = Nothing
                                   , p_reorder  = mempty
                                   , p_input    = input
                                   }
        (outE, _x) = StateS.runState (iter parser) initialState
    in  outE
   where
    iter
      :: CmdParser out out
      -> StateS.State (ParserState out) (Either ParsingError out)
    iter = \case
      Pure x                          -> pure $ Right x
      Ap (CmdParserHelp     _ x) next -> continue next x
      Ap (CmdParserSynopsis _ x) next -> continue next x
      Ap (CmdParserPeekInput f ) next -> do
        s <- StateS.get
        iter $ next <&> \g -> g $ f (inputToString $ p_input s)
      Ap (CmdParserPart _ parseF f) next -> parseWithStr
        parseF
        (\x -> iter $ next <&> \g -> g (f x))
        (\s -> pure $ Left $ ParsingError { _pe_messages  = ["could not parse"]
                                          , _pe_remaining = p_input s
                                          }
        )
      Ap (CmdParserPartMany _ _ parseF f) next -> do
        let loop = do
              dropSpaces
              parseWithStr
                parseF
                (\x -> do
                  more <- loop
                  pure (x : more)
                )
                (\_ -> pure [])
        ps <- loop
        iter $ next <&> \g -> g (f ps)
      Ap (CmdParserPartInp _ parseF f) next -> do
        s <- StateS.get
        case parseF (p_input s) of
          Just (x, rest) -> do
            StateS.put s { p_input = rest }
            iter $ next <&> \g -> g (f x)
          Nothing -> pure $ Left $ ParsingError
            { _pe_messages  = ["could not parse"]
            , _pe_remaining = p_input s
            }
      Ap (CmdParserPartManyInp _ _ parseF f) next -> do
        let loop = do
              dropSpaces
              s <- StateS.get
              case parseF (p_input s) of
                Just (x, rest) -> do
                  StateS.put s { p_input = rest }
                  (x :) <$> loop
                Nothing -> pure $ []
        ps <- loop
        iter $ next <&> \g -> g (f ps)
      Ap (CmdParserChild name childParser x) next -> do
        dropSpaces
        s <- StateS.get
        let childDesc = case find ((== name) . fst) (_cmd_children desc) of
              Just (_, d) -> d
              Nothing     -> error "inconsistent child name map"
        case p_input s of
          InputString str -> if
            | str == name -> do
              pure $ go (InputString "") childDesc childParser
            |
-- TODO str prefix
              otherwise -> continue next x
          InputArgs (a1 : ar) | a1 == name -> do
            pure $ go (InputArgs ar) childDesc childParser
          InputArgs{} -> continue next x
      Ap (CmdParserReorderStart _) next -> error "TODO" next
      Ap (CmdParserReorderStop  _) next -> error "TODO" next
     where
      continue next x = iter (($x) <$> next)
      parseWithStr f successF failF = do
        s <- StateS.get
        case p_input s of
          InputString str -> case f str of
            Just (x, rest) -> do
              StateS.put s { p_input = InputString rest }
              successF x
            Nothing -> failF s
          InputArgs (a1 : ar) -> case f a1 of
            Just (x, "") -> do
              StateS.put s { p_input = InputArgs ar }
              successF x
            _ -> failF s
          InputArgs [] -> failF s

  inputToString :: Input -> String
  inputToString (InputString s ) = s
  inputToString (InputArgs   ss) = List.unwords ss
  dropSpaces = do
    st <- StateS.get
    case p_input st of
      InputString s ->
        StateS.put $ st { p_input = InputString $ dropWhile Char.isSpace s }
      InputArgs{} -> return ()

addCmdPart
  :: Typeable p => PartDesc -> (String -> Maybe (p, String)) -> CmdParser out p
addCmdPart p f = liftAp $ CmdParserPart p f id

addCmdPartMany
  :: Typeable p
  => ManyUpperBound
  -> PartDesc
  -> (String -> Maybe (p, String))
  -> CmdParser out [p]
addCmdPartMany b p f = liftAp $ CmdParserPartMany b p f id

addCmdPartInp
  :: Typeable p => PartDesc -> (Input -> Maybe (p, Input)) -> CmdParser out p
addCmdPartInp p f = liftAp $ CmdParserPartInp p f id

addCmdPartManyInp
  :: Typeable p
  => ManyUpperBound
  -> PartDesc
  -> (Input -> Maybe (p, Input))
  -> CmdParser out [p]
addCmdPartManyInp b p f = liftAp $ CmdParserPartManyInp b p f id

data Param p = Param
  { _param_default     :: Maybe p
  , _param_help        :: Maybe PP.Doc
  , _param_suggestions :: Maybe [CompletionItem]
  }

addReadParam
  :: forall out a
   . (Typeable a, Show a, Text.Read.Read a)
  => String -- ^ paramater name, for use in usage/help texts
  -> Param a -- ^ properties
  -> CmdParser out a
addReadParam name par = addCmdPart desc parseF
 where
  desc :: PartDesc
  desc =
    addSuggestion (_param_suggestions par)
      $ (maybe id PartWithHelp $ _param_help par)
      $ (maybe id (PartDefault . show) $ _param_default par)
      $ PartVariable name
  parseF :: String -> Maybe (a, String)
  parseF s = case Text.Read.reads s of
    ((x, ' ' : r) : _) -> Just (x, dropWhile Char.isSpace r)
    ((x, []     ) : _) -> Just (x, [])
    _                  -> _param_default par <&> \x -> (x, s)

addSuggestion :: Maybe [CompletionItem] -> PartDesc -> PartDesc
addSuggestion Nothing     = id
addSuggestion (Just sugs) = PartSuggestion sugs


data Flag a = Flag
  { flag_name :: String
  , flag_short :: String
  , flag_long :: [String]
  , flag_opts :: FlagOpts a
  , flag_parser :: String -> Maybe (Identity a, String)
  }

data FlagOpts a = FlagOpts
  { _flag_help       :: Maybe PP.Doc
  , _flag_default    :: Maybe a
  , _flag_visibility :: Visibility
  }

traverseFlags
  :: (Covered c, CTraversable Typeable (c 'Wrap))
  => c 'Wrap Flag
  -> CmdParser out (c 'Bare Identity)
traverseFlags k = do
  r <- cTraverse
    (Proxy @Typeable)
    (\f -> addCmdPart (PartVariable (flag_name f)) (flag_parser f))
    k
  pure $ unwrap r

test :: IO ()
test = do
  let parser = do
        arg :: Int <- addReadParam
          "arg"
          Param { _param_default     = Nothing
                , _param_help        = Nothing
                , _param_suggestions = Nothing
                }
        pure $ print arg
  let (desc, eOut) = runCmdParser (InputArgs ["42"]) parser
  print desc
  case eOut of
    Left err -> do
      putStrLn "parsing error"
      print err
    Right f -> f

-- butcherMain :: ButcherA (IO ()) -> IO ()
-- 
-- type ButcherA out = Writer [ButcherCmd out] ()
-- type ButcherCmd = Ap ButcherCmdF out
-- data ButcherCmdF a
--   = ButcherCmdHelp String (() -> a)
--   | ButcherCmdParamString (String -> a)


{-
stringArg :: UnwrapField ('Just Arg) String
stringArg = mempty

argDef :: a -> UnwrapField ('Just Arg) a
argDef x = mempty { _arg_def = Just x }

fromUnordered
  :: (Covered h, CTraversable (h Wrap))
  => String
  -> h Wrap Arg
  -> CmdParserF out (h Plain Identity)

data Arg a = Arg
  { _arg_def  :: Maybe a
  , _arg_help :: Maybe String
  }

instance Monoid (Arg a) where ..

data MyArgs s f = MyArgs
  { greeting :: Wear s f String
  , name     :: Wear s f String
  }

main = butcherMain $ do
  args <- fromUnordered MyArgs
    { greeting = stringArg <> argDef "hi"
    , name     = stringArg
    }
  pure do
    putStrLn $ greeting args ++ ", " ++ name args ++ "!"
-}