branch: elpa/haskell-tng-mode
commit a6bb27ec2bdefab5ca0b5c82c0e476b439765869
Author: Tseen She <ts33n....@gmail.com>
Commit: Tseen She <ts33n....@gmail.com>
[ci skip] layout algorithm implemented and tested
---
haskell-tng-layout.el | 38 +++++++++---
haskell-tng-smie.el | 25 +++-----
haskell-tng-util.el | 6 ++
test/haskell-tng-layout-test.el | 42 +++++++++++--
test/haskell-tng-smie-test.el | 8 +--
test/src/layout.hs.layout | 19 ++++++
test/src/medley.hs.layout | 133 ++++++++++++++++++++++++++++++++++++++++
7 files changed, 233 insertions(+), 38 deletions(-)
diff --git a/haskell-tng-layout.el b/haskell-tng-layout.el
index f3cf56e..121abd8 100644
--- a/haskell-tng-layout.el
+++ b/haskell-tng-layout.el
@@ -19,16 +19,18 @@
;; Notes on caching
;;
-;; The easiest cache is to parse the entire buffer, invalidated on any change.
+;; Small brain is to parse the entire buffer, invalidated on any change.
;;
-;; A more efficient cache would store a record of the region that has been
-;; edited and reparse only the layouts that have changed. The invalidation may
-;; be a simple case of dismissing everything (including CLOSE parts) after any
-;; point that has been edited or trying to track insertions.
+;; Big brain would store a record of the region that has been edited and
reparse
+;; only the layouts that have changed. The invalidation may be a simple case of
+;; dismissing everything (including CLOSE parts) after any point that has been
+;; edited or trying to track insertions.
;;
;; Galaxy brain caching would use properties and put dirty markers on inserted
;; or deleted regions. Also this could give lightning fast lookup at point on
;; cache hits.
+;;
+;; Anything more complicated that small brain needs improved testing.
(require 'haskell-tng-util)
@@ -37,7 +39,9 @@
;; TODO invalidate the cache on change
-(defun haskell-tng-layout:virtuals-at-point (&optional pos)
+;; TODO a visual debugging option would be great, showing virtuals as overlays
+
+(defun haskell-tng-layout:virtuals-at-point ()
"List of virtual `{' `}' and `;' at point, according to the
Haskell2010 Layout rules.
@@ -45,8 +49,24 @@ Designed to be called repeatedly, managing its own caching."
(unless haskell-tng-layout:cache
(haskell-tng-layout:rebuild-cache-full))
- ;; FIXME lookup in cache
- )
+ (let ((pos (point)))
+ (catch 'done
+ (let (breaks
+ closes)
+ (dolist (block haskell-tng-layout:cache)
+ (let ((open (car block))
+ (close (cadr block))
+ (lines (cddr block)))
+ ;;(message "BLOCK = %S (%s, %s, %s)" block open close lines)
+ (when (and (<= open pos) (<= pos close))
+ (when (= open pos)
+ (throw 'done '("{")))
+ (when (= close pos)
+ (push "}" closes))
+ (dolist (line lines)
+ (when (= line pos)
+ (push ";" breaks))))))
+ (append (reverse closes) (reverse breaks))))))
(defun haskell-tng-layout:rebuild-cache-full ()
(let (case-fold-search
@@ -55,7 +75,7 @@ Designed to be called repeatedly, managing its own caching."
(goto-char 0)
(while (not (eobp))
(when-let (wldo (haskell-tng-layout:next-wldo))
- (push haskell-tng-layout:cache cache))))
+ (push wldo cache))))
(setq haskell-tng-layout:cache (reverse cache))))
(defun haskell-tng-layout:next-wldo ()
diff --git a/haskell-tng-smie.el b/haskell-tng-smie.el
index 3bf4d76..250cb66 100644
--- a/haskell-tng-smie.el
+++ b/haskell-tng-smie.el
@@ -27,16 +27,13 @@
;;; Code:
(require 'smie)
+
(require 'haskell-tng-font-lock)
+(require 'haskell-tng-layout)
;; FIXME: this is all broken, use haskell-tng-layout
-(defvar-local haskell-tng-smie:wldos nil)
-;; State: a list of tokens to return at the current point ending with `t' as an
-;; indicator that all virtual tokens have been processed. `nil' means to
proceed
-;; as normal.
-;;
-;; FIXME cache invalidation
+;; TODO: invalidate this state when the lexer jumps around or the user edits
(defvar-local haskell-tng-smie:multi nil)
;; Function to scan forward for the next token.
@@ -49,17 +46,11 @@
;; https://www.gnu.org/software/emacs/manual/html_mono/elisp.html#SMIE-Lexer
(defun haskell-tng-smie:forward-token ()
(interactive) ;; for testing
- (forward-comment (point-max)) ;; TODO: move to after virtual token generation
- (cond
- ;; TODO: remove this hack
- ((eobp)
- "}")
-
- ;; reading from state
- ((stringp (car haskell-tng-smie:multi))
- (pop haskell-tng-smie:multi))
+ (if (stringp (car haskell-tng-smie:multi))
+ ;; reading from state
+ (pop haskell-tng-smie:multi)
- (t
+ (forward-comment (point-max))
(let ((done-multi (pop haskell-tng-smie:multi))
(case-fold-search nil)
(offside (car haskell-tng-smie:wldos)))
@@ -109,7 +100,7 @@
;; single char
(t
(forward-char)
- (string (char-before)))))))))
+ (string (char-before))))))))
(defun haskell-tng-smie:last-match ()
(goto-char (match-end 0))
diff --git a/haskell-tng-util.el b/haskell-tng-util.el
index 6c1e27e..6b32759 100644
--- a/haskell-tng-util.el
+++ b/haskell-tng-util.el
@@ -11,6 +11,12 @@
(require 'subr-x)
+(defmacro haskell-tng:this-lisp-directory ()
+ (expand-file-name
+ (if load-file-name
+ (file-name-directory load-file-name)
+ default-directory)))
+
(defun haskell-tng:paren-close (&optional pos)
"The next `)', if it closes `POS's paren depth."
(save-excursion
diff --git a/test/haskell-tng-layout-test.el b/test/haskell-tng-layout-test.el
index f29fff6..a4db333 100644
--- a/test/haskell-tng-layout-test.el
+++ b/test/haskell-tng-layout-test.el
@@ -9,11 +9,43 @@
(require 'ert)
(require 's)
-;; FIXME a testing framework for layout
+(defun haskell-tng-layout-test:parse-to-string ()
+ (goto-char 0)
+ (let (tokens)
+ (while (not (eobp))
+ (when-let (virtuals (haskell-tng-layout:virtuals-at-point))
+ (push (s-join "" virtuals) tokens))
+ (push (string (char-after)) tokens)
+ (forward-char))
+ (s-join "" (reverse tokens))))
-;; (ert-deftest haskell-tng-layout-file-tests ()
-;; (should (have-expected-forward-lex "src/medley.hs"))
-;; (should (have-expected-forward-lex "src/layout.hs"))
-;; )
+;; TODO share principle with SMIE (and maybe faceup) tests
+(defun have-expected-layout (file)
+ (let* ((backup-inhibited t)
+ (filename (expand-file-name
+ file
+ (haskell-tng:this-lisp-directory)))
+ (golden (concat filename ".layout"))
+ (expected (with-temp-buffer
+ (insert-file-contents golden)
+ (buffer-string)))
+ (got (with-temp-buffer
+ (insert-file-contents filename)
+ ;; TODO mode should be a parameter
+ (haskell-tng-mode)
+ (haskell-tng-layout-test:parse-to-string))))
+ (or (equal got expected)
+ ;; TODO make this a setting
+ ;; writes out the new version on failure
+ (progn
+ (write-region got nil golden)
+ nil))))
+
+(ert-deftest haskell-tng-layout-file-tests ()
+ ;; the Haskell2010 test case
+ (should (have-expected-layout "src/layout.hs"))
+
+ (should (have-expected-layout "src/medley.hs"))
+ )
;;; haskell-tng-layout-test.el ends here
diff --git a/test/haskell-tng-smie-test.el b/test/haskell-tng-smie-test.el
index 9fb86f8..350da9f 100644
--- a/test/haskell-tng-smie-test.el
+++ b/test/haskell-tng-smie-test.el
@@ -9,12 +9,6 @@
(require 'ert)
(require 's)
-(defmacro haskell-tng-smie:this-lisp-directory ()
- (expand-file-name
- (if load-file-name
- (file-name-directory load-file-name)
- default-directory)))
-
;; copy/pasta of `smie-indent-forward-token' but rendering lexed tokens in a
way
;; more ammenable to regression testing (e.g. syntax table usage)
(defun haskell-tng-smie:indent-forward-token ()
@@ -67,7 +61,7 @@ When called interactively, shows the tokens in a buffer."
(let* ((backup-inhibited t)
(filename (expand-file-name
file
- (haskell-tng-smie:this-lisp-directory)))
+ (haskell-tng:this-lisp-directory)))
(golden (concat filename ".lexer"))
(expected (with-temp-buffer
(insert-file-contents golden)
diff --git a/test/src/layout.hs.layout b/test/src/layout.hs.layout
new file mode 100644
index 0000000..1115f57
--- /dev/null
+++ b/test/src/layout.hs.layout
@@ -0,0 +1,19 @@
+-- Figure 2.1 from the Haskell2010 report
+module AStack( Stack, push, pop, top, size ) where
+{data Stack a = Empty
+ | MkStack a (Stack a)
+
+;push :: a -> Stack a -> Stack a
+;push x s = MkStack x s
+
+;size :: Stack a -> Int
+;size s = length (stkToLst s) where
+ {stkToLst Empty = []
+ ;stkToLst (MkStack x s) = x:xs where {xs = stkToLst s
+
+}};pop :: Stack a -> (a, Stack a)
+;pop (MkStack x s)
+ = (x, case s of {r -> i r where {i x = x}}) -- (pop Empty) is an error
+
+;top :: Stack a -> a
+;top (MkStack x s) = x -- (top Empty) is an error
diff --git a/test/src/medley.hs.layout b/test/src/medley.hs.layout
new file mode 100644
index 0000000..0731662
--- /dev/null
+++ b/test/src/medley.hs.layout
@@ -0,0 +1,133 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | This file is a medley of various constructs and some corner cases
+module Foo.Bar.Main
+ ( Wibble(..), Wobble(Wobb, (!!!)), Woo
+ -- * Operations
+ , getFooByBar, getWibbleByWobble
+ , module Bloo.Foo
+ ) 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 -- wibble (wobble)
+ 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,
+ Typey,
+ wibble,
+ Wibble)
+;import System.FilePath (replaceExtension, Foo(Bar, (:<))
+;import System.IO (IOMode (..), hClose, hGetContents,
+ hPutStr, hPutStrLn, openFile, stderr,
+ stdout, MoarTypey)
+;import System.Process (CreateProcess (..), StdStream (..),
+ createProcess, proc, waitForProcess)
+
+-- some chars that should be propertized
+;chars = ['c', '\n', '\'']
+
+;foo = "wobble (wibble)"
+
+;class Get a s where
+ {get :: Set s -> a
+
+};instance {-# OVERLAPS #-} Get a (a ': s) where
+ {get (Ext a _) = a
+
+};instance {-# OVERLAPPABLE #-} Get a s => Get a (b ': s) where
+ {get (Ext _ xs) = get xs
+
+};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
+
+};instance (Eq a) => Eq (Tree a) where
+ {Leaf a == Leaf b = a == b
+ ;(Branch l1 r1) == (Branch l2 r2) = (l1==l2) && (r1==r2)
+ ;_ == _ = False
+
+};data ReportType = Alloc -- ^ Report allocations, percent
+ | Entries -- ^ Report entries, number
+ | Time -- ^ Report time spent in closure, percent
+ | Ticks -- ^ Report ticks, number
+ | Bytes -- ^ Report bytes allocated, number
+ deriving (Eq, Show)
+
+;type family G a where
+ {G Int = Bool
+ ;G a = Char
+
+};data Flobble = Flobble
+ deriving (Eq) via (NonNegative (Large Int))
+ deriving stock (Floo)
+ deriving anyclass (WibblyWoo, OtherlyWoo)
+
+;newtype Flobby = Flobby
+
+;foo ::
+ Wibble -- wibble
+ -> Wobble -- wobble
+ -> Wobble -- wobble
+ -> Wobble -- wobble
+ -> (wob :: Wobble)
+ -> (Wobble -- wobble
+ a b c)
+
+;(foo :: (Wibble Wobble)) foo
+
+;newtype TestApp
+ (logger :: TestLogger)
+ (scribe :: TestScribe)
+ config
+ a
+ = TestApp a
+
+;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"))
+ <*> optional
+ (Opts.strArgument
+ (Opts.metavar "MY-FILE" <>
+ Opts.help "meh"))
+
+;type PhantomThing
+
+;type SomeApi =
+ "thing" :> Capture "bar" Index :> QueryParam "wibble" Text
+ :> QueryParam "wobble" Natural
+ :> Header TracingHeader
TracingId
+ :> ThingHeader
+ :> Get '[JSON] (The ReadResult)
+ :<|> "thing" :> ReqBody '[JSON] Request
+ :> Header TracingHeader TracingId
+ :> SpecialHeader
+ :> Post '[JSON] (The Response)
+
+;deriving instance FromJSONKey StateName
+;deriving anyclass instance FromJSON Base
+;deriving newtype instance FromJSON Treble
+
+;foo = bar
+ where {baz = _
+ -- checking that comments are ignored in layout
+ -- and that a starting syntax entry is ok
+ ;(+) = _
