WIP, language translation as an additional step in pipeline

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
+copy :: Text -> Seq Splice
-splice = singleton . Insert
+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

src/Data/Reprinting/Token.hs

@@ -10,11 +10,9 @@ import Data.Text (Text)
 import Data.Source (Source)
 
 
--- language agnostic -> language specific -> formatting whitespace
+-- language agnostic -> CToken -> SToken -> language specific -> formatting whitespace
--- tokenize          -> translate         -> typeset
+-- tokenize          -> CToken -> SToken -> translate         -> typeset
--- Seq Token         -> Seq Splice        -> Doc
+-- 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.

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
+translatingJSON :: Rule eff Splice (Seq Splice)
-  translation _ _ content context = case (content, context) of
+translatingJSON = fromFunction "translatingJSON" step where
-    (Fragment f, _) -> Right $ splice f
+  step (Insert el@(Truth True) c _) = splice el c "True"
+  step x = pure x
 
-    (Truth True, _)  -> Right $ splice "true"
+beautifyingJSON :: JSONTypeSetting -> Rule eff Splice (Seq Splice)
-    (Truth False, _) -> Right $ splice "false"
+beautifyingJSON _ = fromFunction "beautifyingJSON" step where
-    (Nullity, _)     -> Right $ splice "null"
+  step s@(Insert Open (Just List) _) = s <| directive (HardWrap 2 Space)
 
-    (Open, List:_)        -> Right $ splice "["
+minimizingJSON :: Rule eff Token (Seq Splice)
-    (Open, Associative:_) -> Right $ splice "{"
+minimizingJSON = undefined
 
