From f239a7a48362c5897ea0916f6cb234ba75dd1140 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Fri, 17 Aug 2018 12:46:54 -0700 Subject: [PATCH] Typesetting in the pipeline too --- src/Language/JSON/Translate.hs | 28 ++++++------ src/Reprinting/Pipeline.hs | 29 ++++++------ src/Reprinting/Translate.hs | 84 +++++++++++++++++----------------- src/Reprinting/Typeset.hs | 16 ++++--- 4 files changed, 77 insertions(+), 80 deletions(-) diff --git a/src/Language/JSON/Translate.hs b/src/Language/JSON/Translate.hs index 40d98c746..ad551dc14 100644 --- a/src/Language/JSON/Translate.hs +++ b/src/Language/JSON/Translate.hs @@ -19,24 +19,22 @@ data JSONTypeSetting = JSONTypeSetting { jsonPrettyPrint :: Bool } prettyJSON :: JSONTypeSetting prettyJSON = JSONTypeSetting True -instance ( Member (State [Context]) effs - , Member (Writer (Seq Splice)) effs - , Member (Exc TranslationException) effs - ) => Translation 'JSON JSONTypeSetting effs where +instance Translation 'JSON JSONTypeSetting where translation _ _ content context = case (content, context) of - (Fragment f, _) -> emit f + (Fragment f, _) -> Right $ splice f - (Truth t, _) -> emit $ if t then "true" else "false" - (Nullity, _) -> emit "null" + (Truth True, _) -> Right $ splice "true" + (Truth False, _) -> Right $ splice "false" + (Nullity, _) -> Right $ splice "null" - (Open, List:_) -> emit "[" - (Open, Associative:_) -> emit "{" + (Open, List:_) -> Right $ splice "[" + (Open, Associative:_) -> Right $ splice "{" - (Close, List:_) -> emit "]" - (Close, Associative:_) -> emit "}" + (Close, List:_) -> Right $ splice "]" + (Close, Associative:_) -> Right $ splice "}" - (Separator, List:_) -> emit "," - (Separator, Associative:_) -> emit "," - (Separator, Pair:_) -> emit ":" + (Separator, List:_) -> Right $ splice "," + (Separator, Associative:_) -> Right $ splice "," + (Separator, Pair:_) -> Right $ splice ":" - _ -> Exc.throwError (Unexpected "invalid context") + _ -> Left "JSON translate failed, unknown context" diff --git a/src/Reprinting/Pipeline.hs b/src/Reprinting/Pipeline.hs index 316758a1c..3c536f5f1 100644 --- a/src/Reprinting/Pipeline.hs +++ b/src/Reprinting/Pipeline.hs @@ -99,7 +99,7 @@ import Data.Sequence (singleton) -- | 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 config fields a . (Show (Record fields), Tokenize a, HasField fields History, Translation lang config TranslatorEffs) +runReprinter :: forall lang config fields a . (Show (Record fields), Tokenize a, HasField fields History, Translation lang config) => Source.Source -> config -> Term a (Record fields) @@ -109,27 +109,24 @@ runReprinter s config = fmap go . translating @lang config . tokenizing s -- type PipelineEffs = '[Reader RPContext, State RPState, State [Context], Writer (Seq Splice), Exc TranslationException] -runPipeline :: forall lang config fields a effs . +runPipeline :: forall lang config fields a . ( Show (Record fields) , Tokenize a , HasField fields History - , Translation lang config TranslatorEffs) - => config - -> Source.Source - -> Term a (Record fields) - -> Either TranslationException Source.Source + , Translation lang config + ) + => config + -> Source.Source + -> Term a (Record fields) + -> Either TranslationException Source.Source runPipeline config s tree = fmap go . Effect.run . Exc.runError - . fmap fst - . runWriter . fmap snd . runState (mempty :: [Context]) - -- . runTranslatingEffs - . runT $ source (tokenizing s tree) ~> - machine (translatingRule @lang config) - -- machine (typeSettingRule) ~> - -- machine (prettyPrintingRule) - - where go = Source.fromText . renderStrict . layoutPretty defaultLayoutOptions . typeset + . foldT $ source (tokenizing s tree) + ~> machine (translatingRule @lang config) + ~> flattened + ~> machine (typeSettingRule) + where go = Source.fromText . renderStrict . layoutPretty defaultLayoutOptions diff --git a/src/Reprinting/Translate.hs b/src/Reprinting/Translate.hs index 1d6275053..4e92bdacf 100644 --- a/src/Reprinting/Translate.hs +++ b/src/Reprinting/Translate.hs @@ -33,25 +33,25 @@ import Data.Sequence (singleton) import qualified Data.Source as Source -type Translate a effs = a -> Element -> [Context] -> Eff effs () +type Translate a = a -> Element -> [Context] -> Either String (Seq Splice) -class Translation (lang :: Language) a effs where - translation :: Translate a effs -> Translate a effs +class Translation (lang :: Language) a where + translation :: Translate a -> Translate a -- type Translator = Eff '[State [Context], Writer (Seq Splice), Exc TranslationException] -type TranslatorEffs = '[State [Context], Writer (Seq Splice), Exc TranslationException] +type TranslatorEffs = '[State [Context], Exc TranslationException] translating :: forall lang a . - ( Translation lang a TranslatorEffs ) + ( Translation lang a ) => a -> Seq Token -> Either TranslationException (Seq Splice) -translating config tokens - = run - . Exc.runError - . fmap fst - . runWriter - . fmap snd - . runState (mempty :: [Context]) - $ traverse_ (translate @lang config) tokens +translating config tokens = undefined + -- = run + -- . Exc.runError + -- . fmap fst + -- . runWriter + -- . fmap snd + -- . runState (mempty :: [Context]) + -- $ traverse_ (oldtranslate @lang config) tokens -- runTranslatingEffs :: (Effectful m) => Eff TranslatorEffs () -> m '[] (Either TranslationException (Seq Splice)) -- runTranslatingEffs = undefined @@ -62,49 +62,49 @@ translating config tokens -- . runState (mempty :: [Context]) translatingRule :: forall lang a effs . - ( Translation lang a effs + ( Translation lang a , Member (State [Context]) effs - , Member (Writer (Seq Splice)) effs , Member (Exc TranslationException) effs ) => - a -> Rule effs Token () + a -> Rule effs Token (Seq Splice) translatingRule config = fromEffect "translating" (translate @lang config) translate :: forall lang a effs . - ( Translation lang a effs + ( Translation lang a , Member (State [Context]) effs - , Member (Writer (Seq Splice)) effs , Member (Exc TranslationException) effs ) => - a -> Token -> Eff effs () + a -> Token -> Eff effs (Seq Splice) translate config t = case t of - Chunk source -> emit (Source.toText source) - TElement content -> get >>= translation @lang defaultTranslation config content + Chunk source -> pure $ splice (Source.toText source) + TElement content -> do + a <- get + either (Exc.throwError . Unexpected) pure (translation @lang defaultTranslation config content a) TControl ctl -> case ctl of Log _ -> pure mempty - Enter c -> enterContext c - Exit c -> exitContext c + Enter c -> enterContext c *> pure mempty + Exit c -> exitContext c *> pure mempty where - defaultTranslation :: Translate a effs - defaultTranslation _ content context = case (content, context) of - (Fragment f, _) -> emit f - - (Truth True, _) -> emit "true" - (Truth False, _) -> emit "false" - (Nullity, _) -> emit "null" - - (Open, List:_) -> emit "[" - (Open, Associative:_) -> emit "{" - - (Close, List:_) -> emit "]" - (Close, Associative:_) -> emit "}" - - (Separator, List:_) -> emit "," - (Separator, Associative:_) -> emit "," - (Separator, Pair:_) -> emit ":" - - _ -> Exc.throwError (Unexpected "invalid context") + defaultTranslation :: Translate a + defaultTranslation _ content context = undefined -- case (content, context) of + -- (Fragment f, _) -> emit f + -- + -- (Truth True, _) -> emit "true" + -- (Truth False, _) -> emit "false" + -- (Nullity, _) -> emit "null" + -- + -- (Open, List:_) -> emit "[" + -- (Open, Associative:_) -> emit "{" + -- + -- (Close, List:_) -> emit "]" + -- (Close, Associative:_) -> emit "}" + -- + -- (Separator, List:_) -> emit "," + -- (Separator, Associative:_) -> emit "," + -- (Separator, Pair:_) -> emit ":" + -- + -- _ -> Exc.throwError (Unexpected "invalid context") -- translatingRule' :: forall lang a effs . -- ( Translation lang a diff --git a/src/Reprinting/Typeset.hs b/src/Reprinting/Typeset.hs index 30faa8692..1ba483145 100644 --- a/src/Reprinting/Typeset.hs +++ b/src/Reprinting/Typeset.hs @@ -1,7 +1,6 @@ module Reprinting.Typeset ( typeset , typeSettingRule - , prettyPrintingRule ) where import Prologue @@ -21,10 +20,13 @@ typeset = foldMap go where space Space = " " space Tab = "\t" - typeSettingRule :: Rule effs Splice (Doc a) -typeSettingRule = undefined - - -prettyPrintingRule :: Rule effs (Doc a) Source -prettyPrintingRule = undefined +typeSettingRule = fromFunction "typesetting" go where + go :: Splice -> Doc a + go (Insert t) = pretty t + go (Directive SoftWrap) = softline + go (Directive (HardWrap 0 _)) = line + go (Directive (HardWrap i t)) = line <> stimes i (space t) + go (Directive Don't) = mempty + space Space = " " + space Tab = "\t"