haskell - Generar analizador optparse-aplicativo a partir de funtor alternativo libre

applicative free-monad

Question

Considere las siguientes firmas de tipo:

data Foo x = Foo {
name :: String
, reader :: String -> x
}
instance Functor Foo where
fmap f (Foo n r) = Foo n $ f . r

Ahora muestro una transformación natural de Foo al tipo Parser optparse-applicative :

import qualified Options.Applicative as CL
mkParser :: Foo a -> CL.Parser a
mkParser (Foo n _) = CL.option CL.disabled ( CL.long n )

(Está bien, es un poco inútil, pero servirá para la discusión).

Ahora tomo a Bar como el funtor alternativo gratuito sobre Foo :

type Bar a = Alt Foo a

Dado que este es un functor gratuito, debería ser capaz de mkParser en una transformación natural de Bar a 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

Y de hecho, esto funciona y me devuelve un Parser . Sin embargo, es bastante inútil, porque tratar de hacer mucho con esto da como resultado un bucle infinito. Por ejemplo, si intento describirlo:

CL.cmdDesc clFoo
> Chunk {unChunk = 

Y se cuelga hasta que se interrumpa.

La razón de esto parece ser que los optparse-applicative en sus definiciones de many y some : utiliza análisis monádico debajo de las cubiertas.

¿Estoy haciendo algo mal aquí? No veo cómo, dado esto, es posible construir un analizador de esta manera. ¿Algunas ideas?

Answer 1

Como se señala en los comentarios, tienes que manejar many explícitamente. Enfoque copiado de 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 @f@ to @g@, this gives a canonical monoidal natural transformation from @''Alt'' f@ to @g@.
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 @f@.
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")