github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 01:47:01 +03:00
Code Issues Projects Releases Wiki Activity

WIP, language translation as an additional step in pipeline

Browse Source
This commit is contained in:
Timothy Clem 2018-08-17 15:17:14 -07:00
parent d9218cfd1f
commit cd3233549a
8 changed files with 156 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
src/Data/Reprinting/Splice.hs
View File

@ -2,17 +2,26 @@ module Data.Reprinting.Splice where
import Data.Sequence (singleton)
import Data.String
import Prologue
import Prologue hiding (Element)
import Data.Sequence
import Data.Reprinting.Token
-- | The simplest possible representation of concrete syntax: either
-- it's a run of literal text or information about whitespace.
data Splice
= Insert Text
= Insert Element (Maybe Context) Text
| Original Text
| Directive Layout
deriving (Eq, Show)
splice :: Text -> Seq Splice
splice = singleton . Insert
copy :: Text -> Seq Splice
copy = singleton . Original
splice :: Element -> Maybe Context -> Text -> Seq Splice
splice el c = singleton . Insert el c
directive :: Layout -> Seq Splice
directive = singleton . Directive
-- | Indentation/spacing directives.
data Layout
@ -25,4 +34,4 @@ data Layout
data Indent = Space | Tab deriving (Eq, Show)
instance IsString Splice where fromString = Insert . fromString
-- instance IsString Splice where fromString = Insert . fromString

8
src/Data/Reprinting/Token.hs
View File

@ -10,11 +10,9 @@ import Data.Text (Text)
import Data.Source (Source)
-- language agnostic -> language specific -> formatting whitespace
-- tokenize -> translate -> typeset
-- Seq Token -> Seq Splice -> Doc
-- language agnostic -> CToken -> SToken -> language specific -> formatting whitespace
-- tokenize -> CToken -> SToken -> translate -> typeset
-- Seq Token -> CToken -> SToken -> Seq Splice -> Doc
-- | 'Token' encapsulates 'Element' and 'Control' tokens, as well as sliced
-- portions of the original 'Source' for a given AST.

51
src/Language/JSON/Translate.hs
View File

@ -1,8 +1,12 @@
module Language.JSON.Translate where
import Control.Rule
import Data.Language
import Data.Reprinting.Token
import Data.Reprinting.Splice
import Reprinting.Translate
import Data.Sequence hiding (fromFunction)
import Data.Machine
data JSONTypeSetting = JSONTypeSetting { jsonPrettyPrint :: Bool }
deriving (Eq, Show)
@ -10,22 +14,37 @@ data JSONTypeSetting = JSONTypeSetting { jsonPrettyPrint :: Bool }
prettyJSON :: JSONTypeSetting
prettyJSON = JSONTypeSetting True
instance Translation 'JSON JSONTypeSetting where
translation _ _ content context = case (content, context) of
(Fragment f, _) -> Right $ splice f
translatingJSON :: Rule eff Splice (Seq Splice)
translatingJSON = fromFunction "translatingJSON" step where
step (Insert el@(Truth True) c _) = splice el c "True"
step x = pure x
(Truth True, _) -> Right $ splice "true"
(Truth False, _) -> Right $ splice "false"
(Nullity, _) -> Right $ splice "null"
beautifyingJSON :: JSONTypeSetting -> Rule eff Splice (Seq Splice)
beautifyingJSON _ = fromFunction "beautifyingJSON" step where
step s@(Insert Open (Just List) _) = s <| directive (HardWrap 2 Space)
(Open, List:_) -> Right $ splice "["
(Open, Associative:_) -> Right $ splice "{"
minimizingJSON :: Rule eff Token (Seq Splice)
minimizingJSON = undefined
(Close, List:_) -> Right $ splice "]"
(Close, Associative:_) -> Right $ splice "}"
(Separator, List:_) -> Right $ splice ","
(Separator, Associative:_) -> Right $ splice ","
(Separator, Pair:_) -> Right $ splice ":"
_ -> Left "JSON translate failed, unknown context"
-- instance Translation 'JSON JSONTypeSetting where
-- translation _ JSONTypeSetting{..} content context = undefined -- case (content, context) of
-- (Fragment f, _) -> Right $ splice f
--
-- (Truth True, _) -> Right $ splice "true"
-- (Truth False, _) -> Right $ splice "false"
-- (Nullity, _) -> Right $ splice "null"
--
-- (Open, List:_) -> Right $ splice "["
-- (Open, Associative:_) -> Right $ splice "{" <>
-- if jsonPrettyPrint then directive (HardWrap 2 Space) else mempty
--
-- (Close, List:_) -> Right $ splice "]"
-- (Close, Associative:_) ->
-- let prefix = if jsonPrettyPrint then directive (HardWrap 0 Space) else mempty
-- in Right $ prefix <> splice "}"
--
-- (Separator, List:_) -> Right $ splice ","
-- (Separator, Associative:_) -> Right $ splice ","
-- (Separator, Pair:_) -> Right $ splice ":"
--
-- _ -> Left "JSON translate failed, unknown context"

