chriswarbo-net: f042e0ad1855acf6b34c55b2e7ae3cab470c3761

     1: ---
     2: title: A Framework for Self-Improving Code
     3: packages: [ 'ghcWithQuickCheck' ]
     4: ---
     5: 
     6: Since Haskell functions are opaque (we can't pattern-match them), we'll define a
     7: simple Lambda Calculus to represent our functions instead (this was explained
     8: in [a previous post](/blog/2014-02-07-lazy_lambda_calculus.html)):
     9: 
    10: ```
    11: {.haskell pipe="sh"}
    12: git clone ...
    13: cat ...
    14: ```
    15: 
    16: 
    17: ```{pipe="cat > append"}
    18: #!/bin/sh
    19: tee -a code.hs
    20: echo "" >> code.hs
    21: ```
    22: 
    23: ```{pipe="sh"}
    24: chmod +x append
    25: (source "$stdenv/setup" && patchShebangs .) 1>&2
    26: ```
    27: 
    28: ```{pipe="./append > /dev/null"}
    29: import Test.QuickCheck
    30: import Control.Applicative hiding (Const)
    31: ```
    32: 
    33: ```{.haskell pipe="./append"}
    34: -- Lambda Calculus terms
    35: data Term a = Var Nat
    36:             | Lam (Term a)
    37:             | App (Term a) (Term a)
    38:             | Const a
    39:             deriving (Show)
    40: 
    41: -- De Bruijn indices
    42: data Nat = Z | S Nat deriving (Show)
    43: 
    44: lookUp :: [a] -> Nat -> Maybe a
    45: lookUp xs n = let toInt Z     = 0
    46:                   toInt (S m) = 1 + toInt m
    47:                   n'          = toInt n
    48:                in if n' < length xs
    49:                      then Just (xs !! n')
    50:                      else Nothing
    51: 
    52: -- Compiled closures
    53: data Val a = F (Partial (Val a) -> Partial (Val a))
    54:            | C a
    55: 
    56: -- Environment mapping indices to terms
    57: type Env a = [Partial (Val a)]
    58: 
    59: -- Lambda calculus evaluator
    60: eval' :: Term a -> Env a -> Partial (Val a)
    61: eval' (Const c) env = Now (C c)
    62: eval' (Var   n) env = let Just x = lookUp env n in x
    63: eval' (Lam   f) env = Now (F (\a -> eval' f (a:env)))
    64: eval' (App f x) env = do F f' <- eval' f env
    65:                          Later (f' (eval' x env))
    66: 
    67: eval x = eval' x []
    68: 
    69: -- Turn the general recursion of Lambda Calculus into co-recursion, to avoid
    70: -- killing Haskell
    71: data Partial a = Now a | Later (Partial a)
    72: 
    73: instance Functor Partial where
    74:   fmap f (Now   x) = Now        (f x)
    75:   fmap f (Later x) = Later (fmap f x)
    76: 
    77: instance Applicative Partial where
    78:   pure = return
    79:   (Now   f) <*> x =        f <$> x
    80:   (Later f) <*> x = Later (f <*> x)
    81: 
    82: instance Monad Partial where
    83:   return = Now
    84:   (Now   x) >>= f = Later (f x)
    85:   (Later x) >>= f = Later (x >>= f)
    86: ```
    87: 
    88: ```{pipe="./append"}
    89: instance Eq a => Eq (Val a) where
    90:   C x == C y = x == y
    91:   _   == _   = False
    92: 
    93: instance Arbitrary a => Arbitrary (Term a) where
    94:   arbitrary = oneof [Var   <$> arbitrary,
    95:                      App   <$> arbitrary <*> arbitrary,
    96:                      Lam   <$> arbitrary,
    97:                      Const <$> arbitrary]
    98: 
    99: instance Arbitrary Nat where
   100:   arbitrary = oneof [return Z, S <$> arbitrary]
   101: 
   102: extractTo :: Int -> Partial a -> Maybe a
   103: extractTo _ (Now   x) = Just x
   104: extractTo n _ | n < 1 = Nothing
   105: extractTo n (Later x) = extractTo (n-1) x
   106: 
   107: evalFor n t = extractTo n (eval t)
   108: 
   109: normalIn :: Eq a => Int -> Term a -> Bool
   110: normalIn n t = evalFor n t /= Nothing
   111: 
   112: testId :: Eq a => Int -> Term a -> Bool
   113: testId n t = not (normalIn n t) ||
   114:              evalFor (n * n) (App (Lam (Var Z)) t) == evalFor n t
   115: ```
   116: 
   117: ```{pipe="ghci -v0"}
   118: :load code.hs
   119: quickCheck testId
   120: ```