-    (Close, List:_)        -> Right $ splice "]"
+-- instance Translation 'JSON JSONTypeSetting where
-    (Close, Associative:_) -> Right $ splice "}"
+--   translation _ JSONTypeSetting{..} content context = undefined -- case (content, context) of
-
+    -- (Fragment f, _) -> Right $ splice f
-    (Separator, List:_)        -> Right $ splice ","
+    --
-    (Separator, Associative:_) -> Right $ splice ","
+    -- (Truth True, _)  -> Right $ splice "true"
-    (Separator, Pair:_)        -> Right $ splice ":"
+    -- (Truth False, _) -> Right $ splice "false"
-
+    -- (Nullity, _)     -> Right $ splice "null"
-    _ -> Left "JSON translate failed, unknown context"
+    --
+    -- (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"

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

src/Reprinting/Translate.hs

@@ -2,79 +2,68 @@
              ScopedTypeVariables, TupleSections, TypeFamilyDependencies, TypeApplications, TypeOperators #-}
 
 module Reprinting.Translate
-  ( Translate (..)
+  -- ( Translate
-  , Translation (..)
+  -- , Translation (..)
-  , TranslationException (..)
+  ( 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
+type TranslatingEffs = '[State [Context], Exc TranslationException]
-  translation :: Translate a -> Translate a
 
-translating :: forall lang a effs .
+-- type Translate a = a -> Element -> [Context] -> Either String (Seq Splice)
-  ( Translation lang a
-  , Member (State [Context]) effs
-  , Member (Exc TranslationException) effs
-  ) =>
-  a -> Rule effs Token (Seq Splice)
-translating config = fromEffect "translating" (step @lang config)
 
-step :: forall lang a effs .
+-- class Translation (lang :: Language) a where
-  ( Translation lang a
+--   translation :: Translate a -> Translate 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
 
-  where
+translating :: ( Member (State [Context]) effs , Member (Exc TranslationException) effs )
-    defaultTranslation :: Translate a
+  => Rule effs Token (Seq Splice)
-    defaultTranslation _ content context = case (content, context) of
+translating = fromEffect "translating" step where
-      (Fragment f, _) -> Right $ splice f
+  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"
+  translate el c = let emit = pure . splice el c in case (el, c) of
-      (Truth False, _) -> Right $ splice "false"
+    (Fragment f, _) -> emit f
-      (Nullity, _)     -> Right $ splice "null"
 
-      (Open, List:_)        -> Right $ splice "["
+    (Truth True, _)  -> emit "true"
-      (Open, Associative:_) -> Right $ splice "{"
+    (Truth False, _) -> emit "false"
+    (Nullity, _)     -> emit "null"
 
-      (Close, List:_)        -> Right $ splice "]"
+    (Open, Just List)        -> emit "["
-      (Close, Associative:_) -> Right $ splice "}"
+    (Open, Just Associative) -> emit "{"
 
-      (Separator, List:_)        -> Right $ splice ","
+    (Close, Just List)        -> emit "]"
-      (Separator, Associative:_) -> Right $ splice ","
+    (Close, Just Associative) -> emit "}"
-      (Separator, Pair:_)        -> Right $ splice ":"
 
-      _ -> 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 :)

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)

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
+-- kvMatcher :: forall fs ann term
-           . ( Literal.KeyValue :< fs
+--            . ( Literal.KeyValue :< fs
-             , Literal.Array :< fs
+--              , Literal.Array :< fs
-             , Literal.TextElement :< fs
+--              , Literal.TextElement :< fs
-             , term ~ Term (Sum fs) ann)
+--              , term ~ Term (Sum fs) ann)
-          => Text -> Matcher term (Literal.KeyValue term)
+--           => Text -> Matcher term (Literal.KeyValue term)
-kvMatcher name = matchM kv target <* matchKey where
+-- kvMatcher name = matchM kv target <* matchKey where
-  matchKey
+--   matchKey
-    = match Literal.key $
+--     = match Literal.key $
-        match Literal.textElementContent $
+--         match Literal.textElementContent $
-          ensure (== name)
+--           ensure (== name)
-  kv :: term -> Maybe (Literal.KeyValue term)
+--   kv :: term -> Maybe (Literal.KeyValue term)
-  kv = projectTerm
+--   kv = projectTerm
-
+--
-findKV :: ( Apply Functor syntax
+-- findKV :: ( Apply Functor syntax
-           , Apply Foldable syntax
+--            , Apply Foldable syntax
-           , Literal.KeyValue :< syntax
+--            , Literal.KeyValue :< syntax
-           , Literal.Array :< syntax
+--            , Literal.Array :< syntax
-           , Literal.TextElement :< syntax
+--            , Literal.TextElement :< syntax
-           , term ~ Term (Sum syntax) ann
+--            , term ~ Term (Sum syntax) ann
-           )
+--            )
-        => Text -> Rule effs term (Either term (term, Literal.KeyValue term))
+--         => Text -> Rule effs term (Either term (term, Literal.KeyValue term))
-findKV name = fromMatcher "findKV" (kvMatcher name)
+-- findKV name = fromMatcher "findKV" (kvMatcher name)
-
+--
-changeKV :: forall effs syntax ann fields term
+-- changeKV :: forall effs syntax ann fields term
-          . ( Apply Functor syntax
+--           . ( Apply Functor syntax
-            , Apply Foldable syntax
+--             , Apply Foldable syntax
-            , Literal.KeyValue :< syntax
+--             , Literal.KeyValue :< syntax
-            , Literal.Array :< syntax
+--             , Literal.Array :< syntax
-            , Literal.Float :< syntax
+--             , Literal.Float :< syntax
-            , Literal.TextElement :< syntax
+--             , Literal.TextElement :< syntax
-            , ann ~ Record (History ': fields)
+--             , ann ~ Record (History ': fields)
-            , term ~ Term (Sum syntax) ann
+--             , term ~ Term (Sum syntax) ann
-            )
+--             )
-         => Rule effs (Either term (term, Literal.KeyValue term)) term
+--          => Rule effs (Either term (term, Literal.KeyValue term)) term
-changeKV = fromFunction "changeKV" $ either id injKV
+-- changeKV = fromFunction "changeKV" $ either id injKV
-  where injKV :: (term, Literal.KeyValue term) -> term
+--   where injKV :: (term, Literal.KeyValue term) -> term
-        injKV (term, Literal.KeyValue k v) = case projectTerm v of
+--         injKV (term, Literal.KeyValue k v) = case projectTerm v of
-          Just (Literal.Array elems) -> remark Refactored (termIn ann (inject (Literal.KeyValue k (newArray elems))))
+--           Just (Literal.Array elems) -> remark Refactored (termIn ann (inject (Literal.KeyValue k (newArray elems))))
-          _ -> term
+--           _ -> term
-          where newArray xs = termIn ann (inject (Literal.Array (xs <> [float])))
+--           where newArray xs = termIn ann (inject (Literal.Array (xs <> [float])))
-                float = termIn ann (inject (Literal.Float "4"))
+--                 float = termIn ann (inject (Literal.Float "4"))
-                ann = termAnnotation term
+--                 ann = termAnnotation term
-
+--
-testChangeKV = do
+-- testChangeKV = do
-  (src, tree) <- testJSONFile
+--   (src, tree) <- testJSONFile
-  tagged <- runM $ cata (toAlgebra (changeKV . findKV "\"bar\"")) (mark Unmodified tree)
+--   tagged <- runM $ cata (toAlgebra (changeKV . findKV "\"bar\"")) (mark Unmodified tree)
-  pure $ runReprinter @'Language.JSON prettyJSON src tagged
+--   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

test/fixtures/javascript/reprinting/map.json

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