From b49adc41fec39af0f04f15d5c698a9c751a225f7 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 17 Aug 2018 09:10:14 -0700 Subject: [PATCH] Move splice to data, allow config for translation --- semantic.cabal | 1 + src/Data/Reprinting/Splice.hs | 28 +++++ src/Data/Reprinting/Token.hs | 10 +- src/Language/JSON/Translate.hs | 11 +- src/Reprinting/Pipeline.hs | 5 +- src/Reprinting/Translate.hs | 205 ++++++--------------------------- src/Semantic/Util.hs | 8 +- 7 files changed, 86 insertions(+), 182 deletions(-) create mode 100644 src/Data/Reprinting/Splice.hs diff --git a/semantic.cabal b/semantic.cabal index 741a66451..f76fa7e24 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -96,6 +96,7 @@ library , Data.Range , Data.Record , Data.Reprinting.Token + , Data.Reprinting.Splice , Data.Semigroup.App , Data.Scientific.Exts , Data.Source diff --git a/src/Data/Reprinting/Splice.hs b/src/Data/Reprinting/Splice.hs new file mode 100644 index 000000000..88a8f2618 --- /dev/null +++ b/src/Data/Reprinting/Splice.hs @@ -0,0 +1,28 @@ +module Data.Reprinting.Splice where + +import Data.Sequence (singleton) +import Data.String +import Prologue + +-- | The simplest possible representation of concrete syntax: either +-- it's a run of literal text or information about whitespace. +data Splice + = Insert Text + | Directive Layout + deriving (Eq, Show) + +splice :: Text -> Seq Splice +splice = singleton . Insert + +-- | Indentation/spacing directives. +data Layout + = HardWrap Int Indent + | SoftWrap + | Don't + deriving (Eq, Show) + +-- | Indentation types. This will eventually be moved into the rules engine. +data Indent = Space | Tab deriving (Eq, Show) + + +instance IsString Splice where fromString = Insert . fromString diff --git a/src/Data/Reprinting/Token.hs b/src/Data/Reprinting/Token.hs index 64c25c6ff..8ad813239 100644 --- a/src/Data/Reprinting/Token.hs +++ b/src/Data/Reprinting/Token.hs @@ -7,14 +7,18 @@ module Data.Reprinting.Token ) where import Data.Text (Text) - import Data.Source (Source) + +-- language agnostic -> language specific -> formatting whitespace +-- tokenize -> translate -> typeset +-- Seq Token -> Seq Splice -> Doc + -- | '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 + = Chunk Source -- original 'Source' from AST, unmodified by pipeline. + | TElement Element -- | TControl Control deriving (Show, Eq) diff --git a/src/Language/JSON/Translate.hs b/src/Language/JSON/Translate.hs index f39943f8b..4d82edfa9 100644 --- a/src/Language/JSON/Translate.hs +++ b/src/Language/JSON/Translate.hs @@ -6,8 +6,15 @@ import Data.Reprinting.Token import Prologue import Reprinting.Translate -instance Translation 'JSON where - translation _ content context = case (content, context) of + +data JSONTypeSetting = JSONTypeSetting { jsonPrettyPrint :: Bool } + deriving (Eq, Show) + +prettyJSON :: JSONTypeSetting +prettyJSON = JSONTypeSetting True + +instance Translation 'JSON JSONTypeSetting where + translation _ _ content context = case (content, context) of (Fragment f, _) -> emit f (Truth t, _) -> emit $ if t then "true" else "false" diff --git a/src/Reprinting/Pipeline.hs b/src/Reprinting/Pipeline.hs index 795c23d27..1ce4280e6 100644 --- a/src/Reprinting/Pipeline.hs +++ b/src/Reprinting/Pipeline.hs @@ -85,9 +85,10 @@ import Data.Source -- | Given a 'Proxy' corresponding to the language of the provided -- 'Term' and the original 'Source' from which the provided 'Term' was -- passed, run the reprinting pipeline. -runReprinter :: forall lang fields a . (Show (Record fields), Tokenize a, HasField fields History, Translation lang) +runReprinter :: forall lang config fields a . (Show (Record fields), Tokenize a, HasField fields History, Translation lang config) => Source + -> config -> Term a (Record fields) -> Either TranslationException Source -runReprinter s = fmap go . translating @lang . tokenizing s +runReprinter s config = fmap go . translating @lang config . tokenizing s where go = fromText . renderStrict . layoutPretty defaultLayoutOptions . typeset diff --git a/src/Reprinting/Translate.hs b/src/Reprinting/Translate.hs index 414b04d4a..ba58fc150 100644 --- a/src/Reprinting/Translate.hs +++ b/src/Reprinting/Translate.hs @@ -8,72 +8,73 @@ module Reprinting.Translate , Splice (..) , Layout (..) , Indent (..) + , translating + , translate , emit , splice ) where 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.Sequence (singleton) -import Data.String -import Lens.Micro - import Data.Language +import Data.Reprinting.Splice import Data.Reprinting.Token +import Data.Sequence (singleton) import qualified Data.Source as Source -class Translation (lang :: Language) where - translation :: (Element -> [Context] -> Translator ()) -> Element -> [Context] -> Translator () +type Translate a = a -> Element -> [Context] -> Translator () + +class Translation (lang :: Language) a where + translation :: Translate a -> Translate a type Translator = Eff '[State [Context], Writer (Seq Splice), Exc TranslationException] -translating :: forall lang . (Translation lang) => Seq Token -> Either TranslationException (Seq Splice) -translating tokens +translating :: forall lang a . (Translation lang a) => a -> Seq Token -> Either TranslationException (Seq Splice) +translating config tokens = run . Exc.runError . fmap fst . runWriter . fmap snd . runState mempty - $ translate @lang tokens + $ traverse_ (translate @lang config) tokens -translate :: forall lang . (Translation lang) => Seq Token -> Translator () -translate = traverse_ step where - step :: Token -> Translator () - step t = case t of - Chunk source -> emit (Source.toText source) - TElement content -> get >>= translation @lang defaultTranslation content - TControl ctl -> case ctl of - Log _ -> pure mempty - Enter c -> enterContext c - Exit c -> exitContext c +translate :: forall lang a . (Translation lang a) => a -> Token -> Translator () +translate config t = case t of + Chunk source -> emit (Source.toText source) + TElement content -> get >>= translation @lang defaultTranslation config content + TControl ctl -> case ctl of + Log _ -> pure mempty + Enter c -> enterContext c + Exit c -> exitContext c -defaultTranslation :: Element -> [Context] -> Translator () -defaultTranslation content context = case (content, context) of - (Fragment f, _) -> emit f + where + defaultTranslation :: Translate a + defaultTranslation _ content context = case (content, context) of + (Fragment f, _) -> emit f - (Truth t, _) -> emit $ if t then "true" else "false" - (Nullity, _) -> emit "null" + (Truth True, _) -> emit "true" + (Truth False, _) -> emit "false" + (Nullity, _) -> emit "null" - (Open, List:_) -> emit "[" - (Open, Associative:_) -> emit "{" + (Open, List:_) -> emit "[" + (Open, Associative:_) -> emit "{" - (Close, List:_) -> emit "]" - (Close, Associative:_) -> emit "}" + (Close, List:_) -> emit "]" + (Close, Associative:_) -> emit "}" - (Separator, List:_) -> emit "," - (Separator, Associative:_) -> emit "," - (Separator, Pair:_) -> emit ":" + (Separator, List:_) -> emit "," + (Separator, Associative:_) -> emit "," + (Separator, Pair:_) -> emit ":" - _ -> Exc.throwError (Unexpected "invalid context") + _ -> Exc.throwError (Unexpected "invalid context") emit :: Text -> Translator () emit = tell . splice @@ -89,53 +90,6 @@ exitContext c = do _ -> Exc.throwError (Unexpected "invalid context") - --- -- | Once the 'Tokenize' algebra has yielded a sequence of tokens, --- -- we need to apply per-language interpretation to each token so as to --- -- yield language-specific 'Splice's of source code. The 'Translate' --- -- typeclass describes a stack machine capable of translating a given --- -- a stream of 'Tokens', based on the concrete syntax of the specified --- -- language, into concrete-syntax 'Splice's. --- -- --- -- Some possible issues we should tackle before finalizing this design: --- -- --- -- * Is a stack machine too inexpressive? --- -- * Is this interface too clumsy? Do we just want to use Eff, or another monad? --- -- * Do we want to use a generic MonadError rather than instantiate that to Either? --- -- * @Coassignment@ might be a better name --- class Translate (lang :: Language) where --- --- type Stack lang = s | s -> lang --- --- -- | Each 'Element' data token should emit a chunk of source code, --- -- taking into account (but not changing) the state of the stack. --- onElement :: Element -> Stack lang -> Either TranslationException (Seq Splice) --- --- -- | Each 'Control' token can (but doesn't have to) change the state of the stack. --- onControl :: Control -> Stack lang -> Either TranslationException (Stack lang) - --- | Indentation types. This will eventually be moved into the rules engine. -data Indent = Space | Tab deriving (Eq, Show) - --- | Indentation/spacing directives. -data Layout - = HardWrap Int Indent - | SoftWrap - | Don't - deriving (Eq, Show) - --- | The simplest possible representation of concrete syntax: either --- it's a run of literal text or information about whitespace. -data Splice - = Insert Text - | Directive Layout - deriving (Eq, Show) - -splice :: Text -> Seq Splice -splice = singleton . Insert - -instance IsString Splice where fromString = Insert . fromString - -- | Represents failure occurring in a 'Concrete' machine. data TranslationException = InvalidContext (Maybe Context) Context [Context] @@ -143,94 +97,3 @@ data TranslationException | Unexpected String -- ^ Catch-all exception for unexpected tokens. deriving (Eq, Show) - --- -- | Run a 'Concrete' machine over each 'Token' in the provided --- -- 'Sequence'. Each resulting 'Doc' will be concatenated with --- -- 'mconcat'. Pass in an appropriately-kinded 'Proxy' to select how --- -- to interpret the language. --- translating :: (Translate lang, Lower (Stack lang)) --- => Proxy lang --- -> Seq Token --- -> Either TranslationException (Seq Splice) --- translating prox = --- run --- . Exc.runError --- . fmap snd --- . runState lowerBound --- . fmap fst --- . runWriter --- . traverse (stepM prox) --- --- -- Private interfaces --- --- newtype JSONState = JSONState --- { _contexts :: [Context] --- } deriving (Eq, Show) --- --- contexts :: Lens' JSONState [Context] --- contexts = lens _contexts (\s cs -> s { _contexts = cs }) --- --- current :: JSONState -> Maybe Context --- current s = s ^? contexts._head --- --- instance Lower JSONState where --- lowerBound = JSONState [] --- --- instance Translate 'JSON where --- type Stack 'JSON = JSONState --- --- onControl t st = case t of --- Log _ -> pure st --- Enter c -> pure (over contexts (c:) st) --- Exit c -> let curr = current st in --- if curr /= Just c --- then throwError (InvalidContext curr c (st ^. contexts)) --- else pure (over contexts tail st) --- --- onElement c st = let curr = current st in do --- case c of --- Fragment f -> pure . splice $ f --- Truth t -> pure . splice $ if t then "true" else "false" --- Nullity -> pure . splice $ "null" --- Open -> do --- case curr of --- Just List -> pure . splice $ "[" --- Just Associative -> pure ["{", Directive (HardWrap 2 Space)] --- x -> throwError (Unexpected (show (Open, x))) --- Close -> do --- case curr of --- Just List -> pure . splice $ "]" --- Just Associative -> pure [Directive (HardWrap 0 Space), "}"] --- x -> throwError (Unexpected (show (Close, x))) --- Separator -> do --- let curr = current st --- --- let i = Directive $ --- case curr of --- Just List -> SoftWrap --- Just Associative -> HardWrap 2 Space --- Just Pair -> SoftWrap --- _ -> Don't --- --- case curr of --- Just List -> pure [",", i] --- Just Associative -> pure [",", i] --- Just Pair -> pure [":", i] --- Nothing -> pure mempty --- ctx -> throwError (Unexpected (show ctx)) --- --- -- Distribute 'onControl' and 'onElement' over 'Token', using the --- -- obvious case to handle 'Chunk' tokens. --- step :: Translate lang => Token -> Stack lang -> Either TranslationException (Seq Splice, Stack lang) --- step t st = case t of --- Chunk src -> pure (splice . Source.toText $ src, st) --- TElement el -> onElement el st >>= \s -> pure (s, st) --- TControl ct -> (mempty, ) <$> onControl ct st --- --- -- Kludgy hack to convert 'step' into an effect. --- stepM :: forall lang . Translate lang => Proxy lang -> Token -> Eff '[Writer (Seq Splice), State (Stack lang), Exc TranslationException] () --- stepM _ t = do --- st <- get @(Stack lang) --- case step t st of --- Left exc -> Exc.throwError exc --- Right (s :: Seq Splice, st) -> tell s *> put st diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 52dc49cb6..bbb80d6dc 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -208,7 +208,7 @@ testRenameKey = do pure (toks, tagged) testRenameKey' = do - res <- translating @'Language.JSON . fst <$> testRenameKey + res <- translating @'Language.JSON prettyJSON . fst <$> testRenameKey putStrLn (either show (show . typeset) res) increaseNumbers :: (Literal.Float :< fs, Apply Functor fs) => Term (Sum fs) (Record (History ': fields)) -> Term (Sum fs) (Record (History ': fields)) @@ -256,7 +256,7 @@ testAddKVPair = do pure (toks, tagged) testAddKVPair' = do - res <- translating @'Language.JSON . fst <$> testAddKVPair + res <- translating @'Language.JSON prettyJSON . fst <$> testAddKVPair putStrLn (either show (show . typeset) res) testFloatMatcher = do @@ -291,7 +291,7 @@ testOverwriteFloats = do pure (toks, tagged) testOverwriteFloats' = do - res <- translating @'Language.JSON . fst <$> testOverwriteFloats + res <- translating @'Language.JSON prettyJSON . fst <$> testOverwriteFloats putStrLn (either show (show . typeset) res) @@ -346,5 +346,5 @@ testChangeKV = do pure (toks, tagged) testChangeKV' = do - res <- translating @'Language.JSON . fst <$> testChangeKV + res <- translating @'Language.JSON prettyJSON . fst <$> testChangeKV putStrLn (either show (show . typeset) res)