diff --git a/pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs b/pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
index 54ba660d5d..89dd760273 100644
--- a/pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
+++ b/pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
@@ -1,7 +1,7 @@
 {-|
     Template Haskell Code to Generate FromNoun and ToNoun Instances
 -}
-module Urbit.Noun.TH (deriveNoun, deriveToNoun, deriveFromNoun) where
+module Urbit.Noun.TH (deriveNoun, deriveToNoun, deriveFromNoun, deriveToNounFunc, deriveFromNounFunc) where
 
 import ClassyPrelude              hiding (fromList)
 import Control.Monad.Fail         (fail)
@@ -83,13 +83,9 @@ deriveNoun n = (<>) <$> deriveToNoun n <*> deriveFromNoun n
 
 deriveToNoun :: Name -> Q [Dec]
 deriveToNoun tyName = do
-    (params, shape) <- typeShape tyName
-
-    let exp = case shape of Vod             -> vodToNoun
-                            Tup con         -> tupToNoun con
-                         -- Enu cons        -> enumToAtom cons
-                            Sum atoms cells -> sumToNoun atoms cells
+    (params, _) <- typeShape tyName
 
+    exp    <- deriveToNounFunc tyName
     params <- pure $ zip ['a' ..] params <&> \(n,_) -> mkName (singleton n)
 
     let ty = foldl' (\acc v -> AppT acc (VarT v)) (ConT tyName) params
@@ -101,6 +97,15 @@ deriveToNoun tyName = do
 
     pure [InstanceD overlap ctx inst [ValD (VarP 'toNoun) body []]]
 
+deriveToNounFunc :: Name -> Q Exp
+deriveToNounFunc tyName = do
+    (_, shape) <- typeShape tyName
+    pure case shape of
+      Vod             -> vodToNoun
+      Tup con         -> tupToNoun con
+   -- Enu cons        -> enumToAtom cons
+      Sum atoms cells -> sumToNoun atoms cells
+
 --------------------------------------------------------------------------------
 
 addErrTag :: String -> Exp -> Exp
@@ -111,13 +116,9 @@ addErrTag tag exp =
 
 deriveFromNoun :: Name -> Q [Dec]
 deriveFromNoun tyName = do
-    (params, shape) <- typeShape tyName
-
-    let exp = case shape of Vod             -> vodFromNoun
-                            Tup con         -> tupFromNoun con
-                         -- Enu cons        -> enumFromAtom cons
-                            Sum atoms cells -> sumFromNoun atoms cells
+    (params, _) <- typeShape tyName
 
+    exp    <- deriveFromNounFunc tyName
     params <- pure $ zip ['a' ..] params <&> \(n,_) -> mkName (singleton n)
 
     let ty = foldl' (\acc v -> AppT acc (VarT v)) (ConT tyName) params
@@ -129,6 +130,15 @@ deriveFromNoun tyName = do
 
     pure [InstanceD overlap ctx inst [ValD (VarP 'parseNoun) body []]]
 
+deriveFromNounFunc :: Name -> Q Exp
+deriveFromNounFunc tyName = do
+    (_, shape) <- typeShape tyName
+    pure case shape of
+      Vod             -> vodFromNoun
+      Tup con         -> tupFromNoun con
+   -- Enu cons        -> enumFromAtom cons
+      Sum atoms cells -> sumFromNoun atoms cells
+
 sumFromNoun :: [(String, Name)] -> [(String, ConInfo)] -> Exp
 sumFromNoun [] cl = taggedFromNoun cl
 sumFromNoun at [] = enumFromAtom at