mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-09-20 23:18:00 +03:00
kh: expose to/fromNoun template logic separately
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:
parent
939055f334
commit
2e2361e522
@ -1,7 +1,7 @@
|
|||||||
{-|
|
{-|
|
||||||
Template Haskell Code to Generate FromNoun and ToNoun Instances
|
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 ClassyPrelude hiding (fromList)
|
||||||
import Control.Monad.Fail (fail)
|
import Control.Monad.Fail (fail)
|
||||||
@ -83,13 +83,9 @@ deriveNoun n = (<>) <$> deriveToNoun n <*> deriveFromNoun n
|
|||||||
|
|
||||||
deriveToNoun :: Name -> Q [Dec]
|
deriveToNoun :: Name -> Q [Dec]
|
||||||
deriveToNoun tyName = do
|
deriveToNoun tyName = do
|
||||||
(params, shape) <- typeShape tyName
|
(params, _) <- typeShape tyName
|
||||||
|
|
||||||
let exp = case shape of Vod -> vodToNoun
|
|
||||||
Tup con -> tupToNoun con
|
|
||||||
-- Enu cons -> enumToAtom cons
|
|
||||||
Sum atoms cells -> sumToNoun atoms cells
|
|
||||||
|
|
||||||
|
exp <- deriveToNounFunc tyName
|
||||||
params <- pure $ zip ['a' ..] params <&> \(n,_) -> mkName (singleton n)
|
params <- pure $ zip ['a' ..] params <&> \(n,_) -> mkName (singleton n)
|
||||||
|
|
||||||
let ty = foldl' (\acc v -> AppT acc (VarT v)) (ConT tyName) params
|
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 []]]
|
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
|
addErrTag :: String -> Exp -> Exp
|
||||||
@ -111,13 +116,9 @@ addErrTag tag exp =
|
|||||||
|
|
||||||
deriveFromNoun :: Name -> Q [Dec]
|
deriveFromNoun :: Name -> Q [Dec]
|
||||||
deriveFromNoun tyName = do
|
deriveFromNoun tyName = do
|
||||||
(params, shape) <- typeShape tyName
|
(params, _) <- typeShape tyName
|
||||||
|
|
||||||
let exp = case shape of Vod -> vodFromNoun
|
|
||||||
Tup con -> tupFromNoun con
|
|
||||||
-- Enu cons -> enumFromAtom cons
|
|
||||||
Sum atoms cells -> sumFromNoun atoms cells
|
|
||||||
|
|
||||||
|
exp <- deriveFromNounFunc tyName
|
||||||
params <- pure $ zip ['a' ..] params <&> \(n,_) -> mkName (singleton n)
|
params <- pure $ zip ['a' ..] params <&> \(n,_) -> mkName (singleton n)
|
||||||
|
|
||||||
let ty = foldl' (\acc v -> AppT acc (VarT v)) (ConT tyName) params
|
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 []]]
|
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 :: [(String, Name)] -> [(String, ConInfo)] -> Exp
|
||||||
sumFromNoun [] cl = taggedFromNoun cl
|
sumFromNoun [] cl = taggedFromNoun cl
|
||||||
sumFromNoun at [] = enumFromAtom at
|
sumFromNoun at [] = enumFromAtom at
|
||||||
|
Loading…
Reference in New Issue
Block a user