Duck typing in haskell

Ducks.hs

{-# LANGUAGE TypeOperators
           , Arrows
           , FlexibleInstances
           , DeriveDataTypeable
           , StandaloneDeriving
           , GeneralizedNewtypeDeriving#-}

import Prelude hiding ((.))
import Data.Dynamic
import qualified Data.Map as M
import Control.Arrow
import Control.Category
import Control.Monad
import Data.Maybe
import Data.Typeable

-- All this so I can derive a Typeable2 instance. Sigh. --
-- (The Typeable2 instance is needed so objects can hold functions in their fields) --
newtype a -?> b = P (Kleisli Maybe a b) deriving (Category
                                                 , Arrow
                                                 , ArrowChoice
                                                 , ArrowZero
                                                 , ArrowPlus
                                                 , ArrowApply)
deriving instance Typeable2 (-?>)

wrap :: (a -> Maybe b) -> a -?> b
wrap = P . Kleisli
unwrap :: (a -?> b) -> a -> Maybe b
unwrap (P k) = runKleisli k


-- Actual idea: --
type Object = M.Map String Dynamic --Javascript-style OO. Inheritance doesn't really make sense.

readField :: (Typeable a) => String -> Object -?> a 
readField f = wrap $ fromDynamic <=< M.lookup f


-- Something like traditional idea of "class", not sure how useful it is --
type Class a = M.Map String (a -> Dynamic)

instantiate :: Class a -> a -> Object
instantiate c a = fmap ($a) c



-- examples --
iterateO :: (Typeable a) => (a -> IO ()) -> Object -?> IO ()
iterateO f = proc o -> do
  fields <- readField "each" -< o
  returnA -< void $ mapM f fields

mkIterable :: (Typeable a) => [a] -> Object
mkIterable as = M.fromList [("each", toDyn as)]

-- fromJust (unwrap (iterateO (print :: Int -> IO ())) $ mkIterable ([1..10] :: [Int]))
-- does as expected
-- yes, the monomorphism stuff is annoying, especially since it fails silently if you forget it. 

compareO :: (Object, Object) -?> Ordering
compareO = proc (o, o') -> do
  comparison <- readField "compare" -< o
  comparison -<< o'

mkComparable :: Float -> Object
mkComparable x = M.fromList $ [("value", toDyn x)
                              ,("compare", toDyn go)]
  where go = proc o -> do
          val <- readField "value" -< o
          returnA -< compare x val

-- unwrap compareO (mkComparable 10, mkComparable 20)
-- => Just LT