From 4a666d1aa6bb213892034a044562819098ab3110 Mon Sep 17 00:00:00 2001
From: Benjamin Summers <benjamin@tlon.io>
Date: Wed, 26 Jun 2019 16:40:31 -0700
Subject: [PATCH] Generate FromNoun code for record types.

---
 pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs | 15 ++++++++++++---
 pkg/hs-urbit/lib/Vere/Pier/Types.hs   | 11 ++---------
 2 files changed, 14 insertions(+), 12 deletions(-)

diff --git a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs
index 82f2b9dfb0..20a7d710a9 100644
--- a/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs
+++ b/pkg/hs-urbit/lib/Data/Noun/Poet/TH.hs
@@ -91,8 +91,7 @@ deriveFromNoun tyName = do
 enumFromAtom :: [Name] -> Exp
 enumFromAtom nms = LamE [VarP n] body
   where
-    n         = mkName "n"
-    c         = mkName "c"
+    (n, c)    = (mkName "n", mkName "c")
     getCord   = BindS (VarP c) $ AppE (VarE 'parseNoun) (VarE n)
     examine   = NoBindS $ CaseE (VarE c) (matches ++ [fallback])
     matches   = mkMatch <$> nms
@@ -104,8 +103,18 @@ enumFromAtom nms = LamE [VarP n] body
                   (NormalB $ AppE (VarE 'pure) (ConE n))
                   []
 
+applyE :: Exp -> [Exp] -> Exp
+applyE e []     = e
+applyE e (a:as) = applyE (AppE e a) as
+
 tupFromNoun :: ConInfo -> Exp
-tupFromNoun _ = VarE 'undefined
+tupFromNoun (n, tys) = LamE [VarP x] body
+  where
+    x       = mkName "x"
+    vars    = mkName . singleton . fst <$> zip ['a'..] tys
+    body    = DoE [getTup, convert]
+    convert = NoBindS $ AppE (VarE 'pure) $ applyE (ConE n) (VarE <$> vars)
+    getTup  = BindS (TupP $ VarP <$> vars) $ AppE (VarE 'parseNoun) (VarE x)
 
 sumFromNoun :: [ConInfo] -> Exp
 sumFromNoun _ = VarE 'undefined
diff --git a/pkg/hs-urbit/lib/Vere/Pier/Types.hs b/pkg/hs-urbit/lib/Vere/Pier/Types.hs
index 4c5ef29317..6974f7d4f0 100644
--- a/pkg/hs-urbit/lib/Vere/Pier/Types.hs
+++ b/pkg/hs-urbit/lib/Vere/Pier/Types.hs
@@ -34,22 +34,15 @@ data EffBs
     | EBLolr Word Word
 
 data RecEx = RE Word Word
+  deriving (Eq, Ord, Show)
 
 data NewtEx = NE Word
+  deriving (Eq, Ord, Show)
 
 deriveNoun ''EffBs
 deriveNoun ''RecEx
 deriveNoun ''NewtEx
 
-{-
-    instance FromNoun PutDel where
-      parseNoun n = do
-        parseNoun n >>= \case
-          Cord "put" -> pure Put
-          Cord "del" -> pure Del
-          Cord cord  -> fail ("Invalid turf operation: " <> show cord)
--}
-
 data Eff
     = HttpServer Server.Eff
     | HttpClient Client.Eff