working reprinting tests

src/Data/Syntax.hs

@@ -18,6 +18,7 @@ import GHC.TypeLits
 import Diffing.Algorithm hiding (Empty)
 import Prelude
 import Prologue
+import Rendering.Reprinter hiding (Context, Element)
 import qualified Assigning.Assignment as Assignment
 import qualified Data.Error as Error
 import Proto3.Suite.Class
@@ -207,6 +208,9 @@ instance Show1 Error where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Error
 
+instance Reprintable Error where
+  whenGenerated _ = pure ()
+
 instance Named String where
   nameOf _ = "string"
 

src/Data/Syntax/Literal.hs

@@ -1,9 +1,10 @@
-{-# LANGUAGE DeriveAnyClass, ViewPatterns, ScopedTypeVariables, DuplicateRecordFields #-}
+{-# LANGUAGE DeriveAnyClass, DuplicateRecordFields, ScopedTypeVariables, ViewPatterns #-}
 {-# OPTIONS_GHC -Wno-missing-export-lists #-}
 module Data.Syntax.Literal where
 
 import           Data.Abstract.Evaluatable
 import           Data.JSON.Fields
+import           Data.List (intersperse)
 import           Data.Scientific.Exts
 import qualified Data.Text as T
 import           Diffing.Algorithm
@@ -11,6 +12,7 @@ import           Numeric.Exts
 import           Prelude hiding (Float, null)
 import           Prologue hiding (Set, hash, null)
 import           Proto3.Suite.Class
+import           Rendering.Reprinter
 import           Text.Read (readMaybe)
 
 -- Boolean
@@ -31,6 +33,9 @@ instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Boolean where
   eval (Boolean x) = rvalBox (boolean x)
 
+instance Reprintable Boolean where
+  whenGenerated = yield . Truth . booleanContent
+
 -- Numeric
 
 -- | A literal integer of unspecified width. No particular base is implied.
@@ -59,6 +64,9 @@ instance Evaluatable Data.Syntax.Literal.Float where
   eval (Float s) =
     rvalBox =<< (float <$> either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s))
 
+instance Reprintable Data.Syntax.Literal.Float where
+  whenGenerated = yield . Fragment . floatContent
+
 -- Rational literals e.g. `2/3r`
 newtype Rational a = Rational { value :: Text }
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
@@ -130,6 +138,9 @@ instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TextElement where
   eval (TextElement x) = rvalBox (string x)
 
+instance Reprintable TextElement where
+  whenGenerated = yield . Fragment . textElementContent
+
 data Null a = Null
   deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
 
@@ -139,6 +150,9 @@ instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Null where eval _ = rvalBox null
 
+instance Reprintable Null where
+  whenGenerated _ = yield Nullity
+
 newtype Symbol a = Symbol { symbolElements :: [a] }
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
 
@@ -183,6 +197,17 @@ instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Array where
   eval (Array a) = rvalBox =<< array =<< traverse subtermAddress a
 
+instance Reprintable Array where
+  whenModified t = do
+    control (Enter List)
+    sequence_ t
+    control (Exit List)
+
+  whenGenerated t = do
+    control (Enter List)
+    sequence_ (intersperse (yield Separator) (toList t))
+    control (Exit List)
+
 newtype Hash a = Hash { hashElements :: [a] }
   deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
 
@@ -193,6 +218,14 @@ instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Hash where
   eval t = rvalBox =<< (hash <$> traverse (subtermValue >=> asPair) (hashElements t))
 
+instance Reprintable Hash where
+  whenGenerated t = do
+    control (Enter Associative)
+    sequence_ t
+    control (Exit Associative)
+
+  whenModified = whenGenerated
+
 data KeyValue a = KeyValue { key :: !a, value :: !a }
   deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Diffable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
 
@@ -204,6 +237,19 @@ instance Evaluatable KeyValue where
   eval (fmap subtermValue -> KeyValue{..}) =
     rvalBox =<< (kvPair <$> key <*> value)
 
+instance Reprintable KeyValue where
+  whenGenerated (KeyValue k v) = do
+    control (Enter Pair)
+    k
+    yield Separator
+    v
+    control (Exit Pair)
+
+  whenModified t = do
+    control (Enter Pair)
+    sequence_ t
+    control (Exit Pair)
+
 newtype Tuple a = Tuple { tupleContents :: [a] }
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1)
 

src/Rendering/Reprinter.hs

@@ -6,6 +6,12 @@ module Rendering.Reprinter
   , mark
   -- * The Reprinter monad
   , Reprinter
+  , yield
+  , control
+  -- * Token types
+  , Element (..)
+  , Control (..)
+  , Context (..)
   -- * Reprintable interface
   , Reprintable (..)
   -- * Invocation/esults
@@ -13,19 +19,21 @@ module Rendering.Reprinter
   , Token (..)
   ) where
 
