[Haskell-cafe] Client-extensible heterogeneous types (Duck-typed variadic functions?)

[Brandon Moore]

> Thank you all for your contributions so far. Plenty of food for  thought.
> 
> I though I'd try to put it into practice and have a go at the  motivating 
>example I gave: essentially a EDSL for defining simple maths  tests.

If you have a Python version that has other features you would like, you can 
send that too.

> But it all goes pear shaped as soon as I try to cater  for questions dealing 
>with fractions, for example: Now the type system requires  me to duplicate all 
>the question-making utilities and give them different names.  I tried to 
>mitigate this by using type classes but got walloped by the No  Monomorphism 
>Restriction, and so on, and so forth. Wherever I turned, the type  system was 
>getting in the way.

NoMonomorphismRestriction is the one extension I used. I suppose I could have 
replaced

def = beautiful combinators

by

def x = beautiful combinators x

Dealing with curried functions of varying arity is one thing that does tend to 
be fairly annoying, but in this case addParam was possible. The rest was pretty 
straightforward, mostly avoiding duplication by making more specific helpers 
rather than more generic functions.

{-# LANGUAGE NoMonomorphismRestriction #-}
import System.IO (hFlush, stdout)

data Result = Correct | Improve String | Huh String | Incorrect String
              deriving Show

data Question = Question { ask    :: String
                         , answer :: String
                         , check  :: String -> Result }

bool2result True  = Correct
bool2result False = Incorrect ""

readCheckBy :: (Read a) => (a -> Bool) -> String -> Result
readCheckBy pred str =
  case reads str of [(val,"")] -> bool2result (pred val)
                    _ -> Huh ""

readCheck :: (Read a, Eq a) => a -> String -> Result
readCheck v s = readCheckBy (==v) s

-- helpers

value val prompt = Question prompt (show val) (readCheck val)

infix2 op symbol a b = value (op a b) (unwords [show a, symbol, show b])

addParam :: (Show a) => (funTy -> String -> qty) -> (a -> funTy) -> String -> (a 
-> qty)
addParam qmakr fun string v = qmakr (fun v) (string++" "++show v)

prefix1 = addParam value
prefix2 = addParam prefix1
prefix3 = addParam prefix2

-- question 'types'

addition       = infix2 (+) "+"
subtraction    = infix2 (-) "-"
multiplication = infix2 (*) "x"
power          = infix2 (^) "^"

square = (flip power) 2
cube   = (flip power) 3

square' = prefix1 (^2) "square"

pi1 = value pi "pi"
pi2 = Question "pi" (show pi) (readCheckBy (\v -> abs (pi - v) / pi < 0.0001))

questions = [ addition 1 2
            , subtraction 3 2
            , multiplication 4 5
            , square 3
            , cube 3
            , square' 7
            , value 3.14 "pi"
            ]

test :: Question -> IO ()
test q = do
  putStr $ ask q ++ " = "
  hFlush stdout
  reply <- getLine
  putStrLn $ show $ check q reply

main = mapM_ test questions