{-# LANGUAGE OverloadedStrings, LambdaCase #-}
import Control.Monad (void)
import Data.Char (isSpace)
import Haste.DOM
import Haste.Events
import Haste.Foreign (ffi)
import Haste.JSString
main :: IO ()
main = withElems ["prog", "inp", "out"] $ \[pEl, iEl, oEl] -> do
let
setup button inp = do
Just b <- elemById button
void $ b `onEvent` Click $ const $ go button inp
go button inp = do
Just grandparent <- elemById $ button ++ ".hs"
Just parent <- getFirstChild grandparent
Just p <- getFirstChild parent
prog <- dropWhile isSpace <$> getProp p "textContent"
inscribe prog inp
inscribe prog inp = do
setProp pEl "value" prog
setProp iEl "value" inp
setProp oEl "value" ""
setup "hello" ""
setup "edigits" ""
setup "primes" ""
setup "queens" ""
setup "lindon" "you can cage a swallow can't you"
setup "sort" "James while John had had had had had had had had had had had a better effect on the teacher"
setup "hexmaze" ""
setup "gray" ""
setup "hilbert" ""
setup "douady" ""
setup "enigma" "ATTACKATDAWN"
setup "sha256" ""
setup "keccak" ""
go "hello" ""
let parm = ffi "parm" :: JSString -> IO JSString
parm "a" >>= \case
"0" -> do
prog <- parm "p"
inp <- parm "i"
inscribe (unpack prog) (unpack inp)
"1" -> do
preset <- parm "p"
inp <- parm "i"
go (unpack preset) (unpack inp)
_ -> pure ()
Compilers for contrarians
An award-winning Haskell compiler, browser edition.
[+] Show modules
import System main = putStrLn "Hello, World!"
import Base import System -- Digits of e. See http://miranda.org.uk/examples. mkdigit n | n <= 9 = chr (n + ord '0') norm c (d:e:x) | e `mod` c + 10 <= c = d + e `div` c : e' `mod` c : x' | otherwise = d + e' `div` c : e' `mod` c : x' where (e':x') = norm (c+1) (e:x) convert x = mkdigit h:convert t where (h:t) = norm 2 (0:map (10*) x) edigits = "2." ++ convert (repeat 1) main = putStr $ take 1024 edigits
import Base import System primes = sieve [2..] sieve (p:x) = p : sieve [n | n <- x, n `mod` p /= 0] main = print $ take 100 $ primes
-- Eight queens puzzle. See http://miranda.org.uk/examples. import Base import System safe q b = and[not $ q==p || abs(q-p)==i|(p,i) <- zip b [1..]] queens sz = go sz where go 0 = [[]] go n = [q:b | b <- go (n - 1), q <- [1..sz], safe q b] main = print $ queens 8
-- King, are you glad you are king? import Base import System main = interact $ unwords . reverse . words
import Base import System main = interact $ unwords . sorta . words sorta [] = [] sorta (x:xt) = sorta (filter (<= x) xt) ++ [x] ++ sorta (filter (> x) xt)
-- https://fivethirtyeight.com/features/can-you-escape-this-enchanted-maze/ import Base import Map import System maze = fromList $ concat $ zipWith row [0..] [ "." , "IF" , " BLUE" , "Z ASKS" , "AMY EE" , "DANCES" , " QUEEN" , " Z O" , " O" ] where row r s = concat $ zipWith (cell r) [0..] s cell r c x | x /= ' ' = [((r, c), x)] | otherwise = [] dirs = [(1, 0), (0, 0-1), (0-1, 0-1), (0-1, 0), (0, 1), (1, 1)] turn f x = take 2 $ tail $ dropWhile (/= x) $ cycle $ f dirs data Hex = Hex (Int, Int) (Int, Int) String step (Hex (x, y) (xd, yd) path) = [Hex pos' (xd', yd') (c:path) | (xd', yd') <- next (xd, yd), let pos' = (x + xd', y + yd'), member pos' maze] where c = maze!(x, y) next = turn $ if elem c "AEIOUY" then id else reverse bfs moves = case asum $ won <$> moves of Nothing -> bfs $ step =<< moves Just soln -> reverse soln where won (Hex pos _ path) | maze!pos == '.' && elem 'M' path = Just path | otherwise = Nothing main = putStrLn $ bfs [Hex (5, 0) (1, 1) ""]
-- Gray code. import Base import System gray 0 = [""] gray n = ('0':) <$> gray (n - 1) <|> reverse (('1':) <$> gray (n - 1)) main = putStrLn $ unwords $ gray 4
-- Theorem prover based on a Hilbert system. -- https://crypto.stanford.edu/~blynn/compiler/hilsys.html import Base import System data Term = Var String | Fun String [Term] deriving Eq data FO = Top | Bot | Atom String [Term] | Not FO | FO :/\ FO | FO :\/ FO | FO :==> FO | FO :<=> FO | Forall String FO | Exists String FO deriving Eq data Theorem = Theorem FO instance Show Term where showsPrec _ = \case Var s -> (s ++) Fun s ts -> (s ++) . showParen (not $ null ts) (foldr (.) id $ intersperse (", "++) $ map shows ts) instance Show FO where showsPrec p = \case Top -> ('1':) Bot -> ('0':) Atom s ts -> shows $ Fun s ts Not x -> ('~':) . showsPrec 4 x x :/\ y -> showParen (p > 3) $ showsPrec 3 x . (" /\\ " ++) . showsPrec 3 y x :\/ y -> showParen (p > 2) $ showsPrec 2 x . (" \\/ " ++) . showsPrec 2 y x :==> y -> showParen (p > 1) $ showsPrec 2 x . (" ==> " ++) . showsPrec 1 y x :<=> y -> showParen (p > 1) $ showsPrec 2 x . (" <=> " ++) . showsPrec 1 y Forall s x -> showParen (p > 0) $ ("forall " ++) . (s++) . (". "++) . showsPrec 0 x Exists s x -> showParen (p > 0) $ ("exists " ++) . (s++) . (". "++) . showsPrec 0 x occurs s t = s == t || case t of Var _ -> False Fun _ args -> any (occurs s) args isFree t = \case Top -> False Bot -> False Atom _ ts -> any (occurs t) ts Not x -> isFree t x x :/\ y -> isFree t x || isFree t y x :\/ y -> isFree t x || isFree t y x :==> y -> isFree t x || isFree t y x :<=> y -> isFree t x || isFree t y Forall v x -> not (occurs (Var v) t) && isFree t x Exists v x -> not (occurs (Var v) t) && isFree t x s =: t = Atom "=" [s, t] ponens (Theorem (p :==> q)) (Theorem p') | p == p' = Theorem q gen x (Theorem t) = Theorem $ Forall x t axiomK p q = Theorem $ p :==> (q :==> p) axiomS p q r = Theorem $ (p :==> (q :==> r)) :==> ((p :==> q) :==> (p :==> r)) axiomLEM p = Theorem $ ((p :==> Bot) :==> Bot) :==> p axiomAllImp x p q = Theorem $ Forall x (p :==> q) :==> (Forall x p :==> Forall x q) axiomImpAll x p | isFree (Var x) p = Theorem $ p :==> Forall x p axiomExEq x t | occurs (Var x) t = Theorem $ Exists x $ Var x =: t axiomRefl t = Theorem $ t =: t axiomFunCong f ls rs = Theorem $ foldr (:==>) (Fun f ls =: Fun f rs) $ zipWith (=:) ls rs axiomPredCong p ls rs = Theorem $ foldr (:==>) (Atom p ls :==> Atom p rs) $ zipWith (=:) ls rs axiomIffImp1 p q = Theorem $ (p :<=> q) :==> (p :==> q) axiomIffImp2 p q = Theorem $ (p :<=> q) :==> (q :==> p) axiomImpIff p q = Theorem $ (p :==> q) :==> ((q :==> p) :==> (p :<=> q)) axiomTrue = Theorem $ Top :<=> (Bot :==> Bot) axiomNot p = Theorem $ Not p :<=> (p :==> Bot) axiomAnd p q = Theorem $ (p :/\ q) :<=> ((p :==> (q :==> Bot)) :==> Bot) axiomOr p q = Theorem $ (p :\/ q) :<=> Not (Not p :/\ Not q) axiomExists x p = Theorem $ Exists x p :<=> Not (Forall x $ Not p) -- |- p ==> p impRefl p = ponens (ponens (axiomS p (p :==> p) p) (axiomK p $ p :==> p)) (axiomK p p) -- |- p ==> p ==> q / |- p ==> q impDedup th@(Theorem (p :==> (_ :==> q))) = ponens (ponens (axiomS p p q) th) (impRefl p) -- |- q / |- p ==> q addAssum p th@(Theorem f) = ponens (axiomK f p) th -- |- q ==> r / |- (p ==> q) ==> (p ==> r) impAddAssum p th@(Theorem (q :==> r)) = ponens (axiomS p q r) (addAssum p th) -- |- p ==> q |- q ==> r / |- p ==> r impTrans th1@(Theorem (p :==> _)) th2 = ponens (impAddAssum p th2) th1 -- |- p ==> r / |- p ==> q ==> r impInsert q th@(Theorem (p :==> r)) = impTrans th (axiomK r q) -- |- p ==> q ==> r / |- q ==> p ==> r impSwap th@(Theorem (p :==> (q :==> r))) = impTrans (axiomK q p) $ ponens (axiomS p q r) th -- |- (q ==> r) ==> (p ==> q) ==> (p ==> r) impTransTh p q r = impTrans (axiomK (q :==> r) p) (axiomS p q r) -- |- p ==> q / |- (p ==> r) ==> (q ==> r) impAddConcl r th@(Theorem (p :==> q)) = ponens (impSwap (impTransTh p q r)) th -- |- (p ==> q ==> r) ==> (q ==> p ==> r) impSwapTh p q r = impTrans (axiomS p q r) $ impAddConcl (p :==> r) $ axiomK q p -- |- (p ==> q ==> r) ==> (s ==> t ==> u) / |- (q ==> p ==> r) ==> (t ==> s ==> u) impSwap2 th@(Theorem ((p :==> (q :==> r)) :==> (s :==> (t :==> u)))) = impTrans (impSwapTh q p r) (impTrans th (impSwapTh s t u)) -- |- p ==> q ==> r |- p ==> q / |- p ==> r rightMP ith th = impDedup (impTrans th (impSwap ith)) -- |- p <=> q / |- p ==> q iffImp1 th@(Theorem (p :<=> q)) = ponens (axiomIffImp1 p q) th -- |- p <=> q / |- q ==> p iffImp2 th@(Theorem (p :<=> q)) = ponens (axiomIffImp2 p q) th -- |- p ==> q |- q ==> p / |- p <=> q impAntisym th1@(Theorem (p :==> q)) th2 = ponens (ponens (axiomImpIff p q) th1) th2 -- |- p ==> (q ==> 0) ==> 0 / |- p ==> q rightDoubleNeg th@(Theorem (p :==> ((_ :==> Bot) :==> Bot))) = impTrans th $ axiomLEM p -- |- 0 ==> p exFalso p = rightDoubleNeg $ axiomK Bot (p :==> Bot) -- |- 1 truth = ponens (iffImp2 axiomTrue) (impRefl Bot) -- |- s = t ==> t = s eqSym s t = let rth = axiomRefl s f th = ponens (impSwap th) rth in f $ f $ axiomPredCong "=" [s, s] [t, s] -- |- s = t ==> t = u ==> s = u eqTrans s t u = let th1 = axiomPredCong "=" [t, u] [s, u] th2 = ponens (impSwap th1) (axiomRefl u) in impTrans (eqSym s t) th2 examples = [ axiomOr (Atom "x" []) (Atom "y" []) , impTransTh (Atom "Foo" []) (Atom "Bar" []) (Atom "Baz" []) , eqSym (Var "a") (Var "b") , eqTrans (Var "x") (Var "y") (Var "z") ] concl (Theorem t) = t main = mapM_ (putStr . flip shows "\n" . concl) examples
-- Based on https://sametwice.com/4_line_mandelbrot. import Base import System prec :: Int prec = 16384 infixl 7 # x # y = x * y `div` prec sqAdd (x, y) (a, b) = (a#a - b#b + x, 2*(a#b) + y) norm (x, y) = x#x + y#y douady p = null . dropWhile (\z -> norm z < 4*prec) . take 30 $ iterate (sqAdd p) (0, 0) main = putStr $ unlines [[if douady (616*x - 2*prec, 1502*y - 18022) then '*' else ' ' | x <- [0..79]] | y <- [0..23]]
-- https://crypto.stanford.edu/~blynn/haskell/enigma.html import Base import System wI = ("EKMFLGDQVZNTOWYHXUSPAIBRCJ", "Q") wII = ("AJDKSIRUXBLHWTMCQGZNPYFVOE", "E") wIII = ("BDFHJLCPRTXVZNYEIWGAKMUSQO", "V") wIV = ("ESOVPZJAYQUIRHXLNFTGKDCMWB", "J") wV = ("VZBRGITYUPSDNHLXAWMJQOFECK", "Z") ukwA = "EJMZALYXVBWFCRQUONTSPIKHGD" ukwB = "YRUHQSLDPXNGOKMIEBFZCWVJAT" ukwC = "FVPJIAOYEDRZXWGCTKUQSBNMHL" abc = ['A'..'Z'] abc2 = abc ++ abc sub p x = maybe x id $ lookup x $ zip abc p unsub p x = maybe x id $ lookup x $ zip p abc shift k = sub $ dropWhile (/= k) $ abc2 unshift k = unsub $ dropWhile (/= k) $ abc2 conjugateSub p k = unshift k . sub p . shift k rotorSubs gs = zipWith conjugateSub (fst <$> rotors) gs rotors = [wI, wII, wIII] zap gs = unsub p . sub ukwB . sub p where p = foldr1 (.) (rotorSubs gs) <$> abc turn gs@[_, g2, g3] = zipWith (bool id $ shift 'B') bs gs where [_, n2, n3] = snd <$> rotors bs = [g2 `elem` n2, g2 `elem` n2 || g3 `elem` n3, True] enigma grundstellung = zipWith zap $ tail $ iterate turn grundstellung main = interact $ enigma "AAA"
-- SHA-256. -- -- To make this more fun, we compute the algorithm's constants ourselves. -- They are the first 32 bits of the fractional parts of the square roots -- and cube roots of primes and hence are nothing-up-my-sleeve numbers. module Main where import Base import System -- Fixed-point arithmetic with scaling 1/2^40. -- We break the ring laws but get away with it. denom = 2^40 data Fixie = Fixie Integer deriving Eq instance Ring Fixie where Fixie a + Fixie b = Fixie (a + b) Fixie a - Fixie b = Fixie (a - b) Fixie a * Fixie b = Fixie (a * b `div` denom) fromInteger = Fixie . (denom *) properFraction (Fixie f) = (q, Fixie $ f - q) where q = div f denom truncate (Fixie f) = div f denom recip (Fixie f) = Fixie $ denom^2 `div` f a / b = a * recip b -- Square roots and cube roots via Newton-Raphson. -- In theory, the lowest bits may be wrong since we approach the root from one -- side, but everything turns out fine for our constants. newton f f' = iterate $ \x -> x - f x / f' x agree (a:t@(b:_)) = if a == b then a else agree t fracBits n = (`mod` 2^n) . agree . map (truncate . (2^n*)) primes = sieve [2..] where sieve (p:t) = p : sieve [n | n <- t, n `mod` p /= 0] rt2 n = newton (\x -> x^2 - n) (\x -> 2*x) 1 rt3 n = newton (\x -> x^3 - n) (\x -> 3*x^2) 1 initHash :: [Word] initHash = fromIntegral . fracBits 32 . rt2 . fromIntegral <$> take 8 primes roundKs :: [Word] roundKs = fromIntegral . fracBits 32 . rt3 . fromIntegral <$> take 64 primes -- A pale imitation of parts of `Data.Bits`. rshift :: Int -> Word -> Word rshift i = (`wordShr` fromIntegral i) rotr :: Int -> Word -> Word rotr i n = (wordShr n u) + (wordShl n (32 - u)) where u = fromIntegral i xor = wordXor (.&.) = wordAnd complement x = 0-1-x -- Swiped from `Data.List.Split`. chunksOf i ls = map (take i) (go ls) where go [] = [] go l = l : go (drop i l) -- Big-endian conversions and hex dumping for 32-bit words. be4 n = [div n (256^k) `mod` 256 | k <- reverse [0..3]] unbe4 cs = sum $ zipWith (*) cs $ (256^) <$> reverse [0..3] hexdigit n = chr $ n + (if n <= 9 then ord '0' else ord 'a' - 10) hex32 n = [hexdigit $ fromIntegral $ div n (16^k) `mod` 16 | k <- reverse [0..7]] -- SHA-256, at last. sha256 s = concatMap hex32 $ foldl chunky initHash $ chunksOf 16 ws where l = length s pad = 128 : replicate (4 + mod (64 - l - 9) 64) 0 ++ be4 (fromIntegral l * 8) ws = map unbe4 $ chunksOf 4 $ map (fromIntegral . fromEnum) s ++ pad chunky h c = zipWith (+) h $ foldl hashRound h $ zipWith (+) roundKs w where w = c ++ foldr1 (zipWith (+)) [w, s0, drop 9 w, s1] where s0 = foldr1 (zipWith xor) $ map (<$> tail w) [rotr 7, rotr 18, rshift 3] s1 = foldr1 (zipWith xor) $ map (<$> drop 14 w) [rotr 17, rotr 19, rshift 10] hashRound [a,b,c,d,e,f,g,h] kw = [t1 + t2, a, b, c, d + t1, e, f, g] where s1 = foldr1 xor $ map (`rotr` e) [6, 11, 25] ch = (e .&. f) `xor` (complement e .&. g) t1 = h + s1 + ch + kw s0 = foldr1 xor $ map (`rotr` a) [2, 13, 22] maj = (a .&. b) `xor` (a .&. c) `xor` (b .&. c) t2 = s0 + maj main = interact sha256
-- https://keccak.team/keccak_specs_summary.html -- https://en.wikipedia.org/wiki/SHA-3 -- -- This is the hash function used by Ethereum. -- To get the SHA-3 256 standard hash, in the `pad` function, -- change 0x81 to 0x86 and 0x01 to 0x06. import Base import System -- Ersatz `Data.Bits`. We use `xor` for more than one type. The others are only used on `Word64` values. class Xor a where xor :: a -> a -> a instance Xor Word64 where xor (Word64 a b) (Word64 c d) = Word64 (xor a c) (xor b d) instance Xor Word where xor = wordXor instance Xor Int where xor = intXor complement x = 0-1-x (Word64 a b) .|. (Word64 c d) = Word64 (wordOr a c) (wordOr b d) (Word64 a b) .&. (Word64 c d) = Word64 (wordAnd a c) (wordAnd b d) rotateL (Word64 a b) nInt = let n = wordFromInt nInt in uncurry Word64 (word64Shl a b n 0) .|. uncurry Word64 (word64Shr a b (64 - n) 0) -- Swiped from `Data.List.Split`. chunksOf i ls = map (take i) (go ls) where go [] = [] go l = l : go (drop i l) -- We lack the instance needed for the fancier `drop n <> take n`. drta n xs = drop n xs <> take n xs onHead f (h:t) = (f h:t) kRound :: [[Word64]] -> Word64 -> [[Word64]] kRound a rc = onHead (onHead $ xor rc) chi where c = foldr1 (zipWith xor) a d = zipWith xor (drta 4 c) (map (`rotateL` 1) $ drta 1 c) theta = map (zipWith xor d) a b = [[rotateL ((theta!!i)!!x) $ rotCon x i | i <- [0..4], let x = (3*j+i) `mod` 5] | j <- [0..4]] chi = zipWith (zipWith xor) b $ zipWith (zipWith (.&.)) (map (map complement . drta 1) b) $ map (drta 2) b rotCon 0 0 = 0 rotCon x y = t `mod` 64 where Just t = lookup (x, y) hay hay = zip (iterate go (1, 0)) tri go (x, y) = (y, (3*y + 2*x) `mod` 5) tri = 1 : zipWith (+) tri [2..] rcs :: [Word64] rcs = take 24 $ go $ iterate lfsr 1 where go xs = sum (zipWith setOdd as [0..]) : go bs where (as, bs) = splitAt 7 xs setOdd n m = if mod n 2 == 1 then 2^(2^m - 1) else 0 lfsr :: Int -> Int lfsr n | n < 128 = 2*n | otherwise = xor 0x71 $ 2*(n - 128) keccak256 s = concatMap bytes $ take 4 $ head final where final = foldl go blank $ map fives $ chunksOf 17 $ word64s $ pad s go a b = foldl kRound (zipWith (zipWith xor) a b) rcs bytes n = take 8 $ chr . fromIntegral . (`mod` 256) <$> iterate (`div` 256) n fives = iterate (drop 5) . (++ repeat 0) blank = replicate 5 $ replicate 5 0 pad s = (s++) $ if n == 1 then ['\x81'] else '\x01':replicate (n - 2) '\x00' ++ ['\x80'] where n = 136 - mod (length s) 136 word64s :: String -> [Word64] word64s [] = [] word64s xs = foldr go 0 <$> chunksOf 8 xs where go d acc = fromIntegral (fromEnum d) + 256*acc hex c = (hexit q:) . (hexit r:) where (q, r) = divMod (ord c) 16 hexit c = chr $ c + (if c < 10 then 48 else 87) xxd = concatMap (`hex` "") main = interact $ xxd . keccak256
The above compiles a Haskell program to a WebAssembly binary [download it!], then runs it on the given input. Several language features are missing.
Best of the worst
In 2000, I took the Comprehensive Exams given by the Stanford University Computer Science department. In the Compilers exam, I got the top score…of those who failed.
It didn’t matter because I scraped through the Databases exam instead. But how could I fail Compilers? I had sailed through my undergrad compilers course, and written a few toy compilers for fun. I resolved to one day unravel the mystery.
Since then, I have sporadically read about various compiler topics. Did my younger self deserve to fail? Maybe. There were certainly gaps in that guy’s knowledge (which are only a shade narrower now). On the other hand, there are equally alarming gaps in my textbooks, so maybe I shouldn’t have failed.
Or maybe I’m still bitter about that exam. In any case, here is a dilettante’s guide to writing compilers while thumbing your nose at the establishment.
(I also flunked AI, Networks, and Numerical Analysis. After reading John L. Gustafson, The End of Error: Unum Computing, I’m glad I’m not an expert on the stuff they asked in that Numerical Analysis exam. But that’s a topic for another day.)
See also
Ben Lynn blynn@cs.stanford.edu 💡