github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-19 21:01:35 +03:00
Code Issues Projects Releases Wiki Activity

last few fixes. now to investigate bugs

Browse Source
This commit is contained in:
Patrick Thomson 2018-09-19 12:58:18 -04:00
parent 7f81565efa
commit ba246ca805
2 changed files with 20 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Data/Term.hs
View File

@ -6,6 +6,7 @@ module Data.Term
, termOut
, injectTerm
, projectTerm
, guardTerm
, TermF(..)
, termSize
, hoistTerm
@ -37,6 +38,11 @@ termOut = termFOut . unTerm
projectTerm :: forall f syntax ann . (f :< syntax) => Term (Sum syntax) ann -> Maybe (f (Term (Sum syntax) ann))
projectTerm = Sum.project . termOut
guardTerm :: forall m f syntax ann . (f :< syntax, Alternative m)
=> Term (Sum syntax) ann
-> m (f (Term (Sum syntax) ann))
guardTerm = Sum.projectGuard . termOut
data TermF syntax ann recur = In { termFAnnotation :: ann, termFOut :: syntax recur }
deriving (Eq, Ord, Foldable, Functor, Show, Traversable)

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

@ -1,5 +1,5 @@
{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators #-}
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists #-}
{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-export-lists -Wno-incomplete-uni-patterns #-}
module Semantic.Util.Rewriting where
import Prelude hiding (id, readFile, (.))
@ -9,24 +9,19 @@ import Control.Category
import qualified Data.ByteString.Char8 as BC
import Text.Show.Pretty (pPrint)
import Control.Abstract
import Control.Abstract.Matching
import Control.Rewriting hiding (fromMatcher, target)
import Data.Blob
import Data.History
import qualified Data.Language as Language
import Data.Machine
import Data.Machine.Runner
import Data.Project hiding (readFile)
import Data.Record
import qualified Data.Source as Source
import qualified Data.Sum as Sum
import qualified Data.Syntax.Literal as Literal
import Data.Term
import Language.JSON.PrettyPrint
import Language.Python.PrettyPrint
import Language.Ruby.PrettyPrint
import Matching.Core
import Parsing.Parser
import Reprinting.Pipeline
import Semantic.IO as IO
@ -133,14 +128,6 @@ testOverwriteFloats = do
pPrint tagged
printToTerm $ runReprinter src defaultJSONPipeline tagged
findKV ::
( Literal.KeyValue :< syntax
, Literal.TextElement :< syntax
, term ~ Term (Sum syntax) ann
) =>
Text -> ProcessT (Eff effs) term (Either term (term, Literal.KeyValue term))
findKV name = fromMatcher (kvMatcher name)
kvMatcher :: forall fs ann term .
( Literal.KeyValue :< fs
, Literal.TextElement :< fs
@ -153,42 +140,23 @@ kvMatcher name = matchM projectTerm target <* matchKey where
match Literal.textElementContent $
ensure (== name)
changeKV :: forall effs syntax ann fields term .
( Apply Functor syntax
, Literal.KeyValue :< syntax
, Literal.Array :< syntax
, Literal.Float :< syntax
, ann ~ Record (History ': fields)
, term ~ Term (Sum syntax) ann
) =>
ProcessT (Eff effs) (Either term (term, Literal.KeyValue term)) term
changeKV = auto $ either id injKV
where
injKV :: (term, Literal.KeyValue term) -> term
injKV (term, Literal.KeyValue k v) = case projectTerm v of
Just (Literal.Array elems) -> remark Refactored (termIn ann (inject (Literal.KeyValue k (newArray elems))))
_ -> term
where newArray xs = termIn ann (inject (Literal.Array (xs <> [float])))
float = termIn ann (inject (Literal.Float "4"))
ann = termAnnotation term
changeKV :: ( Apply Functor syntax
, Literal.Array :< syntax
, Literal.Float :< syntax
, term ~ Term (Sum syntax) (Record (History : fields))
)
=> Rewrite (env, term) (Literal.KeyValue term)
changeKV = do
(Literal.KeyValue k v) <- id
(Literal.Array vals) <- guardTerm v
let float = remark Refactored (injectTerm (annotation v) (Literal.Float "4"))
let newArr = remark Refactored (injectTerm (annotation v) (Literal.Array (float:vals)))
pure (Literal.KeyValue k newArr)
testChangeKV = do
(src, tree) <- testJSONFile
tagged <- runM $ cata (toAlgebra (findKV "\"bar\"" ~> changeKV)) (mark Unmodified tree)
let (Right tagged) = rewrite (somewhere' changeKV) () (mark Unmodified tree)
printToTerm $ runReprinter src defaultJSONPipeline tagged
-- Temporary, until new KURE system lands.
fromMatcher :: Matcher from to -> ProcessT (Eff effs) from (Either from (from, to))
fromMatcher m = auto go where go x = maybe (Left x) (\y -> Right (x, y)) (stepMatcher x m)
-- Turn a 'ProccessT' into an FAlgebra.
toAlgebra :: (Traversable (Base t), Corecursive t)
=> ProcessT (Eff effs) t t
-> FAlgebra (Base t) (Eff effs t)
toAlgebra m t = do
inner <- sequenceA t
res <- runT1 (source (Just (embed inner)) ~> m)
pure (fromMaybe (embed inner) res)
parseFile :: Parser term -> FilePath -> IO term
parseFile parser = runTask . (parse parser <=< readBlob . file)