some fixes and improvements

pkg/proto/app/Main.hs

@@ -2,5 +2,36 @@ module Main where
 
 import ClassyPrelude
 
+import Control.Lens ((&))
+
+import Untyped.Parser hiding (main)
+import Untyped.CST
+import Untyped.Hoon
+import Untyped.Core
+import Nock
+import Noun
+import Dashboard
+
+import Text.Show.Pretty (pPrint)
+
+import qualified Prelude as P
+
+-------------------------------------------------------------------------------
+
 main :: IO ()
-main = pure ()
+main = (P.head <$> getArgs) >>= compileHoonTest
+
+compileHoonTest :: Text -> IO ()
+compileHoonTest ln = do
+    cst <- parse ln & \case
+              Left x  -> error (unpack x)
+              Right x -> pure x
+    pPrint cst
+    hon <- pure $ hone cst
+    pPrint hon
+    exp <- pure $ desugar hon
+    pPrint exp
+    nok <- pure $ copy exp
+    pPrint nok
+    res <- runCare $ nock (A 140) nok
+    pPrint res

pkg/proto/lib/Untyped/CST.hs

@@ -16,6 +16,7 @@ hone = go
       WutKet c d e -> H.WutKet (go c) (go d) (go e)
       WutPam cs -> foldr H.WutPam (H.HAtom 0) $ map go cs
       WutBar cs -> foldr H.WutBar (H.HAtom 1) $ map go cs
+      WutHep c pcs -> H.WutHep (go c) (map tr pcs)
       TisFas s c d -> H.TisFas s (go c) (go d)
       ColHep c d -> H.HCons (go c) (go d)
       ColLus{} -> error "hone: offensive rune :+ -- use :*"
@@ -26,12 +27,11 @@ hone = go
       BarTis s c -> H.BarTis s (go c)
       BarHep r v i c -> H.BarHep r v (go i) (go c)
       BarCen pcs -> H.BarCen (map tr pcs)
-        where
-          tr (PatTar, c) = (H.Wild, go c)
-          tr (PatNat a, c) = (H.Exact (A a), go c)
       CenHep c d -> H.CenHep (go c) (go d)
       CenDot c d -> H.CenDot (go c) (go d)
       DotDot s c -> H.DotDot s (go c)
+      SigFas (go -> H.HAtom a) c -> H.SigFas a (go c)
+      SigFas{} -> error "hone: invalid ~/ tag"
       ZapZap -> H.ZapZap
       Tupl cs -> go (ColTar cs)
       Var s -> H.HVar s
@@ -50,5 +50,9 @@ hone = go
       No -> H.HAtom 1
       Sig -> H.HAtom 0
 
+    tr (PatTar, c) = (H.Wild, go c)
+    tr (PatTag s, c) = (H.Exact (A $ textToAtom s), go c)
+
+
 textToAtom :: Text -> Atom
 textToAtom = undefined

pkg/proto/lib/Untyped/Hoon.hs

@@ -23,6 +23,7 @@ data Hoon a
   | DotDot a (Hoon a)
   | DotLus (Hoon a)
   | DotTis (Hoon a) (Hoon a)
+  | SigFas Atom (Hoon a)
   | WutBar (Hoon a) (Hoon a)
   | WutCol (Hoon a) (Hoon a) (Hoon a)
   | WutHep (Hoon a) (Cases a)
@@ -30,12 +31,16 @@ data Hoon a
   | WutPam (Hoon a) (Hoon a)
   | WutPat (Hoon a) (Hoon a) (Hoon a)
   | ZapZap
+  deriving (Functor)
+
+deriving instance Show a => Show (Hoon a)
 
 type Cases a = [(Pat, Hoon a)]
 
 data Pat
   = Exact Noun
   | Wild
+  deriving (Show)
 
 desugar :: Eq a => Hoon a -> Exp a
 desugar = go
@@ -53,6 +58,7 @@ desugar = go
       DotDot v h     -> fix v (go h)
       DotLus h       -> Suc (go h)
       DotTis h j     -> Eql (go h) (go j)
+      SigFas a h     -> Jet a (go h)
       WutBar h j     -> Ift (go h) (Atm 0) (go j)
       WutCol h j k   -> Ift (go h) (go j) (go k)
       -- or branch go (go h) cs

pkg/proto/lib/Untyped/Parser.hs

@@ -23,7 +23,7 @@ import qualified Prelude
 -- Types -----------------------------------------------------------------------
 
 type Nat  = Natural
-type Sym  = String
+type Sym  = Text
 
 
 -- CST -------------------------------------------------------------------------
@@ -52,11 +52,12 @@ data CST
     | CenHep CST CST              --  %-  f  x
     | CenDot CST CST              --  %.  x  f
     | DotDot Sym CST              --  ..  $  f
+    | SigFas CST CST
     | ZapZap                      --  !!
     | Tupl [CST]                  --  [a b ...]
     | Var  Sym                    --  a
     | Atom Nat                    --  3
-    | Tag Sym                     --  %asdf
+    | Tag Text                    --  %asdf
     | Cord Text                   --  'cord'
     | Tape Text                   --  "tape"
     | Incr CST                    --  .+(3)
@@ -106,7 +107,7 @@ alpha ∷ Parser Char
 alpha = oneOf (['a'..'z'] ++ ['A'..'Z'])
 
 sym ∷ Parser Sym
-sym = bucSym <|> some alpha
+sym = bucSym <|> pack <$> some alpha
   where bucSym = char '$' *> pure ""
 
 atom ∷ Parser Nat
@@ -129,7 +130,7 @@ cord = do
   between (char '\'') (char '\'') $
     pack <$> many (label "cord char" (anySingleBut '\''))
 
-tag ∷ Parser String
+tag ∷ Parser Text
 tag = try (char '%' >> sym)
 
 literal ∷ Parser CST
@@ -309,6 +310,7 @@ rune = runeSwitch [ ("|=", rune2 BarTis sym cst)
                   , (".=", rune2 IsEq cst cst)
                   , ("?-", wutHep)
                   , ("|%", barCen)
+                  , ("~/", rune2 SigFas cst cst)
                   ]
 
 runeSwitch ∷ [(Text, Parser a)] → Parser a
@@ -318,7 +320,7 @@ runeSwitch = choice . fmap (\(s, p) → string s *> p)
 -- CST Parser ------------------------------------------------------------------
 
 cst ∷ Parser CST
-cst = irregular <|> literal <|> rune
+cst = irregular <|> rune <|> literal
 
 
 -- Entry Point -----------------------------------------------------------------