+import Prelude hiding (fail)
 import Prologue hiding (Element)
 
-import Control.Monad.Effect
-import Control.Monad.Effect.State (get, put, runState)
-import Control.Monad.Trans (lift)
-import qualified Data.Machine as Machine
-import Data.Machine hiding (yield, run, source, Source)
+import           Control.Monad.Effect
+import           Control.Monad.Effect.Fail
+import           Control.Monad.Effect.State (get, put, runState)
+import           Control.Monad.Effect.Writer
+import Debug.Trace (traceM)
+import Data.Sequence (singleton)
 
-import           Data.Algebra
-import           Data.Range
-import           Data.Record
+import Data.Algebra
+import Data.Range
+import Data.Record
 import Data.Source
-import           Data.Term
+import Data.Term
 
 -- | 'History' values, when attached to a given 'Term', describe the ways in which
 -- that term was refactored, if any.
@@ -44,13 +52,12 @@ historyRange (Refactored r) = Just r
 historyRange Generated      = Nothing
 
 -- | Convert a 'Term' annotated with a 'Range' to one annotated with a 'History'.
-mark :: Functor a => (Range -> History) -> Term a (Record (Range ': fields)) -> Term a (Record (History ': fields))
+mark :: Functor f => (Range -> History) -> f (Record (Range ': fields)) -> f (Record (History ': fields))
 mark f = fmap go where go (r :. a) = f r :. a
 
 
 data RPState = RPState
   { rpCursor  :: Int
-  , rpRange   :: Maybe Range
   , rpHistory :: History
   , rpSource  :: Source
   }
@@ -61,6 +68,7 @@ data Reprinter a where
 
   YElement :: Element -> Reprinter ()
   YControl :: Control -> Reprinter ()
+  YChunk   :: Source  -> Reprinter ()
   Finish :: Reprinter ()
 
   Get :: Reprinter RPState
@@ -92,13 +100,24 @@ locally :: (RPState -> RPState) -> Reprinter a -> Reprinter a
 locally f x = Get >>= \st -> Put (f st) *> x <* Put st
 
 data Element
-  = Whole Integer
+  = Fragment Text
+  | Truth Bool
+  | Nullity
+  | Separator
     deriving (Eq, Show)
 
 data Control
-  = Separator
+  = Enter Context
+  | Exit Context
     deriving (Eq, Show)
 
+data Context
+  = List
+  | Associative
+  | Pair
+  | Parenthesized
+    deriving (Show, Eq)
+
 yield :: Element -> Reprinter ()
 yield = YElement
 
@@ -112,7 +131,7 @@ class Traversable constr => Reprintable constr where
   whenRefactored = whenGenerated
 
   whenModified :: FAlgebra constr (Reprinter ())
-  whenModified = sequence_
+  whenModified = sequenceA_
 
 -- | Sums of reprintable terms are reprintable.
 instance (Apply Functor fs, Apply Foldable fs, Apply Traversable fs, Apply Reprintable fs) => Reprintable (Sum fs) where
