Сгенерируйте аппликационный парсер optparse из бесплатного альтернативного функтора

Рассмотрим следующие типы сигнатур:

data Foo x = Foo {
    name :: String
  , reader :: String -> x
}

instance Functor Foo where
  fmap f (Foo n r) = Foo n $ f . r

Теперь я показываю естественное преобразование от Foo до optparse-applicative Parser type:

import qualified Options.Applicative as CL

mkParser :: Foo a -> CL.Parser a
mkParser (Foo n _) = CL.option CL.disabled ( CL.long n )

(Хорошо, это немного бесполезно, но это будет полезно для обсуждения).

Теперь я принимаю Bar как свободный альтернативный функтор над Foo:

type Bar a = Alt Foo a

Учитывая, что это свободный функтор, я должен поднять mkParser на естественное преобразование от Bar до Parser:

foo :: String -> (String -> x) -> Bar x
foo n r = liftAlt $ Foo n r

myFoo :: Bar [String]
myFoo = many $ foo "Hello" (\_ -> "Hello")

clFoo :: CL.Parser [String]
clFoo = runAlt mkParser $ myFoo

И действительно, это работает и дает мне Parser назад. Тем не менее, это довольно бесполезно, потому что попытка сделать многое с ним приводит к бесконечному циклу. Например, если я попытаюсь описать это:

CL.cmdDesc clFoo
> Chunk {unChunk =

И зависает, пока не прерывается.

Причиной этого является то, что optparse-applicative читы в своих определениях many и some: он использует монадический синтаксический анализ под обложками.

Я делаю что-то неправильно здесь? Я не вижу, как с учетом этого можно построить парсер таким образом. Любые идеи?

ОТВЕТЫ

Ответ 1

Как указано в комментариях, вы должны явно обрабатывать many. Подход скопирован из Earley:

#!/usr/bin/env stack
-- stack --resolver=lts-5.3 runghc --package optparse-applicative
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Control.Applicative
import qualified Options.Applicative as CL
import qualified Options.Applicative.Help.Core as CL

data Alt f a where
  Pure   :: a                             -> Alt f a
  Ap     :: f a       -> Alt f (a -> b)   -> Alt f b
  Alt    :: [Alt f a] -> Alt f (a -> b)   -> Alt f b
  Many   :: Alt f a   -> Alt f ([a] -> b) -> Alt f b

instance Functor (Alt f) where
  fmap f (Pure x)   = Pure $ f x
  fmap f (Ap x g)   = Ap x $ fmap (f .) g
  fmap f (Alt x g)  = Alt x $ fmap (f .) g
  fmap f (Many x g) = Many x $ fmap (f .) g

instance Applicative (Alt f) where
  pure = Pure

  Pure f   <*> y = fmap f y
  Ap x f   <*> y = Ap x $ flip <$> f <*> y
  Alt xs f <*> y = Alt xs $ flip <$> f <*> y
  Many x f <*> y = Many x $ flip <$> f <*> y

instance Alternative (Alt f) where
  empty = Alt [] (pure id)
  a <|> b = Alt [a, b] (pure id)
  many x  = Many x (pure id)

-- | Given a natural transformation from @[email protected] to @[email protected], this gives a canonical monoidal natural transformation from @'Alt' [email protected] to @[email protected]
runAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> Alt f a -> g a
runAlt u = go where
    go :: forall b. Alt f b -> g b
    go (Pure x)    = pure x
    go (Ap x f)    = flip id <$> u x                           <*> go f
    go (Alt xs f)  = flip id <$> foldr (<|>) empty (map go xs) <*> go f
    go (Many x f)  = flip id <$> many (go x)                   <*> go f

-- | A version of 'lift' that can be used with just a 'Functor' for @[email protected]
liftAlt :: (Functor f) => f a -> Alt f a
liftAlt x = Ap x (Pure id)

mkParser :: Foo a -> CL.Parser a
mkParser (Foo n r) = CL.option (CL.eitherReader $ Right . r) ( CL.long n CL.<> CL.help n )

data Foo x = Foo {
    name :: String
  , reader :: String -> x
}

instance Functor Foo where
  fmap f (Foo n r) = Foo n $ f . r

type Bar a = Alt Foo a

foo :: String -> (String -> x) -> Bar x
foo n r = liftAlt $ Foo n r

myFoo :: Bar [String]
myFoo = many $ foo "Hello" (\_ -> "Hello")

clFoo :: CL.Parser [String]
clFoo = runAlt mkParser $ myFoo

main :: IO ()
main = do
  print $ CL.cmdDesc clFoo
  print $ CL.cmdDesc $ mkParser (Foo "Hello" $ \_ -> "Hello")