17
src/Reprinting/Pipeline.hs
View File

@ -77,6 +77,7 @@ import Control.Rule
import Data.Machine hiding (Source)
import Data.Machine.Runner
import Data.Record
import Data.Sequence
import Data.Reprinting.Token
import qualified Data.Source as Source
import Data.Term
@ -85,28 +86,32 @@ import Data.Text.Prettyprint.Doc.Render.Text
import Reprinting.Tokenize
import Reprinting.Translate
import Reprinting.Typeset
import Control.Arrow
-- | Given the language of the provided 'Term' and the original 'Source' from
-- which the provided 'Term' was passed, run the reprinting pipeline.
runReprinter :: forall lang opts fields a .
runReprinter ::
( Show (Record fields)
, Tokenize a
, HasField fields History
, Translation lang opts
-- , Member (State [Context]) effs
-- , Member (Exc TranslationException) effs
)
=> opts
-> Source.Source
=> Source.Source
-> Rule TranslatingEffs Splice (Seq Splice)
-> Term a (Record fields)
-> Either TranslationException Source.Source
runReprinter opts s tree
runReprinter s additionalRules tree
= fmap go
. Effect.run
. Exc.runError
. fmap snd
. runState (mempty :: [Context])
. foldT $ source (tokenizing s tree)
~> machine (translating @lang opts)
~> machine translating
~> flattened
~> machine additionalRules
~> flattened
~> machine typesetting
where go = Source.fromText . renderStrict . layoutPretty defaultLayoutOptions

83
src/Reprinting/Translate.hs
View File

