branch: elpa/haskell-tng-mode
commit a4a664b1c54cec53b50b16a49ad5eb8dd93926f6
Author: Tseen She <ts33n....@gmail.com>
Commit: Tseen She <ts33n....@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*")
