免費替代仿函數生成optparse，應用性分析器

Question

考慮以下類型簽名：

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類型：

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-applicativecheats在其定義many和some：它使用monadic解析下的封面。

我在這裏做錯了什麼？我看不出如何，因爲這樣，就有可能以這種方式構建解析器。有任何想法嗎？

Answer 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 @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")