content: = Compilers for contrarians =
  
  link:ioccc.html[An award-winning Haskell compiler], browser edition.
  
  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  <textarea id='mod_base' hidden>
  include::inn/BasePrecisely.hs[]
  </textarea>
  <textarea id='mod_map' hidden>
  include::inn/Map1.hs[]
  </textarea>
  <textarea id='mod_system' hidden>
  include::inn/SystemWasm.hs[]
  </textarea>
  <p><span style='cursor:pointer;' onclick='hideshow("pre");'><span id='pre_toggle'>[+] Show</span> modules</span></p>
  <div id='pre' style='display:none;'>
  <style>#modlist li:hover{text-decoration:underline;}</style>
  <ul id='modlist'></ul>
  <p>
  <textarea spellcheck='false' id='modinp' rows='16' style='box-sizing:border-box;width:100%;'></textarea>
  <button onclick="update_module()">Update Module</button>
  </p>
  </div>
  
  <div id='compiler' style='display:none;'>
  <p>
  <label for="prog">Program:</label>
  <button id="hello">&#127760;</button>
  <button id="edigits"><i>e</i></button>
  <button id="primes">&#8473;</button>
  <button id="queens">&#9819;</button>
  <button id="lindon">Lindon</button>
  <button id="sort">&#9035;</button>
  <button id="hexmaze">&#11042;</button>
  <button id="gray">Gray</button>
  <button id="hilbert">Hilbert</button>
  <button id="douady">Douady</button>
  <button id="enigma">Enigma</button>
  <button id="sha256">SHA-256</button>
  <button id="keccak">Keccak-256</button>
  </p>
  <p>
  <textarea spellcheck='false' rows='12' id="prog" name="prog"
  style='box-sizing:border-box;width:100%;'>
  </textarea>
  </p>
  <label for="inp">Input:</label>
  <p>
  <textarea spellcheck='false' id='inp' rows='2' style='box-sizing:border-box;width:100%;'></textarea>
  </p>
  <p>
  <button onclick="go()">Run</button>
  <button onclick="genlink()">Linkify</button>
  <span id="msg"></span>
  </p>
  <label for="out">Output:</label>
  <p>
  <textarea spellcheck='false' readonly id='out' rows='8' style='box-sizing:border-box;width:100%;'></textarea>
  </p>
  </div>
  
  <script>
  "use strict";
  function hideshow(s) {
    const x = document.getElementById(s);
    const xt = document.getElementById(s + "_toggle");
    if (x.style.display === "none") {
      x.style.display = "block";
      xt.innerText = "[-] Hide"
    } else {
      x.style.display = "none";
      xt.innerText = "[+] Show"
    }
  }
  
  var blah;
  var blahInp, blahInpLen, blahInpCur;
  function setInput(s) {
    blahInp = s;
    blahInpLen = s.length;
    blahInpCur = 0;
  }
  var blahOut;
  const modmap = new Map();
  modmap.set('Base', document.getElementById('mod_base').value);
  modmap.set('Map', document.getElementById('mod_map').value);
  modmap.set('System', document.getElementById('mod_system').value);
  
  WebAssembly.instantiateStreaming(fetch('imp.wasm'), { env:
    { getchar: () => {
        if (blahInpCur == blahInpLen) throw "eof";
        blahInpCur++;
        return blahInp.charCodeAt(blahInpCur - 1);
      }
    , putchar: c => blahOut.push(c)
    , eof: () => blahInpCur == blahInpLen
    , get_module: () => {
        const mod = String.fromCharCode.apply(null, blahOut);
        blahOut = [];
        setInput("");
        if (modmap.has(mod)) setInput(modmap.get(mod));
      }
    }}).then(obj => {
      document.getElementById('compiler').style.display = "block";
      blah = obj.instance;
    });
  
  const modlist = document.getElementById('modlist');
  const modinp = document.getElementById('modinp');
  
  function populate_modlist() {
    modlist.innerText = "";
    for (const key of modmap.keys()) {
      const x = document.createElement("li");
      const y = document.createTextNode(key);
      x.addEventListener('click', function(){ modinp.value = modmap.get(key); });
      x.appendChild(y);
      modlist.appendChild(x);
    }
  }
  populate_modlist();
  
  function update_module() {
    setInput(modinp.value);
    blahOut = [];
    blah.exports.single_module();
    const mod = String.fromCharCode.apply(null, blahOut);
    if (mod == "") {
      console.log("module update failed");
    } else {
      modmap.set(mod, blahInp);
      populate_modlist();
    }
  }
  
  const msg = document.getElementById("msg");
  let lastProg = "";
  const program = document.getElementById("prog");
  const stdin = document.getElementById("inp");
  const stdout = document.getElementById("out");
  
  function compile() {
    msg.innerText = "compiling...";
    stdout.value = "";
    setInput(program.value);
    if (lastProg == blahInp) return new Promise(function(resolve) { resolve() });
    lastProg = blahInp;
    blahOut = [];
    // Timeout so message is displayed. Unreliable.
    return new Promise(function(resolve, reject) {
      setTimeout(function() {
    blah.exports.go();
    if (blahOut[0] != 0) {
      msg.innerText = "compile error: " + String.fromCharCode.apply(null, blahOut);
      reject();
    } else {
      msg.innerText = "";
      resolve();
    }
      }, 0);
    });
  }
  
  function run() {
    msg.innerText = "running...";
    const inp = stdin.value;
    const inpLen = inp.length;
    let inpCur = 0;
    stdout.value = "";
    function pc(x) { stdout.value += String.fromCharCode(x); }
    function gc() {
      if (inpCur == inpLen) throw "eof";
      inpCur++;
      return inp.charCodeAt(inpCur - 1);
    }
    function eof() { return inpCur == inpLen; }
    WebAssembly.instantiate(new Uint8Array(blahOut),
        {env:{getchar:gc, putchar:pc, eof:eof}}).then(x => {
      x.instance.exports.main();
      msg.innerText = "";
    });
  }
  
  function downloadWasm() {
    compile().then(x => {
      const blob = new Blob([new Uint8Array(blahOut)], {type: "application/octet-stream"});
      const a = document.createElement('a');
      a.style.display = 'none';
      document.body.append(a);
      const url = URL.createObjectURL(blob);
      a.href = url;
      a.download = "out.wasm";
      a.click();
      URL.revokeObjectURL(url);
    });
  }
  function go() { compile().then(x => { run(); }); }
  
  function genlink() {
    const s = "https://"
      + window.location.hostname
      + window.location.pathname
      + "?a=0&p="
      + encodeURIComponent(program.value)
      + "&i="
      + encodeURIComponent(stdin.value);
    out.value = s;
  }
  </script>
  <div style="display:none;">
  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  
  [id="hello.hs"]
  ------------------------------------------------------------------------
  import System
  main = putStrLn "Hello, World!"
  ------------------------------------------------------------------------
  
  [id="edigits.hs"]
  ------------------------------------------------------------------------
  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
  ------------------------------------------------------------------------
  
  [id="primes.hs"]
  ------------------------------------------------------------------------
  import Base
  import System
  primes = sieve [2..]
  sieve (p:x) = p : sieve [n | n <- x, n `mod` p /= 0]
  main = print $ take 100 $ primes
  ------------------------------------------------------------------------
  
  [id="queens.hs"]
  ------------------------------------------------------------------------
  -- 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
  ------------------------------------------------------------------------
  
  [id="lindon.hs"]
  ------------------------------------------------------------------------
  -- King, are you glad you are king?
  import Base
  import System
  main = interact $ unwords . reverse . words
  ------------------------------------------------------------------------
  
  [id="sort.hs"]
  ------------------------------------------------------------------------
  import Base
  import System
  main = interact $ unwords . sorta . words
  sorta [] = []
  sorta (x:xt) = sorta (filter (<= x) xt) ++ [x] ++ sorta (filter (> x) xt)
  ------------------------------------------------------------------------
  
  [id="hexmaze.hs"]
  ------------------------------------------------------------------------
  -- 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, -1), (-1, -1), (-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) ""]
  ------------------------------------------------------------------------
  
  [id="gray.hs"]
  ------------------------------------------------------------------------
  -- Gray code.
  import Base
  import System
  gray 0 = [""]
  gray n = ('0':) <$> gray (n - 1) <|> reverse (('1':) <$> gray (n - 1))
  main = putStrLn $ unwords $ gray 4
  ------------------------------------------------------------------------
  
  [id="hilbert.hs"]
  ------------------------------------------------------------------------
  -- Theorem prover based on a Hilbert system.
  -- https://crypto.stanford.edu/~blynn/compiler/hilsys.html
  import Base
  import System
  include::hilsys.inc[]
  ------------------------------------------------------------------------
  
  [id="douady.hs"]
  ------------------------------------------------------------------------
  -- 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]]
  ------------------------------------------------------------------------
  
  [id="enigma.hs"]
  ------------------------------------------------------------------------
  -- 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"
  ------------------------------------------------------------------------
  
  [id="sha256.hs"]
  ------------------------------------------------------------------------
  -- 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
  instance Field Fixie where
    recip (Fixie f) = Fixie $ denom*denom `div` f
  
  -- 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
  
  -- 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 (-9 - l) 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) [ror 7, ror 18, shr 3]
      s1 = foldr1 (zipWith xor) $ map (<$> drop 14 w) [ror 17, ror 19, shr 10]
      shr = flip shiftR
      ror = flip rotateR
  
  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 (rotateR e) [6, 11, 25]
    ch = (e .&. f) `xor` (complement e .&. g)
    t1 = h + s1 + ch + kw
    s0 = foldr1 xor $ map (rotateR a) [2, 13, 22]
    maj = (a .&. b) `xor` (a .&. c) `xor` (b .&. c)
    t2 = s0 + maj
  
  main = interact sha256
  ------------------------------------------------------------------------
  
  [id="keccak.hs"]
  ------------------------------------------------------------------------
  -- 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
  
  -- 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
  ------------------------------------------------------------------------
  
  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  </div>
  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  
  The above compiles a Haskell program to a WebAssembly binary [+++<a href='#'
  onclick='downloadWasm()'>download it!</a>+++], then runs it on the given input.
  Several language features are missing.
  
  Source: https://github.com/blynn/compiler[https://github.com/blynn/compiler]
  
  == 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 ==
  
  * https://github.com/chrisdone/duet[Duet is another tiny implementation of a
  subset of Haskell].
  
  * https://dl.acm.org/doi/pdf/10.1145/3677999.3678280[Lennart Augustsson, MicroHs: A Small Compiler for Haskell], and https://github.com/augustss/MicroHs[its accompanying source] looks amazing, though its goals differ ever so slightly to mine. While MicroHs also can be built with a C compiler, it relies on a large chunk of C that was generated by a Haskell program.
  
  
  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  <script>
  function inscribe(s, inp) {
    document.getElementById("prog").value = s;
    document.getElementById("inp").value = inp;
    document.getElementById("out").value = "";
  }
  
  function setup(name, inp) {
    document.getElementById(name).addEventListener("click", (event) =>
      inscribe(document.getElementById(name + ".hs").textContent.trim(), inp));
  }
  
  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", "");
  
  const params = (new URL(window.location.href)).searchParams;
  const a = params.get("a");
  if (params.get("a")) {
    if (a == "0") {
      inscribe(params.get("p"), params.get("i"));
    } else if (a == "1") {
      document.getElementById(params.get("p")).click();
      document.getElementById("inp").value = params.get("i");;
    }
  } else {
    document.getElementById("hello").click();
  }
  </script>
  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  