urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-19 00:13:12 +03:00
Code Issues Packages Projects Releases Wiki Activity

kh: expose to/fromNoun template logic separately

Browse Source 
Separately from deriveNoun, which gives you an entire instance. Having
access to these lets you call out to the auto-generated conversion
logic when writing custom code for it.
This commit is contained in:
fang 2021-04-02 13:21:20 +02:00
parent 939055f334
commit 2e2361e522
No known key found for this signature in database
GPG Key ID: EB035760C1BBA972
1 changed files with 23 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
View File

@ -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