the jet system!

pkg/proto/lib/Dashboard.hs

@@ -1,4 +1,17 @@
-module Dashboard where
+module Dashboard
+  ( pattern FastAtom
+  , pattern FastHint
+  , Jet
+  , Dashboard (match)
+  , Freeboard
+  , Hashboard
+  , Fastboard
+  , Careboard
+  , runFree
+  , runHash
+  , runFast
+  , runCare
+  ) where
 
 import ClassyPrelude
 
@@ -7,33 +20,48 @@ import Control.Monad.State.Strict
 import Noun
 
 type Jet = Noun -> Noun
+type JetName = Atom
 type Hash = Int
 
+pattern FastAtom = 9999
+pattern FastHint id n =
+  C (A 11)
+    (C
+      (C (A FastAtom) (C (A 1) (A id)))
+      n)
+
+-- | A context in which to run nock which supports jet lookup.
 class Monad m => Dashboard m where
-  register :: Atom -> Noun -> m ()
+  -- | Find the jet associated with the formula represented by the given noun,
+  -- if any.
   match :: Noun -> m (Maybe Jet)
 
+-- | A dashboard which doesn't jet.
 newtype Freeboard a = Freeboard (Identity a)
   deriving newtype Functor
   deriving newtype Applicative
   deriving newtype Monad
 
+-- | A dashboard which looks for jets by formula hash
 newtype Hashboard a = Hashboard (Identity a)
   deriving newtype Functor
   deriving newtype Applicative
   deriving newtype Monad
 
-newtype Fastboard a = Fastboard (State (HashMap Noun Jet) a)
+-- | A dashboard which checks the head of formulas for "fast
+-- hints" and uses the name contained in such a hint to look for jets.
+newtype Fastboard a = Fastboard (Identity a)
   deriving newtype Functor
   deriving newtype Applicative
   deriving newtype Monad
 
-{-
-newtype Careboard a = Careboard (State (HashMap Noun Jet) a)
+-- | A dashboard which uses both lookup strategies, checking for consistency
+-- between them and that each fast hint is applied to a unique formula.
+-- Violations of these principles are written to standard out.
+newtype Careboard a = Careboard (StateT (HashMap JetName Noun) IO a)
   deriving newtype Functor
   deriving newtype Applicative
   deriving newtype Monad
--}
 
 runFree :: Freeboard a -> a
 runFree (Freeboard x) = runIdentity x
@@ -42,29 +70,60 @@ runHash :: Hashboard a -> a
 runHash (Hashboard x) = runIdentity x
 
 runFast :: Fastboard a -> a
-runFast (Fastboard x) = evalState x mempty 
+runFast (Fastboard x) = runIdentity x
+
+runCare :: Careboard a -> IO a
+runCare (Careboard x) = evalStateT x mempty
 
 instance Dashboard Freeboard where
-  register _ _ = pure ()
-  match _ = pure Nothing
+  match _ = Freeboard $ pure Nothing
 
 instance Dashboard Hashboard where
-  register _ _ = pure ()
-  match n = Hashboard $ pure $ byHash $ hash n
+  match = Hashboard . pure . byHash . hash
 
-byFast :: Atom -> Maybe Jet
+instance Dashboard Fastboard where
+  match = Fastboard . \case
+    FastHint id n -> pure (byFast id)
+    _ -> pure Nothing
+
+-- TODO maybe also detect hash collisions
+instance Dashboard Careboard where
+  match = Careboard . \case
+    n@(FastHint nm _) -> case namely nm of
+      Just (h, j) -> do
+        when (h /= hash n) $
+          putStrLn ("careboard: jet " <> tshow nm <> " should have its hash "
+                    <> "updated from " <> tshow h <> " to " <> tshow (hash n))
+        get <&> lookup nm >>= \case
+          Just n' ->
+            when (n' /= n) $
+              putStrLn ("careboard: jet hint " <> tshow nm <> " has been "
+                        <> "detected on unequal formulae " <> tshow n
+                        <> " and " <> tshow n' <> ", which is very bad")
+          Nothing -> modify' (insertMap nm n)
+        pure (Just j)
+    n -> pure $ byHash $ hash n
+
+byFast :: JetName -> Maybe Jet
 byFast = flip lookup fast
   where
-    fast :: HashMap Atom Jet
-    fast = mapFromList $ map (\(l, h, j) -> (l, j)) jets
+    fast :: HashMap JetName Jet
+    fast = mapFromList $ map (\(n, _, j) -> (n, j)) jets
 
 byHash :: Hash -> Maybe Jet
 byHash = flip lookup hash
   where
     hash :: HashMap Hash Jet
-    hash = mapFromList $ map (\(l, h, j) -> (h, j)) jets
+    hash = mapFromList $ map (\(_, h, j) -> (h, j)) jets
 
-type Entry = (Atom, Hash, Jet)
+namely :: JetName -> Maybe (Hash, Jet)
+namely = flip lookup fash
+  where
+    fash :: HashMap JetName (Hash, Jet)
+    fash = mapFromList $ map (\(n, h, j) -> (n, (h, j))) jets
+
+type Entry = (JetName, Hash, Jet)
+-- | Your jets here
 jets :: [Entry]
 jets =
   [

pkg/proto/lib/Nock.hs

@@ -26,9 +26,6 @@ data Hint = Tag Atom
           | Assoc Atom Nock
   deriving (Eq, Ord, Read, Show, Generic)
 
-pattern FastAtom = 9999
-pattern FastHint id = Assoc FastAtom (N1 (A id))
-
 instance Hashable Nock
 instance Hashable Hint
 
@@ -87,7 +84,9 @@ nock n = \case
   N2 sf ff -> do
     s <- nock n sf
     f <- nock n ff
-    nock s (nounToNock f)
+    match f >>= \case
+      Just jet -> pure (jet s)
+      Nothing  -> nock s (nounToNock f)
   N3 f -> nock n f <&> \case
     C{} -> yes
     A{} -> no

pkg/proto/lib/UntypedLambda.hs

@@ -11,6 +11,7 @@ import Data.Maybe (fromJust)
 import qualified Data.Set as Set
 import Data.Void
 
+import Dashboard (pattern FastAtom)
 import Nock
 import Noun