constraint/test.hs

   1 {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-}
   2 module Main where
   3
   4 import Prelude hiding (print)
   5 import Data.Functor.Identity
   6 class Empty x
   7
   8 instance Empty x
   9
  10 main = putStrLn $ show (unP e1 [])
  11
  12 e1 :: Printer Int
  13 e1 = lit 42
  14
  15 infixl 6 +., -.
  16 infixl 7 *.
  17 infix 4 ==.
  18 class Expr v c where
  19     lit :: (c a) => a -> v a
  20     (+.) :: (c a, Num a) => v a -> v a -> v a
  21     (-.) :: (c a, Num a) => v a -> v a -> v a
  22     (*.) :: (c a, Num a) => v a -> v a -> v a
  23     (==.) :: (c a, Eq a) => v a -> v a -> v Bool
  24 --    if' :: (c a) => v Bool -> v a -> v a -> v a
  25
  26 data Printer a = P ([String] -> [String])
  27 unP (P a) = a
  28 instance Expr Printer Show where
  29     lit a = P (show a:)
  30     l +. r  = P $ unP l . ("+":) .  unP r
  31     l -. r  = P $ unP l . ("-":) .  unP r
  32     l *. r  = P $ unP l . ("*":) .  unP r
  33     l ==. r = P $ unP l . ("==":) . unP r
  34 --    if' i t e = P $ ("if ":) . unP i . (" then ":) . unP t . (" else ":) . unP e
  35
  36 data Eval a = E a
  37 unE (E a) = a
  38 instance Expr Eval Empty where
  39     lit a = E a
  40     l +. r  = E $ unE l +  unE r
  41     l -. r  = E $ unE l -  unE r
  42     l *. r  = E $ unE l *  unE r
  43     l ==. r = E $ unE l == unE r
  44 --    if' i t e = if unE i then t else e