@@ -121,13 +140,17 @@ instance (Apply Functor fs, Apply Foldable fs, Apply Traversable fs, Apply Repri
   whenModified = apply @Reprintable whenModified
 
 -- | Annotated terms are reprintable and operate in a context derived from the annotation.
-instance (HasField fields History, Reprintable (Sum fs)) => Reprintable (TermF (Sum fs) (Record fields)) where
+instance (HasField fields History, Reprintable a) => Reprintable (TermF a (Record fields)) where
   whenGenerated t = locally (withAnn (termFAnnotation t)) (whenGenerated (termFOut t) )
   whenRefactored t = locally (withAnn (termFAnnotation t)) (whenRefactored (termFOut t))
   whenModified t = locally (withAnn (termFAnnotation t)) (whenModified (termFOut t))
 
-withAnn :: HasField fields History => HasField fields History => Record fields -> RPState -> RPState
-withAnn ann s = let h = getField ann in s { rpRange = historyRange h, rpHistory = h}
+withAnn :: HasField fields History => Record fields -> RPState -> RPState
+withAnn ann s = let h = getField ann in s { rpHistory = h }
+
+withHistory :: HasField fields History
+            => Subterm (Term syntax (Record fields)) (Reprinter a) -> Reprinter a
+withHistory t = locally (withAnn (termAnnotation (subterm t))) (subtermRef t)
 
 data Token
   = Chunk Source
@@ -135,34 +158,38 @@ data Token
   | TControl Control
     deriving (Show, Eq)
 
-initial :: History -> Source -> RPState
-initial = RPState 0 Nothing
-
-descend :: HasField fields History => SubtermAlgebra constr (Term a (Record fields)) (Reprinter ())
+descend :: (Reprintable constr, HasField fields History) => SubtermAlgebra constr (Term a (Record fields)) (Reprinter ())
 descend t = history >>= \case
   Pristine _   -> pure ()
-  Modified _   -> pure ()
-  Generated    -> pure ()
-  Refactored _ -> pure ()
+  Modified _   -> whenModified (fmap subtermRef t)
+  Generated    -> whenGenerated (fmap withHistory t)
+  Refactored r -> do
+    st <- Get
+    let range = Range (rpCursor st) (start r)
+    source >>= (YChunk . slice range)
+    Put (st { rpCursor = start r })
+    whenRefactored (fmap withHistory t)
+    Put (st { rpCursor = end r})
 
-
-compile :: Reprinter a -> PlanT k Token (Eff '[State RPState]) a
+compile :: Reprinter a -> Eff '[State RPState, Writer (Seq Token)] a
 compile r = case r of
-  Get       -> lift get
-  Put a     -> lift (put a)
-  Pure v    -> pure v
-  Bind p f  -> compile p >>= compile . f
-  YElement e -> Machine.yield (TElement e)
-  YControl c -> Machine.yield (TControl c)
-  Finish    -> compile (dropSource <$> cursor <*> source) >>= Machine.yield . Chunk
+  Pure v     -> pure v
+  Bind p f   -> compile p >>= compile . f
+  Get        -> get
+  Put a      -> put a
+  YChunk c   -> tell (singleton (Chunk c))
+  YElement e -> tell (singleton (TElement e))
+  YControl c -> tell (singleton (TControl c))
+  Finish     -> compile (dropSource <$> cursor <*> source) >>= tell . singleton . Chunk
 
-reprint :: (Functor a, HasField fields History) => Source -> Term a (Record fields) -> [Token]
+
+reprint :: (Reprintable a, HasField fields History) => Source -> Term a (Record fields) -> Seq Token
 reprint s t =
   run
+  . fmap fst
+  . runWriter
   . fmap snd
-  . runState (initial (getField (termAnnotation t)) s)
-  . runT
-  . repeatedly
+  . runState (RPState 0 (getField (termAnnotation t)) s)
   . compile
   $ foldSubterms descend t *> finish
 

test/Rendering/Reprinting/Spec.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedLists #-}
+
 module Rendering.Reprinting.Spec where
 
 import SpecHelpers
@@ -7,13 +9,24 @@ import Rendering.Reprinter
 import Semantic.IO
 import Data.Blob
 
+setup = do
+  let path = "test/fixtures/javascript/reprinting/map.json"
+  src  <- blobSource <$> readBlobFromPath (File path Language.JSON)
+  tree <- parseFile jsonParser "test/fixtures/javascript/reprinting/map.json"
+  pure (src, tree)
+
 spec :: Spec
-spec = describe "reprinting" $
+spec = describe "reprinting" $ do
 
   it "should pass over a pristine tree" $ do
-    let path = "test/fixtures/javascript/reprinting/map.json"
-    src  <- blobSource <$> readBlobFromPath (File path Language.JSON)
-    tree <- parseFile jsonParser "test/fixtures/javascript/reprinting/map.json"
+    (src, tree) <- setup
     let tagged = mark Pristine tree
     let toks = reprint src tagged
     toks `shouldBe` [Chunk src]
+
+  it "should emit control tokens but only 1 chunk for a wholly-modified tree" $ do
+    (src, tree) <- fmap (fmap (mark Modified))setup
+    let toks = reprint src tree
+    forM_ @[] [List, Associative] $ \t -> do
+      toks `shouldSatisfy` (elem (TControl (Enter t)))
+      toks `shouldSatisfy` (elem (TControl (Exit t)))

test/fixtures/javascript/reprinting/map.json

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