Extremely ad-hoc renderer to Docs

semantic.cabal

@@ -151,6 +151,9 @@ library
                      , Rendering.Symbol
                      , Rendering.TOC
                      , Reprinting.Algebra
+                     , Reprinting.Concrete
+                     , Reprinting.Pipeline
+                     , Reprinting.Token
                      -- High-level flow & operational functionality (logging, stats, etc.)
                      , Semantic.AST
                      , Semantic.CLI
@@ -204,7 +207,6 @@ library
                      , http-client-tls
                      , http-types
                      , kdt
-                     , machines
                      , mersenne-random-pure64
                      , mtl
                      , network
@@ -212,6 +214,7 @@ library
                      , optparse-applicative
                      , parallel
                      , parsers
+                     , prettyprinter
                      , pretty-show
                      , recursion-schemes
                      , reducers

src/Data/Syntax.hs

@@ -18,7 +18,7 @@ import GHC.TypeLits
 import Diffing.Algorithm hiding (Empty)
 import Prelude
 import Prologue
-import Rendering.Reprinter hiding (Context, Element)
+import Reprinting.Algebra hiding (Context, Element)
 import qualified Assigning.Assignment as Assignment
 import qualified Data.Error as Error
 import Proto3.Suite.Class

src/Data/Syntax/Literal.hs

@@ -12,7 +12,7 @@ import           Numeric.Exts
 import           Prelude hiding (Float, null)
 import           Prologue hiding (Set, hash, null)
 import           Proto3.Suite.Class
-import           Rendering.Reprinter
+import           Reprinting.Algebra
 import           Text.Read (readMaybe)
 
 -- Boolean

src/Reprinting/Algebra.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeOperators, UndecidableInstances #-}
 
 module Reprinting.Algebra
