20

次のような自由なモナド DSL が与えられた場合:

data FooF x = Foo String x
            | Bar Int    x
  deriving (Functor)

type Foo = Free FooF

そして、のランダムインタプリタFoo:

printFoo :: Foo -> IO ()
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n

手動で行うことに頼らずに、 printFoo の各反復に何かを散在させることが可能であるように私には思えます:

printFoo' :: Foo -> IO ()
printFoo' (Free (Foo s n)) = print s >> print "extra info" >> printFoo' n
printFoo' (Free (Bar i n)) = print i >> print "extra info" >> printFoo' n

これは、オリジナルを「ラッピング」することで何とか可能printFooですか?

動機: バイナリ形式に「コンパイル」する小さな DSL を書いています。バイナリ形式には、各ユーザー コマンドの後にいくつかの追加情報が含まれています。そこにある必要がありますが、私のユースケースではまったく関係ありません。

4

5 に答える 5

14

他の答えは、これがどれほど簡単かを見逃していますfree! :) 現在、あなたは持っています

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free

data FooF x = Foo String x
            | Bar Int    x
  deriving (Functor)

type Foo = Free FooF

program :: Free FooF ()
program = do
  liftF (Foo "Hello" ())
  liftF (Bar 1 ())
  liftF (Foo "Bye" ())

printFoo :: Foo () -> IO ()
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n
printFoo (Pure a) = return a

を与える

*Main> printFoo program 
"Hello"
1
"Bye"

それiterMは問題ありませんが、必要な配管を行うことができます

printFooF :: FooF (IO a) -> IO a
printFooF (Foo s x) = print s >> x
printFooF (Bar i x) = print i >> x

printFooBetter :: Foo () -> IO ()
printFooBetter = iterM printFooF

次に、取得します

*Main> printFooBetter program
"Hello"
1
"Bye"

OK、以前と同じです。ただしprintFooF、必要な行に沿って翻訳者を拡張する柔軟性が向上します

printFooFExtra :: FooF (IO a) -> IO a
printFooFExtra = (print "stuff before IO action" >>)
                 . printFooF
                 . fmap (print "stuff after IO action" >>)

printFooExtra :: Foo () -> IO ()
printFooExtra = iterM printFooFExtra

それから私たちは得る

*Main> printFooExtra program
"stuff before IO action"
"Hello"
"stuff after IO action"
"stuff before IO action"
1
"stuff after IO action"
"stuff before IO action"
"Bye"
"stuff after IO action"

無料モナドを普及させてくれた Gabriel Gonzalez とライブラリを書いてくれた Edward Kmett に感謝します! :)

于 2013-12-13T20:33:46.180 に答える
5

これは、パッケージを使用した非常に単純なソリューションoperationalです。フリー モナドの合理的な代替手段です。

printFoo関数を、適切な命令を出力する部分と追加情報を追加する部分に分解することができます。これは、このようなコード重複の標準的な処理です。

