[nongnu] elpa/haskell-tng-mode a6bb27e 061/385: [ci skip] layout algorithm implemented and tested

[ELPA Syncer]

branch: elpa/haskell-tng-mode
commit a6bb27ec2bdefab5ca0b5c82c0e476b439765869
Author: Tseen She <ts33n.sh3@gmail.com>
Commit: Tseen She <ts33n.sh3@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
+        ;(+) = _