-  ( History (..)
+  ( module Reprinting.Token
+  , History (..)
   , mark
   -- * Token types
   , Element (..)
@@ -30,6 +31,7 @@ import Data.Range
 import Data.Record
 import Data.Source
 import Data.Term
+import Reprinting.Token
 
 -- | 'History' values, when attached to a given 'Term', describe the ways in which
 -- that term was refactored, if any.
@@ -71,41 +73,10 @@ instance Applicative Reprinter where
 instance Monad Reprinter where
   (>>=) = Bind
 
--- | 'Element' tokens describe atomic pieces of source code to be
--- output to a rendered document. These tokens are language-agnostic
--- and are interpreted into language-specific representations at a
--- later point in the reprinting pipeline.
-data Element
-  = Fragment Text -- ^ A literal chunk of text.
-  | Truth Bool    -- ^ A boolean value.
-  | Nullity       -- ^ @null@ or @nil@ or some other zero value.
-  | Separator     -- ^ Some sort of delimiter, interpreted in some 'Context'.
-    deriving (Eq, Show)
-
 -- | Yield an 'Element' token in a 'Reprinter' context.
 yield :: Element -> Reprinter ()
 yield = YElement
 
--- | 'Control' tokens describe information about some AST's context.
--- Though these are ultimately rendered as whitespace (or nothing) on
--- the page, they are needed to provide information as to how deeply
--- subsequent entries in the pipeline should indent.
-data Control
-  = Enter Context
-  | Exit Context
-    deriving (Eq, Show)
-
-data Context
-  = List
-  | Associative
-  | Pair
-  | Infix Operator
-    deriving (Show, Eq)
-
-data Operator
-  = Add
-    deriving (Show, Eq)
-
 -- | Yield a 'Control' token in a 'Reprinter' context.
 control :: Control -> Reprinter ()
 control = YControl
@@ -140,14 +111,6 @@ instance (HasField fields History, Reprintable a) => Reprintable (TermF a (Recor
   whenRefactored t = locally (withAnn (termFAnnotation t)) (whenRefactored (termFOut t))
   whenModified t = locally (withAnn (termFAnnotation t)) (whenModified (termFOut t))
 
--- | 'Token' encapsulates 'Element' and 'Control' tokens, as well as sliced
--- portions of the original 'Source' for a given AST.
-data Token
-  = Chunk Source
-  | TElement Element
-  | TControl Control
-    deriving (Show, Eq)
-
 -- | The top-level function. Pass in a 'Source' and a 'Term' and
 -- you'll get out a 'Seq' of 'Token's for later processing.
 reprint :: (Reprintable a, HasField fields History) => Source -> Term a (Record fields) -> Seq Token

src/Reprinting/Concrete.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE FunctionalDependencies, KindSignatures, LambdaCase, ScopedTypeVariables, TupleSections, TypeOperators #-}
+
+module Reprinting.Concrete
+  ( Concrete (..)
+  , ConcreteException (..)
+  , Precedence (..)
+  , concretize
+  ) where
+
+import Prelude hiding (foldl)
+import Prologue hiding (Element)
+
+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           Data.Text.Prettyprint.Doc
+
+import           Data.Language
+import qualified Data.Source as Source
+import           Reprinting.Token
+
+data ConcreteException
+  = InvalidContext (Maybe Context) Context [Context]
+  | Unexpected String
+    deriving (Eq, Show)
+
+class Concrete (l :: Language) stack | l -> stack, stack -> l where
+  initial :: stack
+
+  onElement :: Element -> stack -> Either ConcreteException (Doc a)
+  onControl :: Control -> stack -> Either ConcreteException stack
+
+data JSState = JSState
+  { _currentPrecedence :: Precedence
+  , contexts           :: [Context]
+  }
+
+class HasContexts state where
+  push    :: Context -> state -> state
+  pop     :: state -> state
+  current :: state -> Maybe Context
+
+instance HasContexts JSState where
+  push c s = s { contexts = c : contexts s }
+
+  pop s = s { contexts = drop 1 (contexts s)}
+
+  current = listToMaybe . contexts
+
+data Precedence
+  = None
+  | Level Int
+
+instance Concrete 'JSON JSState where
+
+  initial = JSState None []
+
+  onControl t st = case t of
+    Enter c -> pure (push c st)
+    Exit c  -> do
+      let curr = current st
+      if curr /= Just c
+        then throwError (InvalidContext curr c (contexts st))
+        else pure (pop st)
+
+  onElement c st = do
+    case c of
+      Fragment f -> pure (pretty f)
+      Truth t    -> pure (if t then "true" else "false")
+      Nullity    -> pure "null"
+      Separator  -> case current st of
+        Just List        -> pure ","
+        Just Associative -> pure ", "
+        Just Pair        -> pure ": "
+        Nothing          -> pure mempty
+        ctx              -> throwError (Unexpected (show ctx))
+
+step :: Concrete lang state => Token -> state -> Either ConcreteException (Doc a, state)
+step t st = case t of
+  Chunk src   -> pure (pretty . Source.toText $ src, st)
+  TElement el -> onElement el st >>= \doc -> pure (doc, st)
+  TControl ct -> (mempty, ) <$> onControl ct st
+
+stepM :: forall lang state a . Concrete lang state => Proxy lang -> Token -> Eff '[Writer (Doc a), State state, Exc ConcreteException] ()
+stepM _ t = do
+  st <- get @state
+  case step t st of
+    Left exc                 -> Exc.throwError exc
+    Right (doc :: Doc a, st) -> tell doc *> put st
+
+concretize :: Concrete lang state => Proxy lang -> Seq Token -> Either ConcreteException (Doc a)
+concretize prox =
+  run
+  . Exc.runError
+  . fmap snd
+  . runState initial
+  . fmap fst
+  . runWriter
+  . traverse (stepM prox)

src/Reprinting/Pipeline.hs

@@ -0,0 +1,20 @@
+module Reprinting.Pipeline ( runReprinter ) where
+
+import Prologue
+
+import Data.Text.Prettyprint.Doc
+import Data.Text.Prettyprint.Doc.Render.Text
+
+import Reprinting.Algebra
+import Reprinting.Concrete
+import Data.Record
+import Data.Term
+import Data.Source
+
+runReprinter :: (Reprintable a, HasField fields History, Concrete lang stack)
+             => Proxy lang
+             -> Source
+             -> Term a (Record fields)
+             -> Either ConcreteException Source
+runReprinter prox s = fmap go . concretize prox . reprint s
+  where go = fromText . renderStrict . layoutPretty defaultLayoutOptions

src/Reprinting/Token.hs

@@ -0,0 +1,58 @@
+module Reprinting.Token
+  ( Token (..)
+  , Element (..)
+  , Control (..)
+  , Context (..)
+  , Operator (..)
+  ) where
+
+import Data.Text (Text)
+
+import Data.Source (Source)
+
+-- | 'Token' encapsulates 'Element' and 'Control' tokens, as well as sliced
+-- portions of the original 'Source' for a given AST.
+data Token
+  = Chunk Source
+  | TElement Element
+  | TControl Control
+    deriving (Show, Eq)
+
+-- | 'Element' tokens describe atomic pieces of source code to be
+-- output to a rendered document. These tokens are language-agnostic
+-- and are interpreted into language-specific representations at a
+-- later point in the reprinting pipeline.
+data Element
+  = Fragment Text -- ^ A literal chunk of text.
+  | Truth Bool    -- ^ A boolean value.
+  | Nullity       -- ^ @null@ or @nil@ or some other zero value.
+  | Separator     -- ^ Some sort of delimiter, interpreted in some 'Context'.
+    deriving (Eq, Show)
+
+-- | 'Control' tokens describe information about some AST's context.
+-- Though these are ultimately rendered as whitespace (or nothing) on
+-- the page, they are needed to provide information as to how deeply
+-- subsequent entries in the pipeline should indent.
+data Control
+  = Enter Context
+  | Exit Context
+    deriving (Eq, Show)
+
+-- | A 'Context' represents a scope in which other tokens can be
+-- interpreted. For example, in the 'Imperative' context a 'Separator'
+-- could be a semicolon or newline, whereas in a 'List' context a
+-- 'Separator' is probably going to be a comma.
+data Context
+  = List
+  | Associative
+  | Pair
+  | Infix Operator
+  | Imperative
+    deriving (Show, Eq)
+
+-- | A sum type representing every concievable infix operator a
+-- language can define. These are handled by instances of 'Concrete'
+-- and given appropriate precedence.
+data Operator
+  = Add
+    deriving (Show, Eq)

test/Reprinting/Spec.hs

@@ -5,7 +5,8 @@ module Reprinting.Spec where
 import SpecHelpers
 
 import qualified Data.Language as Language
-import Rendering.Reprinter
+import Reprinting.Algebra
+import Reprinting.Pipeline
 import Semantic.IO
 import Data.Blob
 
@@ -16,17 +17,24 @@ setup = do
   pure (src, tree)
 
 spec :: Spec
-spec = describe "reprinting" $ do
+spec = do
+  describe "reprinting" $ do
+    it "should pass over a pristine tree" $ do
+      (src, tree) <- setup
+      let tagged = mark Pristine tree
+      let toks = reprint src tagged
+      toks `shouldBe` [Chunk src]
 
-  it "should pass over a pristine tree" $ do
+    it "should emit control tokens but only 1 chunk for a wholly-modified tree" $ do
-    (src, tree) <- setup
+      (src, tree) <- fmap (fmap (mark Modified)) setup
-    let tagged = mark Pristine tree
+      let toks = reprint src tree
-    let toks = reprint src tagged
+      forM_ @[] [List, Associative] $ \t -> do
-    toks `shouldBe` [Chunk src]
+        toks `shouldSatisfy` (elem (TControl (Enter t)))
+        toks `shouldSatisfy` (elem (TControl (Exit t)))
 
-  it "should emit control tokens but only 1 chunk for a wholly-modified tree" $ do
+  describe "pipeline" $ do
-    (src, tree) <- fmap (fmap (mark Modified))setup
+    it "should roundtrip exactly over a pristine tree" $ do
-    let toks = reprint src tree
+      (src, tree) <- setup
-    forM_ @[] [List, Associative] $ \t -> do
+      let tagged = mark Pristine tree
-      toks `shouldSatisfy` (elem (TControl (Enter t)))
+      let printed = runReprinter (Proxy @'Language.JSON) src tagged
-      toks `shouldSatisfy` (elem (TControl (Exit t)))
+      printed `shouldBe` Right src

test/Spec.hs

@@ -21,7 +21,7 @@ import qualified Integration.Spec
 import qualified Matching.Go.Spec
 import qualified Numeric.Spec
 import qualified Rendering.TOC.Spec
-import qualified Reprinting.Algebra.Spec
+import qualified Reprinting.Spec
 import qualified Semantic.Spec
 import qualified Semantic.CLI.Spec
 import qualified Semantic.IO.Spec
@@ -58,7 +58,7 @@ main = do
       describe "Matching" Matching.Go.Spec.spec
       describe "Numeric" Numeric.Spec.spec
       describe "Rendering.TOC" Rendering.TOC.Spec.spec
-      describe "Reprinting.Algebra" Reprinting.Algebra.Spec.spec
+      describe "Reprinting.Spec" Reprinting.Spec.spec
       describe "Semantic" Semantic.Spec.spec
       describe "Semantic.CLI" Semantic.CLI.Spec.spec
       describe "Semantic.IO" Semantic.IO.Spec.spec