Typesetting in the pipeline too

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"

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

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

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"