試み

https://github.com/nushio3/practice/tree/master/duck

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Object where

import qualified Data.Map as Map
import           Data.Dynamic
import           Control.Lens

-- これが特異メソッドを持てるオブジェクトです。
newtype Object = Object (Map.Map TypeRep Dynamic)
  deriving (Show, Typeable)

-- レコード名(キー)としては文字列とかじゃなく型をつかいます。これは後述するように、
-- 名前衝突を回避するためです。このレコード(キー)に対応する値を型族として持たせます。
class Typeable a => KeyType a where
  type ValType a :: *

-- レコードはObjectから値型へのレンズとします。値をMaybeでくるんでおくことで、
-- 値が未定義の場合も扱えるようにしましょう。
type Record kt = Lens Object Object (Maybe (ValType kt)) (Maybe (ValType kt))

-- 空のオブジェクトです
empty :: Object
empty = Object $ Map.empty

-- レコードを作るヘルパ関数です。
mkRecord :: forall kt. (KeyType kt, Typeable (ValType kt)) => kt -> Record kt
mkRecord k1 = lens gettr settr
  where
    gettr :: Object -> Maybe (ValType kt)
    gettr (Object map0) = Map.lookup k map0 >>= fromDynamic
    settr :: Object -> (Maybe (ValType kt)) -> Object
    settr (Object map0) Nothing  = Object $ Map.delete k map0
    settr (Object map0) (Just x) = Object $ Map.insert k (toDyn x) map0
    k :: TypeRep
    k = typeOf k1

次に、飛行物体(Flying Objects)に関するレコードをいくつか定義します。ちょっと繰り返しが多いですが、試験版なので我慢してね・・・。

module Data.Object.Flying (speed, sound) where

import Data.Dynamic
import Data.Object


data Unidentified = Unidentified deriving Typeable
instance KeyType Unidentified where type ValType Unidentified = Bool
unidentified :: Record Unidentified
unidentified = mkRecord Unidentified

data Speed = Speed deriving Typeable
instance KeyType Speed where type ValType Speed = Double
speed :: Record Speed
speed = mkRecord Speed

data Sound = Sound deriving Typeable
instance KeyType Sound where type ValType Sound = String
sound :: Record Sound
sound = mkRecord Sound

さて、特異メソッドとDuck Typingの例です。

import           Control.Lens
import           Control.Monad
import           Data.List (isInfixOf)
import           Data.Object
import           Data.Object.Flying
import qualified Data.Object.Wav as Wav
import           Data.Maybe
import qualified Data.Vector as V

x1,x2,x3,x4,x5, santa :: Object
x1 = empty -- 空の物体

x2 = x1 & speed .~ Just 120 -- 飛行速度を追加

x3 = x2 & sound .~ Just "quack! quack. quack? quack..."　-- 鳴き声追加

x4 = x3 & over speed (fmap (*2)) -- あひるを加速!

-- 音声データをWavフォーマットで追加。同じsoundという名前のレコードが複数ありますが、きちんと区別されます。
x5 = x2 & Wav.sound .~ Just (V.generate 44100 (\i -> floor (sin(2*pi*800 * fromIntegral i/44100))))

-- NOARDレーダーに反応あり！
santa = empty
 & speed .~ Just 64000
 & sound .~ Just "Merry Xmas! Hohohoho!"

main = do
  print x1
  print $ x1 ^. speed
  print x2
  print $ x2 ^. speed
  print $ x3 ^. sound
  let speeders :: [Object]
      speeders = do                       -- リストモナド
        x <- [x1, x2, x3, x4, x5, santa]  -- 飛行物体の一覧
        sp <- maybeToList $ x ^. speed    -- speedレコードを取り出す
        snd <- maybeToList $ x ^. sound   -- 音声データを取り出す
        -- レコードを持たないものはListモナドの機能により、
        -- 実行時エラーを出すことなく除外されます。
        guard $ sp < 200                  -- 速度が200以下
        guard $ "quack" `isInfixOf` snd   -- 鳴き声はガアガア
        return x
  print speeders

速度200以下で飛び、ガアガアと鳴く物体がいたら、それはあひるのはずです。あなたは無事あひるを見つけられましたか？