Duck Typed morphisms statically typed

TDT.hs

{import Control.Applicative ((<|>))
import Control.Monad
import Data.Data
import Data.Generics.Aliases
import Data.Monoid

trans ::  (MonadPlus m, Typeable a, Typeable b) => (b -> r) -> a -> m r
trans = mkQ mzero . (return .)

mcast :: (Typeable b, Typeable r) => (a -> Maybe b) -> a -> Maybe r
mcast f = (maybe Nothing cast) . f

rule :: (Typeable a, Typeable b, Typeable r, Typeable b1) => (b1 -> b) -> a -> Maybe r
rule = mcast . trans

firstRule :: (Typeable a, Typeable r) => [a -> Maybe r] -> a -> Maybe r
firstRule rs = getFirst . mconcat . fmap First .  sequence rs
-- Usage

preFoo :: (Typeable a, Typeable r) => a -> Maybe r
preFoo = rule ("foo" ++)

plusOne :: (Typeable a, Typeable r) => a -> Maybe r
plusOne = rule (+ (1 :: Integer))

integerFromString :: (Typeable a, Typeable r) => a -> Maybe r
integerFromString = rule (length :: String -> Int)

{- Resolve the first adequate function

   >>> composition 2 :: Maybe Integer
   Just 3
   >>> composition 2 :: Maybe String
   Nothing
   >>> composition "bar :: Maybe Integer
   Nothing
   >>> composition "bar" :: Maybe String
   Just foobar
   >>> composition "bar" :: Maybe Char
   Nothing
-}
composition :: (Typeable a, Typeable r) => a -> Maybe r
composition = firstRule [preFoo, plusOne, integerFromString]

data A = A Integer String
  deriving (Read, Show)
data B = B Integer Int
  deriving (Read, Show)

aToB :: A -> Maybe B
aToB (A x y) = do
  x' <- composition x
  y' <- composition y
  return $ B x' y'