From cd3233549ae1b3b83c56c7cc7962e1008ef89786 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 17 Aug 2018 15:17:14 -0700 Subject: [PATCH] WIP, language translation as an additional step in pipeline --- src/Data/Reprinting/Splice.hs | 19 +++- src/Data/Reprinting/Token.hs | 8 +- src/Language/JSON/Translate.hs | 51 +++++++--- src/Reprinting/Pipeline.hs | 17 ++-- src/Reprinting/Translate.hs | 83 +++++++-------- src/Reprinting/Typeset.hs | 3 +- src/Semantic/Util.hs | 102 ++++++++++--------- test/fixtures/javascript/reprinting/map.json | 3 +- 8 files changed, 156 insertions(+), 130 deletions(-) diff --git a/src/Data/Reprinting/Splice.hs b/src/Data/Reprinting/Splice.hs index 88a8f2618..01934fb85 100644 --- a/src/Data/Reprinting/Splice.hs +++ b/src/Data/Reprinting/Splice.hs @@ -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 diff --git a/src/Data/Reprinting/Token.hs b/src/Data/Reprinting/Token.hs index 6eb344464..ba521af61 100644 --- a/src/Data/Reprinting/Token.hs +++ b/src/Data/Reprinting/Token.hs @@ -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. diff --git a/src/Language/JSON/Translate.hs b/src/Language/JSON/Translate.hs index d91632b9b..74d15d79d 100644 --- a/src/Language/JSON/Translate.hs +++ b/src/Language/JSON/Translate.hs @@ -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" diff --git a/src/Reprinting/Pipeline.hs b/src/Reprinting/Pipeline.hs index f7b8ff4fe..a36e8d730 100644 --- a/src/Reprinting/Pipeline.hs +++ b/src/Reprinting/Pipeline.hs @@ -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 diff --git a/src/Reprinting/Translate.hs b/src/Reprinting/Translate.hs index d5c78bb38..a6376c266 100644 --- a/src/Reprinting/Translate.hs +++ b/src/Reprinting/Translate.hs @@ -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 :) diff --git a/src/Reprinting/Typeset.hs b/src/Reprinting/Typeset.hs index 383177212..72b328844 100644 --- a/src/Reprinting/Typeset.hs +++ b/src/Reprinting/Typeset.hs @@ -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) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 48190f09f..574943d0e 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -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 diff --git a/test/fixtures/javascript/reprinting/map.json b/test/fixtures/javascript/reprinting/map.json index 49b67ce4c..e948665c6 100644 --- a/test/fixtures/javascript/reprinting/map.json +++ b/test/fixtures/javascript/reprinting/map.json @@ -1,4 +1,5 @@ { "foo": 100, - "bar": [1, 2, 3] + "bar": [1, 2, 3], + "baz": true }