स्वतंत्र विकल्प functor से optparse-अनुप्रयोगी पार्सर उत्पन्न

Question

निम्न प्रकार के हस्ताक्षर पर विचार करें:

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

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

अब मैं से एक प्राकृतिक परिवर्तन दिखाने Foooptparse-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 से अधिक स्वतंत्र विकल्प functor होने के लिए:

type Bar a = Alt Foo a 

को देखते हुए यह एक नि: शुल्क functor है, मैं Parser को Bar से एक प्राकृतिक परिवर्तन में mkParser लिफ्ट करने के लिए सक्षम होना चाहिए:

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 = 

और बाधित होने तक लटकता है। यह कवर के तहत monadic पार्स उपयोग करता है:

इस का कारण यह है कि optparse-applicativecheatsmany और some की अपनी परिभाषा में हो रहा है।

क्या मैं यहां कुछ गलत कर रहा हूं? मैं नहीं देखता कि, यह कैसे दिया गया है, इस तरह से एक पार्सर बनाना संभव है। कोई विचार?

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