Amazingly it complies! and still prettyprints

src/Reprinting/Pipeline.hs

@@ -67,6 +67,7 @@ stages of the pipeline follows:
 
 -}
 
+{-# LANGUAGE AllowAmbiguousTypes, TypeApplications, ScopedTypeVariables, RankNTypes #-}
 module Reprinting.Pipeline ( runReprinter ) where
 
 import Prologue
@@ -84,10 +85,9 @@ 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 :: (Show (Record fields), Tokenize a, HasField fields History, Translate lang, Lower (Stack lang))
+runReprinter :: forall lang fields a . (Show (Record fields), Tokenize a, HasField fields History, Translation lang)
-             => Proxy lang
+             => Source
-             -> Source
              -> Term a (Record fields)
              -> Either TranslationException Source
-runReprinter prox s = fmap go . translating prox . tokenizing s
+runReprinter s = fmap go . translating @lang . tokenizing s
   where go = fromText . renderStrict . layoutPretty defaultLayoutOptions . typeset

src/Reprinting/Translate.hs

@@ -2,8 +2,8 @@
              ScopedTypeVariables, TupleSections, TypeFamilyDependencies, TypeApplications, TypeOperators #-}
 
 module Reprinting.Translate
-  ( Translate (..)
+  ( -- Translate (..)
-  , Translation (..)
+    Translation (..)
   , TranslationException (..)
   , Splice (..)
   , Layout (..)
@@ -35,8 +35,8 @@ class Translation (lang :: Language) where
 
 type Translator = Eff '[State [Context], Writer (Seq Splice), Exc TranslationException]
 
-translating' :: forall lang . (Translation lang) => Seq Token -> Either TranslationException (Seq Splice)
+translating :: forall lang . (Translation lang) => Seq Token -> Either TranslationException (Seq Splice)
-translating' tokens
+translating tokens
   = run
   . Exc.runError
   . fmap fst
@@ -90,29 +90,29 @@ exitContext c = do
 
 
 
--- | Once the 'Tokenize' algebra has yielded a sequence of tokens,
+-- -- | Once the 'Tokenize' algebra has yielded a sequence of tokens,
--- we need to apply per-language interpretation to each token so as to
+-- -- we need to apply per-language interpretation to each token so as to
--- yield language-specific 'Splice's of source code. The 'Translate'
+-- -- yield language-specific 'Splice's of source code. The 'Translate'
--- typeclass describes a stack machine capable of translating a given
+-- -- typeclass describes a stack machine capable of translating a given
--- a stream of 'Tokens', based on the concrete syntax of the specified
+-- -- a stream of 'Tokens', based on the concrete syntax of the specified
--- language, into concrete-syntax 'Splice's.
+-- -- 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
 --
--- Some possible issues we should tackle before finalizing this design:
+--   type Stack lang = s | s -> lang
 --
--- * Is a stack machine too inexpressive?
+--   -- | Each 'Element' data token should emit a chunk of source code,
--- * Is this interface too clumsy? Do we just want to use Eff, or another monad?
+--   -- taking into account (but not changing) the state of the stack.
--- * Do we want to use a generic MonadError rather than instantiate that to Either?
+--   onElement :: Element -> Stack lang -> Either TranslationException (Seq Splice)
--- * @Coassignment@ might be a better name
+--
-class Translate (lang :: Language) where
+--   -- | Each 'Control' token can (but doesn't have to) change the state of the stack.
-
+--   onControl :: Control -> Stack lang -> Either TranslationException (Stack lang)
-  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)
@@ -144,93 +144,93 @@ data TranslationException
   -- ^ Catch-all exception for unexpected tokens.
     deriving (Eq, Show)
 
--- | Run a 'Concrete' machine over each 'Token' in the provided
+-- -- | Run a 'Concrete' machine over each 'Token' in the provided
--- 'Sequence'.  Each resulting 'Doc' will be concatenated with
+-- -- 'Sequence'.  Each resulting 'Doc' will be concatenated with
--- 'mconcat'.  Pass in an appropriately-kinded 'Proxy' to select how
+-- -- 'mconcat'.  Pass in an appropriately-kinded 'Proxy' to select how
--- to interpret the language.
+-- -- to interpret the language.
-translating :: (Translate lang, Lower (Stack lang))
+-- translating :: (Translate lang, Lower (Stack lang))
-            => Proxy lang
+--             => Proxy lang
-            -> Seq Token
+--             -> Seq Token
-            -> Either TranslationException (Seq Splice)
+--             -> Either TranslationException (Seq Splice)
-translating prox =
+-- translating prox =
-  run
+--   run
-  . Exc.runError
+--   . Exc.runError
-  . fmap snd
+--   . fmap snd
-  . runState lowerBound
+--   . runState lowerBound
-  . fmap fst
+--   . fmap fst
-  . runWriter
+--   . runWriter
-  . traverse (stepM prox)
+--   . traverse (stepM prox)
-
+--
--- Private interfaces
+-- -- Private interfaces
-
+--
-newtype JSONState = JSONState
+-- newtype JSONState = JSONState
-  { _contexts    :: [Context]
+--   { _contexts    :: [Context]
-  } deriving (Eq, Show)
+--   } deriving (Eq, Show)
-
+--
-contexts :: Lens' JSONState [Context]
+-- contexts :: Lens' JSONState [Context]
-contexts = lens _contexts (\s cs -> s { _contexts = cs })
+-- contexts = lens _contexts (\s cs -> s { _contexts = cs })
-
+--
-current :: JSONState -> Maybe Context
+-- current :: JSONState -> Maybe Context
-current s = s ^? contexts._head
+-- current s = s ^? contexts._head
-
+--
-instance Lower JSONState where
+-- instance Lower JSONState where
-  lowerBound = JSONState []
+--   lowerBound = JSONState []
-
+--
-instance Translate 'JSON where
+-- instance Translate 'JSON where
-  type Stack 'JSON = JSONState
+--   type Stack 'JSON = JSONState
-
+--
-  onControl t st = case t of
+--   onControl t st = case t of
-    Log _   -> pure st
+--     Log _   -> pure st
-    Enter c -> pure (over contexts (c:) st)
+--     Enter c -> pure (over contexts (c:) st)
-    Exit c  -> let curr = current st in
+--     Exit c  -> let curr = current st in
-      if curr /= Just c
+--       if curr /= Just c
-        then throwError (InvalidContext curr c (st ^. contexts))
+--         then throwError (InvalidContext curr c (st ^. contexts))
-        else pure (over contexts tail st)
+--         else pure (over contexts tail st)
-
+--
-  onElement c st = let curr = current st in do
+--   onElement c st = let curr = current st in do
-    case c of
+--     case c of
-      Fragment f -> pure . splice $ f
+--       Fragment f -> pure . splice $ f
-      Truth t    -> pure . splice $ if t then "true" else "false"
+--       Truth t    -> pure . splice $ if t then "true" else "false"
-      Nullity    -> pure . splice $ "null"
+--       Nullity    -> pure . splice $ "null"
-      Open -> do
+--       Open -> do
-        case curr of
+--         case curr of
-          Just List        -> pure . splice $ "["
+--           Just List        -> pure . splice $ "["
-          Just Associative -> pure ["{", Directive (HardWrap 2 Space)]
+--           Just Associative -> pure ["{", Directive (HardWrap 2 Space)]
-          x                -> throwError (Unexpected (show (Open, x)))
+--           x                -> throwError (Unexpected (show (Open, x)))
-      Close -> do
+--       Close -> do
-        case curr of
+--         case curr of
-          Just List        -> pure . splice $ "]"
+--           Just List        -> pure . splice $ "]"
-          Just Associative -> pure [Directive (HardWrap 0 Space), "}"]
+--           Just Associative -> pure [Directive (HardWrap 0 Space), "}"]
-          x                -> throwError (Unexpected (show (Close, x)))
+--           x                -> throwError (Unexpected (show (Close, x)))
-      Separator  -> do
+--       Separator  -> do
-        let curr = current st
+--         let curr = current st
-
+--
-        let i = Directive $
+--         let i = Directive $
-              case curr of
+--               case curr of
-                Just List        -> SoftWrap
+--                 Just List        -> SoftWrap
-                Just Associative -> HardWrap 2 Space
+--                 Just Associative -> HardWrap 2 Space
-                Just Pair        -> SoftWrap
+--                 Just Pair        -> SoftWrap
-                _                -> Don't
+--                 _                -> Don't
-
+--
-        case curr of
+--         case curr of
-          Just List        -> pure [",", i]
+--           Just List        -> pure [",", i]
-          Just Associative -> pure [",", i]
+--           Just Associative -> pure [",", i]
-          Just Pair        -> pure [":", i]
+--           Just Pair        -> pure [":", i]
-          Nothing          -> pure mempty
+--           Nothing          -> pure mempty
-          ctx              -> throwError (Unexpected (show ctx))
+--           ctx              -> throwError (Unexpected (show ctx))
-
+--
--- Distribute 'onControl' and 'onElement' over 'Token', using the
+-- -- Distribute 'onControl' and 'onElement' over 'Token', using the
--- obvious case to handle 'Chunk' tokens.
+-- -- obvious case to handle 'Chunk' tokens.
-step :: Translate lang => Token -> Stack lang -> Either TranslationException (Seq Splice, Stack lang)
+-- step :: Translate lang => Token -> Stack lang -> Either TranslationException (Seq Splice, Stack lang)
-step t st = case t of
+-- step t st = case t of
-  Chunk src   -> pure (splice . Source.toText $ src, st)
+--   Chunk src   -> pure (splice . Source.toText $ src, st)
-  TElement el -> onElement el st >>= \s -> pure (s, st)
+--   TElement el -> onElement el st >>= \s -> pure (s, st)
-  TControl ct -> (mempty, ) <$> onControl ct st
+--   TControl ct -> (mempty, ) <$> onControl ct st
-
+--
--- Kludgy hack to convert 'step' into an effect.
+-- -- 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 :: forall lang . Translate lang => Proxy lang -> Token -> Eff '[Writer (Seq Splice), State (Stack lang), Exc TranslationException] ()
-stepM _ t = do
+-- stepM _ t = do
-  st <- get @(Stack lang)
+--   st <- get @(Stack lang)
-  case step t st of
+--   case step t st of
-    Left exc                    -> Exc.throwError exc
+--     Left exc                    -> Exc.throwError exc
-    Right (s :: Seq Splice, st) -> tell s *> put st
+--     Right (s :: Seq Splice, st) -> tell s *> put st

src/Semantic/Util.hs

@@ -55,6 +55,7 @@ import           Semantic.Telemetry (LogQueue, StatQueue)
 import           System.Exit (die)
 import           System.FilePath.Posix (takeDirectory)
 import           Text.Show.Pretty (ppShow)
+import Language.JSON.Translate
 
 justEvaluating
   = runM
@@ -207,7 +208,7 @@ testRenameKey = do
   pure (toks, tagged)
 
 testRenameKey' = do
-  res <- translating (Proxy @'Language.JSON) . fst <$> testRenameKey
+  res <- translating @'Language.JSON . 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))
@@ -255,7 +256,7 @@ testAddKVPair = do
   pure (toks, tagged)
 
 testAddKVPair' = do
-  res <- translating (Proxy @'Language.JSON) . fst <$> testAddKVPair
+  res <- translating @'Language.JSON . fst <$> testAddKVPair
   putStrLn (either show (show . typeset) res)
 
 testFloatMatcher = do
@@ -290,7 +291,7 @@ testOverwriteFloats = do
   pure (toks, tagged)
 
 testOverwriteFloats' = do
-  res <- translating (Proxy @'Language.JSON) . fst <$> testOverwriteFloats
+  res <- translating @'Language.JSON . fst <$> testOverwriteFloats
   putStrLn (either show (show . typeset) res)
 
 
@@ -345,5 +346,5 @@ testChangeKV = do
   pure (toks, tagged)
 
 testChangeKV' = do
-  res <- translating (Proxy @'Language.JSON) . fst <$> testChangeKV
+  res <- translating @'Language.JSON . fst <$> testChangeKV
   putStrLn (either show (show . typeset) res)