Split Transformer into a pure class and ProjectIn

cpp-notebook-language-server.cabal

@@ -42,6 +42,7 @@ library
       FlexibleInstances
       LambdaCase
       ViewPatterns
+      MultiParamTypeClasses
       MultiWayIf
       TupleSections
       NumericUnderscores
@@ -95,6 +96,7 @@ executable cpp-notebook-language-server
       FlexibleInstances
       LambdaCase
       ViewPatterns
+      MultiParamTypeClasses
       MultiWayIf
       TupleSections
       NumericUnderscores
@@ -152,6 +154,7 @@ test-suite cpp-notebook-language-server-test
       FlexibleInstances
       LambdaCase
       ViewPatterns
+      MultiParamTypeClasses
       MultiWayIf
       TupleSections
       NumericUnderscores

package.yaml

@@ -23,6 +23,7 @@ default-extensions:
 - FlexibleInstances
 - LambdaCase
 - ViewPatterns
+- MultiParamTypeClasses
 - MultiWayIf
 - TupleSections
 - NumericUnderscores

src/Language/LSP/Notebook/DeclarationSifter.hs

@@ -37,37 +37,6 @@ data DeclarationSifterParams = DeclarationSifterParams {
 instance Transformer DeclarationSifter where
   type Params DeclarationSifter = DeclarationSifterParams
 
-  getParams _ = DeclarationSifterParams "cling-parser" "__notebook_exec"
-
-  project :: MonadIO m => Params DeclarationSifter -> Doc -> m (Doc, DeclarationSifter, Either Text ())
-  project params doc = do
-    result <- parseCppCode params doc
-    let originalLines = docToList doc
-    let numOrigLines = length originalLines
-    case result of
-      Left err -> return (doc, mkIdentitySifter numOrigLines, Left (T.pack err))
-      Right declarations -> do
-        let (siftedIdxs, nonSiftedIdxs) = partitionIndices originalLines declarations
-            siftedLines = map (originalLines !!) siftedIdxs
-            nonSiftedLines = map (originalLines !!) nonSiftedIdxs
-
-        if not (null nonSiftedLines) && any (not . T.null . T.strip) nonSiftedLines
-          then do
-            -- Wrap executable lines in a function
-            let wrappedLines = wrapInFunction (execFunctionName params) nonSiftedLines
-                allLines = siftedLines ++ wrappedLines
-                numSifted = length siftedIdxs
-                -- Wrapper structure: header, body lines, closing brace
-                bodyStart = numSifted + 1  -- after function header
-                bodyEnd = numSifted + length nonSiftedLines  -- before closing brace
-                sifter = mkSifter numOrigLines siftedIdxs nonSiftedIdxs (Just (bodyStart, bodyEnd))
-            return (listToDoc allLines, sifter, Right ())
-          else do
-            -- No wrapper needed
-            let allLines = siftedLines ++ nonSiftedLines
-                sifter = mkSifter numOrigLines siftedIdxs nonSiftedIdxs Nothing
-            return (listToDoc allLines, sifter, Right ())
-
   transformPosition :: DeclarationSifter -> Position -> Maybe Position
   transformPosition sifter (Position l c)
     | origLine < 0 || origLine >= V.length (forward sifter) = Nothing
@@ -197,3 +166,33 @@ wrapInFunction functionName executableLines =
     functionStart = "void " <> functionName <> "() {"
     functionEnd = "}"
     indentedBody = map (\l -> if T.null l then l else "  " <> l) executableLines
+
+instance MonadIO m => ProjectIn m DeclarationSifter where
+  project :: Params DeclarationSifter -> Doc -> m (Doc, DeclarationSifter, Either Text ())
+  project params doc = do
+    result <- parseCppCode params doc
+    let originalLines = docToList doc
+    let numOrigLines = length originalLines
+    case result of
+      Left err -> return (doc, mkIdentitySifter numOrigLines, Left (T.pack err))
+      Right declarations -> do
+        let (siftedIdxs, nonSiftedIdxs) = partitionIndices originalLines declarations
+            siftedLines = map (originalLines !!) siftedIdxs
+            nonSiftedLines = map (originalLines !!) nonSiftedIdxs
+
+        if not (null nonSiftedLines) && any (not . T.null . T.strip) nonSiftedLines
+          then do
+            -- Wrap executable lines in a function
+            let wrappedLines = wrapInFunction (execFunctionName params) nonSiftedLines
+                allLines = siftedLines ++ wrappedLines
+                numSifted = length siftedIdxs
+                -- Wrapper structure: header, body lines, closing brace
+                bodyStart = numSifted + 1  -- after function header
+                bodyEnd = numSifted + length nonSiftedLines  -- before closing brace
+                sifter = mkSifter numOrigLines siftedIdxs nonSiftedIdxs (Just (bodyStart, bodyEnd))
+            return (listToDoc allLines, sifter, Right ())
+          else do
+            -- No wrapper needed
+            let allLines = siftedLines ++ nonSiftedLines
+                sifter = mkSifter numOrigLines siftedIdxs nonSiftedIdxs Nothing
+            return (listToDoc allLines, sifter, Right ())

src/Language/LSP/Transformer.hs

@@ -8,6 +8,7 @@ module Language.LSP.Transformer (
   Doc
 
   , Transformer(..)
+  , ProjectIn(..)
   , (:>)(..)
   , defaultHandleDiff
 
@@ -39,54 +40,54 @@ type Doc = Rope.Rope
 class Transformer a where
   type Params a
 
-  getParams :: a -> Params a
+  unproject :: a -> Doc -> Maybe Doc
+  unproject _ _ = Nothing
 
-  project :: MonadIO m => Params a -> Doc -> m (Doc, a, Either Text ())
+  transformPosition :: a -> Position -> Maybe Position
+
+  untransformPosition :: a -> Position -> Maybe Position
+
+class Transformer a => ProjectIn m a where
+  project :: Params a -> Doc -> m (Doc, a, Either Text ())
 
-  handleDiffMulti :: MonadIO m => Params a -> Doc -> [TextDocumentContentChangeEvent] -> a -> m ([TextDocumentContentChangeEvent], a)
+  handleDiffMulti :: Monad m => Params a -> Doc -> [TextDocumentContentChangeEvent] -> a -> m ([TextDocumentContentChangeEvent], a)
   handleDiffMulti params before changes tx = do
-    result <- foldM f ([], before, tx) changes
-    let (finalChanges, _finalLines, finalTx) = result
+    (finalChanges, _finalLines, finalTx) <- foldM f ([], before, tx) changes
     return (finalChanges, finalTx)
     where
-      f :: MonadIO m => ([TextDocumentContentChangeEvent], Doc, a) -> TextDocumentContentChangeEvent -> m ([TextDocumentContentChangeEvent], Doc, a)
       f (changesSoFar, curLines, txSoFar) change = do
         (newChanges, tx') <- handleDiff params curLines change txSoFar
         return (changesSoFar <> newChanges, applyChanges [change] curLines, tx')
 
-  handleDiff :: MonadIO m => Params a -> Doc -> TextDocumentContentChangeEvent -> a -> m ([TextDocumentContentChangeEvent], a)
+  handleDiff :: Monad m => Params a -> Doc -> TextDocumentContentChangeEvent -> a -> m ([TextDocumentContentChangeEvent], a)
   handleDiff = defaultHandleDiff
 
-  -- No 'Params' here: no transformer has ever needed them to map a position, and threading
-  -- them meant every caller had to be able to build a 'Params'.
-  transformPosition :: a -> Position -> Maybe Position
-
-  untransformPosition :: a -> Position -> Maybe Position
-
 data (a :: Type) :> (b :: Type) = a :> b
   deriving Show
 infixr :>
 
 instance (Transformer a, Transformer b) => Transformer (a :> b) where
   type Params (a :> b) = Params a :> Params b
-  getParams (x :> y) = getParams x :> getParams y
+  unproject (x :> y) lines = unproject y lines >>= unproject x
+  transformPosition (x :> y) p = transformPosition x p >>= transformPosition y
+  untransformPosition (x :> y) p = untransformPosition y p >>= untransformPosition x
+
+instance (ProjectIn m a, ProjectIn m b, Monad m) => ProjectIn m (a :> b) where
   project (xParams :> yParams) lines = do
     (lines', x, eitherErr1) <- project xParams lines
     (lines'', y, eitherErr2) <- project yParams lines'
     let overallErr = case lefts [eitherErr1, eitherErr2] of
           [] -> Right ()
-          xs -> Left (T.intercalate "; " xs)
+          errs -> Left (T.intercalate "; " errs)
     return (lines'', x :> y, overallErr)
   handleDiff (xParams :> yParams) before change (x :> y) = do
     (change', x') <- handleDiff xParams before change x
-    (beforeTransformed, _, _eitherErr1) <- project @a xParams before
+    (beforeTransformed, _, _err) <- project @m @a xParams before
     (change'', y') <- handleDiffMulti yParams beforeTransformed change' y
     return (change'', x' :> y')
-  transformPosition (x :> y) p = transformPosition x p >>= transformPosition y
-  untransformPosition (x :> y) p = untransformPosition y p >>= untransformPosition x
 
 -- Default implementation uses diff.
-defaultHandleDiff :: forall a m. (Transformer a, MonadIO m) => Params a -> Doc -> TextDocumentContentChangeEvent -> a -> m ([TextDocumentContentChangeEvent], a)
+defaultHandleDiff :: forall m a. (ProjectIn m a, Monad m) => Params a -> Doc -> TextDocumentContentChangeEvent -> a -> m ([TextDocumentContentChangeEvent], a)
 defaultHandleDiff params before change _transformer = do
   (before', _ :: a, _eitherErrBefore) <- project params before
   let after = applyChanges [change] before

test/TestLib/Core.hs

@@ -10,12 +10,12 @@ import Test.QuickCheck as Q
 
 
 testChange :: forall a m. (
-  Transformer a, Eq a, Show a, MonadIO m
+  ProjectIn m a, Eq a, Show a, MonadIO m
   ) => Params a -> Doc -> TextDocumentContentChangeEvent -> m Property
 testChange = testChange' @a (const [])
 
 testChange' :: forall a m. (
-  Transformer a, Eq a, Show a, MonadIO m
+  ProjectIn m a, Eq a, Show a, MonadIO m
   ) => ([TextDocumentContentChangeEvent] -> [Property]) -> Params a -> Doc -> TextDocumentContentChangeEvent -> m Property
 testChange' extraProps params docLines change = do
   -- Expected un-projected document after the change