@ -2,79 +2,68 @@
ScopedTypeVariables, TupleSections, TypeFamilyDependencies, TypeApplications, TypeOperators #-}
module Reprinting.Translate
( Translate (..)
, Translation (..)
, TranslationException (..)
-- ( Translate
-- , Translation (..)
( TranslationException (..)
, TranslatingEffs
, Splice (..)
, Layout (..)
, Indent (..)
, translating
, splice
) where
import Prologue hiding (Element)
import Control.Rule
import Control.Monad.Effect
import Control.Monad.Effect.Exception (Exc)
import qualified Control.Monad.Effect.Exception as Exc
import Control.Monad.Effect.State
import Control.Monad.Effect.Writer
import Control.Rule
import Data.Language
import Data.Reprinting.Splice
import Data.Reprinting.Token
import Data.Sequence (singleton)
import qualified Data.Source as Source
type Translate a = a -> Element -> [Context] -> Either String (Seq Splice)
class Translation (lang :: Language) a where
translation :: Translate a -> Translate a
type TranslatingEffs = '[State [Context], Exc TranslationException]
translating :: forall lang a effs .
( Translation lang a
, Member (State [Context]) effs
, Member (Exc TranslationException) effs
) =>
a -> Rule effs Token (Seq Splice)
translating config = fromEffect "translating" (step @lang config)
-- type Translate a = a -> Element -> [Context] -> Either String (Seq Splice)
step :: forall lang a effs .
( Translation lang a
, Member (State [Context]) effs
, Member (Exc TranslationException) effs
) =>
a -> Token -> Eff effs (Seq Splice)
step config t = case t of
Chunk source -> pure $ splice (Source.toText source)
TElement content -> do
context <- get
let eitherSlices = translation @lang defaultTranslation config content context
either (Exc.throwError . Unexpected) pure eitherSlices
TControl ctl -> case ctl of
Log _ -> pure mempty
Enter c -> enterContext c *> pure mempty
Exit c -> exitContext c *> pure mempty
-- class Translation (lang :: Language) a where
-- translation :: Translate a -> Translate a
where
defaultTranslation :: Translate a
defaultTranslation _ content context = case (content, context) of
(Fragment f, _) -> Right $ splice f
translating :: ( Member (State [Context]) effs , Member (Exc TranslationException) effs )
=> Rule effs Token (Seq Splice)
translating = fromEffect "translating" step where
step t = case t of
Chunk source -> pure $ copy (Source.toText source)
TElement el -> get >>= translate el . listToMaybe
TControl ctl -> case ctl of
Log _ -> pure mempty
Enter c -> enterContext c *> pure mempty
Exit c -> exitContext c *> pure mempty
(Truth True, _) -> Right $ splice "true"
(Truth False, _) -> Right $ splice "false"
(Nullity, _) -> Right $ splice "null"
translate el c = let emit = pure . splice el c in case (el, c) of
(Fragment f, _) -> emit f
(Open, List:_) -> Right $ splice "["
(Open, Associative:_) -> Right $ splice "{"
(Truth True, _) -> emit "true"
(Truth False, _) -> emit "false"
(Nullity, _) -> emit "null"
(Close, List:_) -> Right $ splice "]"
(Close, Associative:_) -> Right $ splice "}"
(Open, Just List) -> emit "["
(Open, Just Associative) -> emit "{"
(Separator, List:_) -> Right $ splice ","
(Separator, Associative:_) -> Right $ splice ","
(Separator, Pair:_) -> Right $ splice ":"
(Close, Just List) -> emit "]"
(Close, Just Associative) -> emit "}"
_ -> Left "defaulTranslate failed, unknown context"
(Separator, Just List) -> emit ","
(Separator, Just Associative) -> emit ","
(Separator, Just Pair) -> emit ":"
-- TODO: Maybe put an error token in the stream instead?
_ -> Exc.throwError (Unexpected "don't know how to translate")
enterContext :: (Member (State [Context]) effs) => Context -> Eff effs ()
enterContext c = modify' (c :)

3
src/Reprinting/Typeset.hs
View File

@ -17,7 +17,8 @@ typesetting = fromFunction "typesetting" step
step :: Splice -> Doc a
step (Directive Don't) = mempty
step (Insert t) = pretty t
step (Original t) = pretty t
step (Insert _ _ t) = pretty t
step (Directive SoftWrap) = softline
step (Directive (HardWrap 0 _)) = line
step (Directive (HardWrap i t)) = line <> stimes i (space t)

102
src/Semantic/Util.hs
View File

@ -24,8 +24,10 @@ import qualified Data.Abstract.ModuleTable as ModuleTable
import Data.Abstract.Package
import Data.Abstract.Value.Concrete as Concrete
import Data.Abstract.Value.Type as Type
import qualified Data.ByteString.Char8 as BC
import Data.Blob
import Data.Coerce
import qualified Data.Source as Source
import Data.Graph (topologicalSort)
import Data.History
import qualified Data.Language as Language
@ -296,55 +298,57 @@ testJSONFile = do
-- putStrLn (either show (show . typeset) res)
kvMatcher :: forall fs ann term
. ( Literal.KeyValue :< fs
, Literal.Array :< fs
, Literal.TextElement :< fs
, term ~ Term (Sum fs) ann)
=> Text -> Matcher term (Literal.KeyValue term)
kvMatcher name = matchM kv target <* matchKey where
matchKey
= match Literal.key $
match Literal.textElementContent $
ensure (== name)
kv :: term -> Maybe (Literal.KeyValue term)
kv = projectTerm
findKV :: ( Apply Functor syntax
, Apply Foldable syntax
, Literal.KeyValue :< syntax
, Literal.Array :< syntax
, Literal.TextElement :< syntax
, term ~ Term (Sum syntax) ann
)
=> Text -> Rule effs term (Either term (term, Literal.KeyValue term))
findKV name = fromMatcher "findKV" (kvMatcher name)
changeKV :: forall effs syntax ann fields term
. ( Apply Functor syntax
, Apply Foldable syntax
, Literal.KeyValue :< syntax
, Literal.Array :< syntax
, Literal.Float :< syntax
, Literal.TextElement :< syntax
, ann ~ Record (History ': fields)
, term ~ Term (Sum syntax) ann
)
=> Rule effs (Either term (term, Literal.KeyValue term)) term
changeKV = fromFunction "changeKV" $ 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
testChangeKV = do
(src, tree) <- testJSONFile
tagged <- runM $ cata (toAlgebra (changeKV . findKV "\"bar\"")) (mark Unmodified tree)
pure $ runReprinter @'Language.JSON prettyJSON src tagged
-- kvMatcher :: forall fs ann term
-- . ( Literal.KeyValue :< fs
-- , Literal.Array :< fs
-- , Literal.TextElement :< fs
-- , term ~ Term (Sum fs) ann)
-- => Text -> Matcher term (Literal.KeyValue term)
-- kvMatcher name = matchM kv target <* matchKey where
-- matchKey
-- = match Literal.key $
-- match Literal.textElementContent $
-- ensure (== name)
-- kv :: term -> Maybe (Literal.KeyValue term)
-- kv = projectTerm
--
-- findKV :: ( Apply Functor syntax
-- , Apply Foldable syntax
-- , Literal.KeyValue :< syntax
-- , Literal.Array :< syntax
-- , Literal.TextElement :< syntax
-- , term ~ Term (Sum syntax) ann
-- )
-- => Text -> Rule effs term (Either term (term, Literal.KeyValue term))
-- findKV name = fromMatcher "findKV" (kvMatcher name)
--
-- changeKV :: forall effs syntax ann fields term
-- . ( Apply Functor syntax
-- , Apply Foldable syntax
-- , Literal.KeyValue :< syntax
-- , Literal.Array :< syntax
-- , Literal.Float :< syntax
-- , Literal.TextElement :< syntax
-- , ann ~ Record (History ': fields)
-- , term ~ Term (Sum syntax) ann
-- )
-- => Rule effs (Either term (term, Literal.KeyValue term)) term
-- changeKV = fromFunction "changeKV" $ 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
--
-- testChangeKV = do
-- (src, tree) <- testJSONFile
-- tagged <- runM $ cata (toAlgebra (changeKV . findKV "\"bar\"")) (mark Unmodified tree)
-- pure $ runReprinter @'Language.JSON prettyJSON src tagged
testPipeline = do
(src, tree) <- testJSONFile
pure $ runReprinter @'Language.JSON prettyJSON src (mark Refactored tree)
printToTerm $ runReprinter src translatingJSON (mark Refactored tree)
printToTerm res = either (putStrLn . show) (BC.putStr . Source.sourceBytes) res

3
test/fixtures/javascript/reprinting/map.json vendored
View File

@ -1,4 +1,5 @@
{
"foo": 100,
"bar": [1, 2, 3]
"bar": [1, 2, 3],
"baz": true
}