{-# LANGUAGE GADTs #-}

import Control.Monad.Operational

data FooI a where
    Foo :: String -> FooI ()
    Bar :: Int    -> FooI ()

type Foo = Program FooI

printFoo :: Foo a -> IO a
printFoo = interpretWithMonad printExtra
    where
    printExtra :: FooI a -> IO a
    printExtra instr = do { a <- execFooI instr; print "extra info"; return a; }

execFooI :: FooI a -> IO a
execFooI (Foo s) = print s
execFooI (Bar i) = print i
于 2013-12-14T10:24:01.680 に答える
3

このようなものをお探しですか？

元のコードは次のようになります

{-# LANGUAGE DeriveFunctor #-}

import Control.Monad.Free

data FooF a = Foo String a | Bar Int a deriving (Functor)

type Foo = Free FooF

printFoo :: Show a => Foo a -> IO ()
printFoo (Free (Foo s n)) = print s >> printFoo n
printFoo (Free (Bar i n)) = print i >> printFoo n
printFoo (Pure a)         = print a

次に、単純なラッパー関数と、追加情報を各レイヤーに追加する再帰アノテーターを定義できますFoo(明らかに、これらは好きなだけ複雑にすることができます)。

annotate :: Foo a -> Foo a
annotate (Free (Foo s n)) = wrapper (Free (Foo s (annotate n)))
annotate (Free (Bar i n)) = wrapper (Free (Bar i (annotate n)))
annotate (Pure a)         = wrapper (Pure a)

wrapper :: Foo a -> Foo a
wrapper n = Free (Foo "Extra info" n)

次に、DSL を定義するいくつかの便利なコンストラクターを定義します

foo :: String -> a -> Foo a
foo s a = Free (Foo s (Pure a))

bar :: Int -> a -> Foo a
bar i a = Free (Bar i (Pure a))

つまりFoo a、モナド インターフェイスと DSL を使用するだけでオブジェクトを作成できます。

example = do
    i <- return 1
    a <- foo "Created A" i
    b <- bar 123 a
    c <- foo "Created C" b
    return c

GHCI をロードすると、元exampleのバージョンまたは注釈付きのバージョンのいずれかで作業できます。

>> printFoo example
"Created A"
123
"Created C"
1
>> printFoo (annotate example)
"Extra info"
"Created A"
"Extra info"
123
"Extra info"
"Created C"
"Extra info"
1
于 2013-12-13T11:46:41.027 に答える
1

どちらも構造をたどり、誘導処理の結果を蓄積するだけです。これには、カタモルフィズムによる反復の一般化が必要です。

> newtype Fix f = Fix {unFix :: f (Fix f)}
> data N a b x = Z a | S b x deriving (Functor)
> type Nat a b = Fix (N a b)
> let z = Fix . Z
> let s x = Fix . S x
> let x = s "blah" $ s "doo" $ s "duh" $ z 0
> let annotate (Z x) = s "annotate" $ z x;
      annotate (S x y) = s "annotate" $ s x y
> let exec (Z x) = print x; exec (S x y) = print x >> y
> let cata phi = phi . fmap (cata phi) . unFix
>
> cata exec x
"blah"
"doo"
"duh"
0
>
> cata exec $ cata annotate x
"annotate"
"blah"
"annotate"
"doo"
"annotate"
"duh"
"annotate"
0

コメントにいくつかのリクエストがあり、Fix を使用するとモナドではなくなるのではないかという懸念があったため、何が起こっているのかをさらに詳しく説明しましょう。

関手 G を考える:

G(X) = A + F(G(X))

ここで F は任意の関手です。次に、任意の A に対して不動点を見つけることができます (F と G は明らかに多項式です - 私たちは Hask にいます)。カテゴリのすべてのオブジェクト A をカテゴリのオブジェクトにマップするため、不動点 T(A) の関手について話していることになります。モナドであることがわかります。任意の関手 F のモナドであるため、T(A) は Free Monad です。(以下のコードから明らかに Monad であることがわかります)

{-# LANGUAGE DeriveFunctor
           , TypeSynonymInstances #-}

newtype Fix f = Fix {unFix :: f (Fix f)} -- the type of Fixed point of a functor
newtype Compo f g x = Compo {unCompo :: f (g x)} -- composition of functors

instance (Functor f, Functor g) => Functor (Compo f g) where -- composition of functors is a functor
  fmap f = Compo . fmap (fmap f) . unCompo

data FreeF a x = Pure a | Free x deriving (Functor) -- it is a bi-functor, really;
                -- this derives functor in x

-- a special case of fmap - the fmap with unwrapping; useful to eliminate pattern matching
ffmap :: (a -> b) -> FreeF b a -> b
ffmap f x = case fmap f x of -- unwrapping, since now distinction between Pure and Free is not important
              Pure a -> a
              Free a -> a

-- Free Monad is a functor of fixed points of functor G(X)
-- G(X) = A + F(G(X))
type Free f a = Fix (Compo (FreeF a) f) -- fixed point of composition F . (FreeF a)


-- unfortunately, when defined as type, (Free f a) cannot be declared
-- as a Monad (Free f) - Haskell wants Free f to be with `a`
-- instance Monad (Free f) where -- this derives a functor in a at the same time;
--                          note that fmap will work in x, and is not meant
--                          to be equal to (m >>= return . f), which is in `a`
--   return a = Fix $ Compo $ Pure a
--   (Fix (Compo (Pure a))) >>= f  = f a
--   (Fix (Compo (Free fx))) >>= f = Fix $ Compo $ Free $ fmap (>>= f) fx

ret :: (Functor f) => a -> Free f a -- yet it is a monad: this is return
ret = Fix . Compo . Pure

-- and this is >>= of the monad
bind :: (Functor f) => Free f a -> (a -> Free f b) -> Free f b
bind (Fix (Compo (Pure a))) f = f a
bind (Fix (Compo (Free fx))) f = Fix $ Compo $ Free $ fmap (`bind` f) fx

-- Free is done

-- here is your functor FooF
data FooF x = Z Int x | S String x deriving (Functor)

type Foo x = Free FooF x

-- catamorphism for an algebra phi "folds" any F(X) (represented by fixed point of F)
-- into X
cata :: (Functor f) => (f x -> x) -> Fix f -> x
cata phi = phi . fmap (cata phi) . unFix

-- helper functions to construct "Foo a"
z :: Int -> Foo a -> Foo a
z x = Fix . Compo . Free . Z x

s :: String -> Foo a -> Foo a
s x = Fix . Compo . Free . S x

tip :: a -> Foo a
tip = ret

program :: Foo (IO ())
program = s "blah" $ s "doo" $ s "duh" $ z 0 $ tip $ return ()

-- This is essentially a catamorphism; I only added a bit of unwrapping
cata' :: (Functor f) => (f a -> a) -> Free f a -> a
cata' phi = ffmap (phi . fmap (cata' phi)) . unCompo . unFix

exec (Z x y) = print x >> y
exec (S x y) = print x >> y

annotate (Z x y) = s "annotated Z" $ z x y
annotate (S x y) = s "met S" $ s x y

main = do
         cata' exec program
         cata' exec $ cata' annotate (program `bind` (ret . ret))
           -- cata' annotate (program >>= return . return)
           -- or rather cata' annotate $ fmap return program

programですFoo (IO ())。fmapin a(FreeF はバイファンクターであることを思い出してください - fmap in が必要ですa) にprogram変換できますFoo (Foo (IO ()))- 今では annotate のカタモルフィズムは new を構築できFoo (IO ())ます。

からのものでcata'あることに注意してください。iterControl.Monad.Free

于 2013-12-13T14:49:17.697 に答える