lambda/bug.icl

   1 module bug
   2
   3 import StdEnv
   4 import Data.Functor
   5 import Data.Func
   6 import Data.Maybe
   7 import Control.Applicative
   8 import Control.Monad
   9
  10 :: In a b = In infixl 0 a b
  11 class lambda v
  12 where
  13         (@) infixr 1 :: (v (a -> v b)) (v a) -> v b
  14         \| :: ((v a) -> v b) -> v (a -> v b) | TC a & TC b & TC (v b)
  15
  16 class expr v
  17 where
  18         lit :: a -> v a | toString, TC a
  19         (+.) infixl 6 :: (v a) (v a) -> v a | + a
  20         (-.) infixl 6 :: (v a) (v a) -> v a | - a
  21         (*.) infixl 6 :: (v a) (v a) -> v a | * a
  22         (/.) infixl 6 :: (v a) (v a) -> v a | / a
  23         (==.) infix 4 :: (v a) (v a) -> v Bool | == a
  24         If :: (v Bool) (v a) (v a) -> v a
  25
  26 class let v
  27 where
  28         lett :: ((v a) -> In (v a) (v b)) -> v b | TC a
  29
  30 import Data.Either
  31 import Data.Tuple
  32 :: St a = St (Env -> Either String (a, Env))
  33 :: Env :== [(Int, Dynamic)]
  34 instance Functor St where fmap f m = St $ fmap (appFst f) o evalSt m
  35 instance pure St where pure x = St \s->Right (x, s)
  36 instance <*> St where (<*>) mfa ma = ap mfa ma
  37 instance Monad St
  38 where
  39         bind ma a2mb = St \s->case evalSt ma s of
  40                 Left err = Left err
  41                 Right (a, s) = evalSt (a2mb a) s
  42
  43 get   = St \s->Right (s, s)
  44 put s = St \_->Right ((), s)
  45 evalSt (St m) = m
  46
  47 instance expr St
  48 where
  49         lit a = pure a
  50         (+.) l r = (+) <$> l <*> r
  51         (-.) l r = (-) <$> l <*> r
  52         (*.) l r = (*) <$> l <*> r
  53         (/.) l r = (/) <$> l <*> r
  54         (==.) l r = (==) <$> l <*> r
  55         If i t e = if` <$> i <*> t <*> e
  56
  57 instance lambda St
  58 where
  59         (@) l r = l >>= \l->r >>= \r->l r
  60         \| def = pure $ def o pure
  61
  62 instance let St
  63 where
  64         lett def = length <$> get >>= \l->
  65                 let (x In y) = def $ get >>= \s->hd [d\\(x, d :: St a^)<-s | l == x]
  66                 in  get >>= \s->put [(l, dynamic x):s] >>| y
  67
  68 Start = evalSt t2 []
  69 where
  70 // Geeft:
  71 /*
  72 initial_unification_environment [module: _SystemDynamic]
  73 _initial_unification_environment [module: _SystemDynamic]
  74 _f111;111 [module: bug]
  75 <lambda>[line:65];38;90 [module: bug]
  76 <case>[line:39];27;103 [module: bug]
  77 evalSt [module: bug]
  78 <lambda>[line:39];23;11 [module: bug]
  79 evalSt [module: bug]
  80 <lambda>[line:39];23;11 [module: bug]
  81 evalSt [module: bug]
  82 evalSt [module: bug]
  83 <lambda>[line:39];23;11 [module: bug]
  84 */
  85         t1  = lett \id     = (\| \x->x)
  86 //        In lett \fix    = (\| \f->lett \x=f @ x In x)
  87           In lett \fac    = (\| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1)))
  88 //        In lett \facfix = (\| \n->(fix @ \| \fac-> \| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1))) @ n)
  89           In fac @ id @ lit 10
  90 // Geeft:
  91 /*
  92 unify_ [module: _SystemDynamic]
  93 unify_ [module: _SystemDynamic]
  94 unify_ [module: _SystemDynamic]
  95 unify_types [module: _SystemDynamic]
  96 _unify [module: _SystemDynamic]
  97 _f143;143 [module: bug]
  98 <lambda>[line:65];38;101 [module: bug]
  99 <case>[line:39];27;135 [module: bug]
 100 evalSt [module: bug]
 101 <lambda>[line:39];23;22 [module: bug]
 102 evalSt [module: bug]
 103 evalSt [module: bug]
 104 */
 105         t2  = lett \id     = (\| \x->x)
 106           In lett \fix    = (\| \f->lett \x=f @ x In x)
 107           In lett \fac    = (\| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1)))
 108           In lett \facfix = (\| \n->(fix @ \| \fac-> \| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1))) @ n)
 109           In facfix @ id @ lit 10