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

king: better cost center tagging in from/toNoun TH

Browse Source
This commit is contained in:
pilfer-pandex 2021-08-30 19:55:44 -04:00
parent 11d18a7026
commit 51373a0976
2 changed files with 11 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
pkg/hs/stack.yaml
View File

@ -2,7 +2,6 @@ resolver: lts-16.15
packages: packages:
- natpmp-static - natpmp-static
- proto
- racquire - racquire
- terminal-progress-bar - terminal-progress-bar
- urbit-atom - urbit-atom

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

@ -116,6 +116,12 @@ addErrTag tag exp =
nam = LamE [VarP $ mkName "x"] $ AppE (AppE (VarE 'named) str) nam = LamE [VarP $ mkName "x"] $ AppE (AppE (VarE 'named) str)
$ VarE (mkName "x") $ VarE (mkName "x")
addCostCenter :: String -> Exp -> Exp
addCostCenter tag exp =
LetE [ValD (VarP nom) (NormalB exp) []] (VarE nom)
where
nom = mkName $ "scc_" ++ tag
deriveFromNoun :: Name -> Q [Dec] deriveFromNoun :: Name -> Q [Dec]
deriveFromNoun tyName = do deriveFromNoun tyName = do
(params, shape) <- typeShape tyName (params, shape) <- typeShape tyName
@ -130,7 +136,8 @@ deriveFromNoun tyName = do
let ty = foldl' (\acc v -> AppT acc (VarT v)) (ConT tyName) params let ty = foldl' (\acc v -> AppT acc (VarT v)) (ConT tyName) params
let overlap = Nothing let overlap = Nothing
body = NormalB (addErrTag (nameStr tyName) exp) body = NormalB (addCostCenter nom $ addErrTag nom exp)
nom = nameStr tyName
ctx = params <&> \t -> AppT (ConT ''FromNoun) (VarT t) ctx = params <&> \t -> AppT (ConT ''FromNoun) (VarT t)
inst = AppT (ConT ''FromNoun) ty inst = AppT (ConT ''FromNoun) ty
@ -211,12 +218,13 @@ taggedFromNoun cons = LamE [VarP n] (DoE [getHead, getTag, examine])
matches = mkMatch <$> cons matches = mkMatch <$> cons
mkMatch = \(tag, (n, tys)) -> mkMatch = \(tag, (n, tys)) ->
let body = AppE (addErrTag ('%':tag) (tupFromNoun (n, tys))) let body = addCostCenter tag
$ AppE (addErrTag ('%':tag) (tupFromNoun (n, tys)))
(VarE t) (VarE t)
in Match (LitP $ StringL tag) (NormalB body) [] in Match (LitP $ StringL tag) (NormalB body) []
fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) [] fallback = Match WildP (NormalB $ AppE (VarE 'fail) matchFail) []
matchFail = unexpectedTag (fst <$> cons) (VarE c) matchFail = addCostCenter "matchFail" $ unexpectedTag (fst <$> cons) (VarE c)
tagFail = LitE $ StringL (intercalate " " (('%':) <$> (fst <$> cons))) tagFail = LitE $ StringL (intercalate " " (('%':) <$> (fst <$> cons)))