From dccea555ed69e927882375aef74d66529490abc7 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Tue, 31 Jul 2018 12:44:20 -0400 Subject: [PATCH] Extremely ad-hoc renderer to Docs --- semantic.cabal | 5 +- src/Data/Syntax.hs | 2 +- src/Data/Syntax/Literal.hs | 2 +- src/Reprinting/Algebra.hs | 43 ++-------------- src/Reprinting/Concrete.hs | 101 +++++++++++++++++++++++++++++++++++++ src/Reprinting/Pipeline.hs | 20 ++++++++ src/Reprinting/Token.hs | 58 +++++++++++++++++++++ test/Reprinting/Spec.hs | 34 ++++++++----- test/Spec.hs | 4 +- 9 files changed, 211 insertions(+), 58 deletions(-) create mode 100644 src/Reprinting/Concrete.hs create mode 100644 src/Reprinting/Pipeline.hs create mode 100644 src/Reprinting/Token.hs diff --git a/semantic.cabal b/semantic.cabal index 8d357ca38..5cce45008 100644 --- a/semantic.cabal +++ b/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 diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 907ed70ba..862b7591e 100644 --- a/src/Data/Syntax.hs +++ b/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 diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index 62abecd58..2e89e6521 100644 --- a/src/Data/Syntax/Literal.hs +++ b/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 diff --git a/src/Reprinting/Algebra.hs b/src/Reprinting/Algebra.hs index cff1c6dc3..65d04f2f8 100644 --- a/src/Reprinting/Algebra.hs +++ b/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 diff --git a/src/Reprinting/Concrete.hs b/src/Reprinting/Concrete.hs new file mode 100644 index 000000000..394f31a51 --- /dev/null +++ b/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) diff --git a/src/Reprinting/Pipeline.hs b/src/Reprinting/Pipeline.hs new file mode 100644 index 000000000..c53f99e29 --- /dev/null +++ b/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 diff --git a/src/Reprinting/Token.hs b/src/Reprinting/Token.hs new file mode 100644 index 000000000..36d3c0943 --- /dev/null +++ b/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) diff --git a/test/Reprinting/Spec.hs b/test/Reprinting/Spec.hs index 2461c8193..b38afc1b0 100644 --- a/test/Reprinting/Spec.hs +++ b/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 - (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))) - 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))) + describe "pipeline" $ do + it "should roundtrip exactly over a pristine tree" $ do + (src, tree) <- setup + let tagged = mark Pristine tree + let printed = runReprinter (Proxy @'Language.JSON) src tagged + printed `shouldBe` Right src diff --git a/test/Spec.hs b/test/Spec.hs index 80ed39c0e..319f7be57 100644 --- a/test/Spec.hs +++ b/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