github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-20 05:11:44 +03:00
Code Issues Projects Releases Wiki Activity

port addKVPair

Browse Source
This commit is contained in:
Patrick Thomson 2018-09-19 12:06:09 -04:00
parent 9a1f6e9835
commit 0cc5fc5e19
1 changed files with 13 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
src/Semantic/Util/Rewriting.hs
View File

@ -106,32 +106,22 @@ increaseNumbers = do
(Literal.Float c) <- id (Literal.Float c) <- id
pure (Literal.Float (c <> "0")) pure (Literal.Float (c <> "0"))
addKVPair :: forall effs syntax ann fields term . addKVPair :: ( Literal.TextElement :< syn
( Apply Functor syntax , Literal.KeyValue :< syn
, Literal.Hash :< syntax , Literal.Array :< syn
, Literal.Array :< syntax , Apply Functor syn
, Literal.TextElement :< syntax , term ~ Term (Sum syn) (Record (History : fields))
, Literal.KeyValue :< syntax ) => Rewrite (env, term) (Literal.Hash term)
, ann ~ Record (History ': fields) addKVPair = do
, term ~ Term (Sum syntax) ann Literal.Hash els <- id
) => k <- modified $ Literal.TextElement "\"added\""
ProcessT (Eff effs) (Either term (term, Literal.Hash term)) term v <- modified $ Literal.Array []
addKVPair = repeatedly $ do pair <- modified $ (Literal.KeyValue k v)
t <- await pure (Literal.Hash (pair : els))
Data.Machine.yield (either id injKVPair t)
where
injKVPair :: (term, Literal.Hash term) -> term
injKVPair (origTerm, Literal.Hash xs) =
remark Refactored (injectTerm ann (Literal.Hash (xs <> [newItem])))
where
newItem = termIn ann (inject (Literal.KeyValue k v))
k = termIn ann (inject (Literal.TextElement "\"added\""))
v = termIn ann (inject (Literal.Array []))
ann = termAnnotation origTerm
testAddKVPair = do testAddKVPair = do
(src, tree) <- testJSONFile (src, tree) <- testJSONFile
tagged <- runM $ cata (toAlgebra (fromMatcher matchHash ~> addKVPair)) (mark Unmodified tree) let (Right tagged) = rewrite (somewhere addKVPair markRefactored) () (mark Unmodified tree)
printToTerm $ runReprinter src defaultJSONPipeline tagged printToTerm $ runReprinter src defaultJSONPipeline tagged
overwriteFloats :: forall effs syntax ann fields term . overwriteFloats :: forall effs syntax ann fields term .