[nongnu] elpa/haskell-tng-mode a4a664b 056/385: layout inference

[ELPA Syncer]

branch: elpa/haskell-tng-mode
commit a4a664b1c54cec53b50b16a49ad5eb8dd93926f6
Author: Tseen She <ts33n.sh3@gmail.com>
Commit: Tseen She <ts33n.sh3@gmail.com>

    layout inference
---
 haskell-tng-smie.el           | 172 ++++++++++++++++++------------------------
 haskell-tng-util.el           |  17 +----
 test/faces/medley.hs          |   2 +-
 test/faces/medley.hs.faceup   |   2 +-
 test/faces/medley.hs.lexer    |  85 ++++++++++-----------
 test/haskell-tng-smie-test.el |   2 +-
 6 files changed, 120 insertions(+), 160 deletions(-)

diff --git a/haskell-tng-smie.el b/haskell-tng-smie.el
index 037f6c1..addeff0 100644
--- a/haskell-tng-smie.el
+++ b/haskell-tng-smie.el
@@ -29,20 +29,18 @@
 (require 'smie)
 (require 'haskell-tng-font-lock)
 
-;; FIXME: the "massive hack"s only work for a full forward parse of a file. If
-;; these hacks can't be removed it may be the death of SMIE, and we'll need a
-;; custom s-expression parser and indentation engine.
+;; FIXME: massive hack. Holds an ordered list of (position . level) that close
+;; an inferred layout block. This could be turned into a (cached) function call
+;; plus some state in wldo-state.
+(defvar-local haskell-tng-smie:wldos nil)
+
+;; FIXME: massive hack. State of previous lexeme. Unsure how to remove this.
+;; Ideally we would be able to return multiple tokens to SMIE and we wouldn't
+;; need this.
 ;;
-;; Maybe we could create state for a block of code (maybe top-level), hashed by
-;; the content. Then context-less forward/backward-token requests would always
-;; be able to consult the state without having to update it.
-
-;; FIXME: massive hack. Holds an ordered list of positions that close an
-;; inferred layout block.
-(defvar haskell-tng-smie:wldos nil)
-
-;; FIXME: massive hack. t if the previous lexeme was a WLDO
-(defvar haskell-tng-smie:wldo nil)
+;; TODO: refactor so this stores the list of tokens to return at the current
+;; point, and some information allowing cache invalidation.
+(defvar-local haskell-tng-smie:wldo-state nil)
 
 ;; Function to scan forward for the next token.
 ;;
@@ -54,100 +52,74 @@
 ;; https://www.gnu.org/software/emacs/manual/html_mono/elisp.html#SMIE-Lexer
 (defun haskell-tng-smie:forward-token ()
   (interactive) ;; for testing
-  (let ((start (point))
-        (wldo haskell-tng-smie:wldo))
-    (setq haskell-tng-smie:wldo nil)
+  (forward-comment (point-max))
+  (if (eobp)
+      "}"
+    (let ((case-fold-search nil)
+          (syntax (char-syntax (char-after)))
+          (wldo-state haskell-tng-smie:wldo-state)
+          (offside (car haskell-tng-smie:wldos)))
+      (setq haskell-tng-smie:wldo-state nil)
+      (cond
+       ;; layout
+       ((and (eq wldo-state 'start) (not (looking-at "{")))
+        (push (haskell-tng:layout-close-and-level) haskell-tng-smie:wldos)
+        (setq haskell-tng-smie:wldo-state 'middle)
+        "{")
+       ((when-let (close (car offside))
+          (= (point) close))
+        (pop haskell-tng-smie:wldos)
+        "}")
+       ((when-let (level (cdr offside))
+          (and
+           (= (current-column) level)
+           (not (eq wldo-state 'middle))))
+        (setq haskell-tng-smie:wldo-state 'middle)
+        ";")
+
+       ;; parens
+       ((member syntax '(?\( ?\) ?\" ?$)) nil)
+
+       ;; layout detection
+       ((looking-at (rx word-start (| "where" "let" "do" "of") word-end))
+        (setq haskell-tng-smie:wldo-state 'start)
+        (haskell-tng-smie:last-match))
+
+       ;; regexps
+       ((or
+         ;; known identifiers
+         (looking-at haskell-tng:regexp:reserved)
+         ;; symbols
+         (looking-at (rx (+ (| (syntax word) (syntax symbol)))))
+         ;; whatever the current syntax class is
+         (looking-at (rx-to-string `(+ (syntax ,syntax)))))
+        (haskell-tng-smie:last-match))))))
+
+(defun haskell-tng:layout-of-next-token ()
+  (save-excursion
     (forward-comment (point-max))
-    (unless (eobp)
-      (let ((start-line (line-number-at-pos start))
-            (this-line (line-number-at-pos))
-            (case-fold-search nil)
-            (syntax (char-syntax (char-after))))
-        (cond
-         ;; layout of wldo blocks: braces
-         ;;
-         ;; Starting braces can be detected with a lookback when we hit a non-{
-         ;; lexeme following a WLDO. Ending braces are a lot harder, as we need
-         ;; to calculate "do we need to close a brace here" every time the
-         ;; indentation level decreases.
-         ;;
-         ;; A hacky solution is to calculate and cache the closing brace when
-         ;; discovering an open brace, but that just introduces more problems.
-         ((and wldo (not (looking-at "{")))
-          (let ((close (haskell-tng:layout-close)))
-            (message "WLDO opened at %s setting level to %s, closing at %s"
-                     start (current-column) close)
-            (push close haskell-tng-smie:wldos))
-          "{")
-         ((when-let (close (car haskell-tng-smie:wldos))
-            (>= (point) close))
-          (message "WLDO closed at %s" (point))
-          (pop haskell-tng-smie:wldos)
-          "}")
-
-         ;; TODO should only trigger inside a WLDO block
-         ;; layout of wldo blocks: semicolons
-         ((not (eq start-line this-line))
-          (let ((start-layout (haskell-tng-smie:layout-level start-line))
-                (this-layout (current-indentation)))
-            ;;(message "LAYOUT %s %s" start-layout this-layout)
-            (cond
-             ((null start-layout) "")
-             ;;((eq start-layout this-layout) ";")
-             (t ""))))
-
-         ;; parens
-         ((member syntax '(?\( ?\) ?\" ?$)) nil)
-
-         ;; layout, wldo detection
-         ((looking-at (rx word-start (| "where" "let" "do" "of") word-end))
-          (message "WLDO is at %s" (point))
-          (setq haskell-tng-smie:wldo t)
-          (haskell-tng-smie:last-match))
-
-         ;; regexps
-         ((or
-           ;; known identifiers
-           (looking-at haskell-tng:regexp:reserved)
-           ;; symbols
-           (looking-at (rx (+ (| (syntax word) (syntax symbol)))))
-           ;; whatever the current syntax class is
-           (looking-at (rx-to-string `(+ (syntax ,syntax)))))
-          (haskell-tng-smie:last-match)))))))
-
-(defun haskell-tng-smie:looking-back-wldo (p)
-  "t if the previous token before point P is `where', `let', `do' or `of'."
-  ;; FIXME this is really hacky, it tries to reparse the last token. We should
-  ;; doing a backwards token parse to take comments into account, or at least
-  ;; caching the previous token.
+    (current-column)))
+
+(defun haskell-tng:layout-close-and-level (&optional pos)
+  "A cons cell of the closing point for the layout beginning at POS, and 
level."
   (save-excursion
-    (goto-char p)
-    (let ((hit (looking-back
-                (rx word-start (| "where" "let" "do" "of") word-end point)
-                nil
-                ;;(- p 5)
-                )))
-      (message "WLDO is %s at `...%s'" hit (buffer-substring-no-properties (- 
p 5) p))
-      hit)))
+    (goto-char (or pos (point)))
+    (let ((level (current-column))
+          (close (or (haskell-tng:paren-close) (point-max))))
+      (catch 'closed
+        (while (not (eobp))
+          (forward-line)
+          (forward-comment (point-max))
+          (when (< close (point))
+            (throw 'closed (cons close level)))
+          (when (< (current-column) level)
+            (throw 'closed (cons (point) level))))
+        (cons (point-max) level)))))
 
 (defun haskell-tng-smie:last-match ()
   (goto-char (match-end 0))
   (match-string-no-properties 0))
 
-(defun haskell-tng-smie:layout-level (line)
-  "Calculates the layout indentation at the end of the given line."
-
-  ;; TODO starting at the end of the line, look backwards for wldo (where, 
let, do, of).
-  ;; If the wldo is the last lexeme, then the layout level is set by the next 
line (return nil).
-  ;; If the wldo is followed by a non-brace lexeme, set the layout level.
-  ;;
-  ;; If there is no wldo, the layout level is set by the indentation level
-  ;; (think about this some more)
-  (save-excursion
-    (forward-line (- line (line-number-at-pos)))
-    ;; now at start of line
-    (current-indentation)))
-
 ;; TODO a haskell grammar
 ;; https://www.gnu.org/software/emacs/manual/html_mono/elisp.html#SMIE-Grammar
 (defvar haskell-tng-smie:grammar
diff --git a/haskell-tng-util.el b/haskell-tng-util.el
index 9f90b00..d7cca01 100644
--- a/haskell-tng-util.el
+++ b/haskell-tng-util.el
@@ -20,7 +20,8 @@
       (when (looking-at ")")
         (point)))))
 
-;; FIXME comment aware
+;; TODO comment / paren aware, like haskell-tng:layout-of-next-token
+;; TODO refactor to share code with haskell-tng:layout-of-next-token
 (defun haskell-tng:indent-close (&optional pos)
   "The beginning of the line with indentation that closes `POS'."
   (save-excursion
@@ -32,20 +33,6 @@
             (throw 'closed (point))))
         nil))))
 
-;; FIXME comment aware
-;; TODO share with haskell-tng:indent-close?
-(defun haskell-tng:layout-close (&optional pos)
-  "The point with indentation that closes `POS'."
-  (save-excursion
-    (goto-char (or pos (point)))
-    (let ((level (current-column)))
-      (catch 'closed
-        (while (and (forward-line) (not (eobp)))
-          (when (< (current-indentation) level)
-            (forward-char (current-indentation))
-            (throw 'closed (point))))
-        nil))))
-
 (defun haskell-tng:indent-close-previous ()
   "Indentation closing the previous symbol."
   (save-excursion
diff --git a/test/faces/medley.hs b/test/faces/medley.hs
index 5b950e5..f182758 100644
--- a/test/faces/medley.hs
+++ b/test/faces/medley.hs
@@ -34,7 +34,7 @@ import           System.Process      (CreateProcess (..), 
StdStream (..),
                                       createProcess, proc, waitForProcess)
 
 -- some chars that should be propertized
-'c' '\n' '\''
+chars = ['c', '\n', '\'']
 
 foo = "wobble (wibble)"
 
diff --git a/test/faces/medley.hs.faceup b/test/faces/medley.hs.faceup
index 822121c..2f33e9a 100644
--- a/test/faces/medley.hs.faceup
+++ b/test/faces/medley.hs.faceup
@@ -34,7 +34,7 @@
                                       createProcess«:haskell-tng:keyword:,» 
proc«:haskell-tng:keyword:,» waitForProcess«:haskell-tng:keyword:)»
 
 «x:-- some chars that should be propertized
-»«s:'c'» «s:'\n'» «s:'\''»
+»«:haskell-tng:toplevel:chars» «:haskell-tng:keyword:=» 
«:haskell-tng:keyword:[»«s:'c'»«:haskell-tng:keyword:,» 
«s:'\n'»«:haskell-tng:keyword:,» «s:'\''»«:haskell-tng:keyword:]»
 
 «:haskell-tng:toplevel:foo» «:haskell-tng:keyword:=» «s:"wobble (wibble)"»
 
diff --git a/test/faces/medley.hs.lexer b/test/faces/medley.hs.lexer
index 42da296..89748ba 100644
--- a/test/faces/medley.hs.lexer
+++ b/test/faces/medley.hs.lexer
@@ -10,78 +10,78 @@ _( Wibble _( .. _) , Wobble _( Wobb , _( !!! _) _) , Woo
 _) where
 
 { import Control.Applicative _( many , optional , pure , _( <*> _) , _( <|> _) 
_)
-import Data.Foldable _( traverse_ _)
-import Data.Functor _( _( <$> _) _)
-import Data.List _( intercalate _)
-import Data.Monoid _( _( <> _) _)
-import qualified Options.Monad
-import qualified Options.Applicative as Opts
-import qualified Options.Divisible
+; import Data.Foldable _( traverse_ _)
+; import Data.Functor _( _( <$> _) _)
+; import Data.List _( intercalate _)
+; import Data.Monoid _( _( <> _) _)
+; import qualified Options.Monad
+; import qualified Options.Applicative as Opts
+; import qualified Options.Divisible
 as Div
-import qualified ProfFile.App hiding _( as , hiding , qualified _)
-import ProfFile.App _( as , hiding , qualified _)
-import ProfFile.App hiding _( as , hiding , qualified _)
-import qualified ProfFile.App _( as , hiding , qualified _)
-import System.Exit _( ExitCode _( .. _) , exitFailure , qualified ,
+; import qualified ProfFile.App hiding _( as , hiding , qualified _)
+; import ProfFile.App _( as , hiding , qualified _)
+; import ProfFile.App hiding _( as , hiding , qualified _)
+; import qualified ProfFile.App _( as , hiding , qualified _)
+; import System.Exit _( ExitCode _( .. _) , exitFailure , qualified ,
 Typey ,
 wibble ,
 Wibble _)
-import System.FilePath _( replaceExtension , Foo _( Bar , _( :< _) _)
-import System.IO _( IOMode _( .. _) , hClose , hGetContents ,
+; import System.FilePath _( replaceExtension , Foo _( Bar , _( :< _) _)
+; import System.IO _( IOMode _( .. _) , hClose , hGetContents ,
 hPutStr , hPutStrLn , openFile , stderr ,
 stdout , MoarTypey _)
-import System.Process _( CreateProcess _( .. _) , StdStream _( .. _) ,
+; import System.Process _( CreateProcess _( .. _) , StdStream _( .. _) ,
 createProcess , proc , waitForProcess _)
 
 
-_'c' _'\n' _'\''
+; chars = _[ _'c' , _'\n' , _'\'' _]
 
-foo = _"wobble (wibble)"
+; foo = _"wobble (wibble)"
 
-class Get a s where
+; class Get a s where
 { get :: Set s -> a
 
-} instance Get a _( a ': s _) where
+} ; instance Get a _( a ': s _) where
 { get _( Ext a _ _) = a
 
-} instance Get a s => Get a _( b ': s _) where
+} ; instance Get a s => Get a _( b ': s _) where
 { get _( Ext _ xs _) = get xs
 
-} data Options = Options
+} ; data Options = Options
 _{ optionsReportType :: ReportType
 , optionsProfFile :: Maybe FilePath
 , optionsOutputFile :: Maybe FilePath
 , optionsFlamegraphFlags :: _[ String _]
 _} deriving _( Eq , Show _)
 
-class _( Eq a _) => Ord a where
-{ _( < _) , _( <= _) , _( >= _) , _( > _) :: a -> a -> Bool
-max @Foo , min :: a -> a -> a
+; class _( Eq a _) => Ord a where
+{ _; < _) , _( <= _) , _( >= _) , _( > _) :: a -> a -> Bool
+; max @Foo , min :: a -> a -> a
 
-} instance _( Eq a _) => Eq _( Tree a _) where
+} ; instance _( Eq a _) => Eq _( Tree a _) where
 { Leaf a == Leaf b = a == b
-_( Branch l1 r1 _) == _( Branch l2 r2 _) = _( l1==l2 _) && _( r1==r2 _)
-_ == _ = False
+; _; Branch l1 r1 _) == _( Branch l2 r2 _) = _( l1==l2 _) && _( r1==r2 _)
+; _ == _ = False
 
-} data ReportType = Alloc
+} ; data ReportType = Alloc
 | Entries
 | Time
 | Ticks
 | Bytes
 deriving _( Eq , Show _)
 
-type family G a where
+; type family G a where
 { G Int = Bool
-G a = Char
+; G a = Char
 
-} data Flobble = Flobble
+} ; data Flobble = Flobble
 deriving _( Eq _) via _( NonNegative _( Large Int _) _)
 deriving stock _( Floo _)
 deriving anyclass _( WibblyWoo , OtherlyWoo _)
 
-newtype Flobby = Flobby
+; newtype Flobby = Flobby
 
-foo ::
+; foo ::
 Wibble
 -> Wobble
 -> Wobble
@@ -90,17 +90,17 @@ Wibble
 -> _( Wobble
 a b c _)
 
-_( foo :: _( Wibble Wobble _) _) foo
+; _; foo :: _( Wibble Wobble _) _) foo
 
-newtype TestApp
+; newtype TestApp
 _( logger :: TestLogger _)
 _( scribe :: TestScribe _)
 config
 a
 = TestApp a
 
-optionsParser :: Opts.Parser Options
-optionsParser = Options
+; optionsParser :: Opts.Parser Options
+; optionsParser = Options
 <$> _( Opts.flag' Alloc _( Opts.long _"alloc" <> Opts.help _"wibble" _)
 <|> Opts.flag' Entries _( Opts.long _"entry" <> Opts.help _"wobble" _)
 <|> Opts.flag' Bytes _( Opts.long _"bytes" <> Opts.help _"i'm a fish" _) _)
@@ -109,9 +109,9 @@ _( Opts.strArgument
 _( Opts.metavar _"MY-FILE" <>
 Opts.help _"meh" _) _)
 
-type PhantomThing
+; type PhantomThing
 
-type SomeApi =
+; type SomeApi =
 _"thing" :> Capture _"bar" Index :> QueryParam _"wibble" Text
 :> QueryParam _"wobble" Natural
 :> Header TracingHeader TracingId
@@ -122,6 +122,7 @@ _"thing" :> Capture _"bar" Index :> QueryParam _"wibble" 
Text
 :> SpecialHeader
 :> Post ' _[ JSON _] _( The Response _)
 
-deriving instance FromJSONKey StateName
-deriving anyclass instance FromJSON Base
-deriving newtype instance FromJSON Treble
+; deriving instance FromJSONKey StateName
+; deriving anyclass instance FromJSON Base
+; deriving newtype instance FromJSON Treble
+}
diff --git a/test/haskell-tng-smie-test.el b/test/haskell-tng-smie-test.el
index b2cd085..82755b1 100644
--- a/test/haskell-tng-smie-test.el
+++ b/test/haskell-tng-smie-test.el
@@ -46,7 +46,7 @@ When called interactively, shows the tokens in a buffer."
         ordered))))
 
 (defun haskell-tng-smie:tokens-to-string (lines)
-  (s-join "\n" (--map (s-join " " it) lines)))
+  (concat (s-join "\n" (--map (s-join " " it) lines)) "\n"))
 
 (defun haskell-tng-smie:display-tokens (lines)
   (with-current-buffer (get-buffer-create "*Haskell-TNG-SMIE-test*")