mirror of
https://github.com/urbit/shrub.git
synced 2024-12-23 19:05:48 +03:00
king: better cost center tagging in from/toNoun TH
This commit is contained in:
parent
11d18a7026
commit
51373a0976
pkg/hs
@ -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
|
||||||
|
@ -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)))
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user