{-# 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"
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 Prelude
main = putStrLn "Hello, World!"
-- 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
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. 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? main = interact $ unwords . reverse . words
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/ 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. 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 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. 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 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"
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 💡