Move splice to data, allow config for translation

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

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

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
+  = Chunk Source     -- original 'Source' from AST, unmodified by pipeline.
-  | TElement Element
+  | TElement Element --
   | TControl Control
     deriving (Show, Eq)
 

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"

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

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
+type Translate a = a -> Element -> [Context] -> Translator ()
-  translation :: (Element -> [Context] -> Translator ()) -> 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 :: forall lang a . (Translation lang a) => a -> Seq Token -> Either TranslationException (Seq Splice)
-translating tokens
+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 :: forall lang a . (Translation lang a) => a -> Token -> Translator ()
-translate = traverse_ step where
+translate config t = case t of
-  step :: Token -> Translator ()
+  Chunk source     -> emit (Source.toText source)
-  step t = case t of
+  TElement content -> get >>= translation @lang defaultTranslation config content
-    Chunk source     -> emit (Source.toText source)
+  TControl ctl     -> case ctl of
-    TElement content -> get >>= translation @lang defaultTranslation content
+    Log _   -> pure mempty
-    TControl ctl     -> case ctl of
+    Enter c -> enterContext c
-      Log _   -> pure mempty
+    Exit c  -> exitContext c
-      Enter c -> enterContext c
-      Exit c  -> exitContext c
 
-defaultTranslation :: Element -> [Context] -> Translator ()
+  where
-defaultTranslation content context = case (content, context) of
+    defaultTranslation :: Translate a
-  (Fragment f, _) -> emit f
+    defaultTranslation _ content context = case (content, context) of
+      (Fragment f, _) -> emit f
 
-  (Truth t, _) -> emit $ if t then "true" else "false"
+      (Truth True, _)  -> emit "true"
-  (Nullity, _) -> emit "null"
+      (Truth False, _) -> emit "false"
+      (Nullity, _)     -> emit "null"
 
-  (Open, List:_)        -> emit "["
+      (Open, List:_)        -> emit "["
-  (Open, Associative:_) -> emit "{"
+      (Open, Associative:_) -> emit "{"
 
-  (Close, List:_)        -> emit "]"
+      (Close, List:_)        -> emit "]"
-  (Close, Associative:_) -> emit "}"
+      (Close, Associative:_) -> emit "}"
 
-  (Separator, List:_)        -> emit ","
+      (Separator, List:_)        -> emit ","
-  (Separator, Associative:_) -> emit ","
+      (Separator, Associative:_) -> emit ","
-  (Separator, Pair:_)        -> 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

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)