Make Error a Functor; move all Error stuff to Error.hs

tools/lsp/squirrel/app/Main.hs

@@ -28,7 +28,6 @@ import           ParseTree
 import           Parser
 import           Range
 import           AST hiding (def)
-import           HasErrors
 import           Pretty
 import           Error
 
@@ -173,8 +172,8 @@ collectErrors funs uri path version = do
         $ partitionBySource
         $ map errorToDiag (errs <> errors tree)
 
-errorToDiag :: Error -> J.Diagnostic
-errorToDiag (Expected what instead (Range (sl, sc, _) (el, ec, _))) =
+errorToDiag :: Error ASTInfo -> J.Diagnostic
+errorToDiag (Expected what instead (getRange -> (Range (sl, sc, _) (el, ec, _)))) =
   J.Diagnostic
     (J.Range begin end)
     (Just J.DsError)

tools/lsp/squirrel/package.yaml

@@ -36,6 +36,8 @@ default-extensions:
   - TypeFamilies
   - TypeOperators
   - UndecidableInstances
+  - FunctionalDependencies
+  - ViewPatterns
 
 ghc-options: -freverse-errors -Wall -threaded
 

tools/lsp/squirrel/squirrel.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.31.2.
+-- This file has been generated from package.yaml by hpack version 0.33.0.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 1c4275313cf3b683e190f5dc3ea95cd8cde978c09aa4f2269958de6128c73df3
+-- hash: a49f1d3cbdae65e52d4685178a1d0fc9b72502cc4b3c8cfa45f245ffdf32922d
 
 name:           squirrel
 version:        0.0.0
@@ -18,13 +18,11 @@ library
       AST.Types
       Error
       HasComments
-      HasErrors
       Lattice
       Parser
       ParseTree
       Pretty
       Range
-      Stubbed
       TH
       Tree
       Union
@@ -33,7 +31,7 @@ library
       Paths_squirrel
   hs-source-dirs:
       src/
-  default-extensions: BangPatterns BlockArguments DataKinds DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances GADTs GeneralisedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies TypeOperators UndecidableInstances
+  default-extensions: BangPatterns BlockArguments DataKinds DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances GADTs GeneralisedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies TypeOperators UndecidableInstances FunctionalDependencies ViewPatterns
   ghc-options: -freverse-errors -Wall -threaded
   include-dirs:
       vendor
@@ -58,7 +56,7 @@ executable squirrel
       Paths_squirrel
   hs-source-dirs:
       app/
-  default-extensions: BangPatterns BlockArguments DataKinds DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances GADTs GeneralisedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies TypeOperators UndecidableInstances
+  default-extensions: BangPatterns BlockArguments DataKinds DeriveFoldable DeriveFunctor DeriveTraversable DerivingStrategies DerivingVia FlexibleContexts FlexibleInstances GADTs GeneralisedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings QuasiQuotes ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeFamilies TypeOperators UndecidableInstances FunctionalDependencies ViewPatterns
   ghc-options: -freverse-errors -Wall -threaded
   build-depends:
       base

tools/lsp/squirrel/src/Error.hs

@@ -1,23 +1,51 @@
 
 module Error
   ( Error(..)
+  , HasErrors (..)
+  , Stubbed (..)
   )
   where
 
-import Data.Text (Text)
+import Data.Text (Text, pack)
 
 import Pretty
 import Range
 
 -- | Parse error.
-data Error
+data Error info
   = Expected
     { eMsg   :: Text   -- ^ Description of what was expected.
     , eWhole :: Text   -- ^ Offending text.
-    , eRange :: Range  -- ^ Location of the error.
+    , eInfo  :: info   -- ^ Location of the error.
     }
-  deriving (Show) via PP Error
+  deriving (Show) via PP (Error info)
+  deriving stock (Functor, Foldable, Traversable)
 
-instance Pretty Error where
-  pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓"
+instance Pretty1 Error where
+  pp1 (Expected msg found r) = "░" <> pp msg <> r <> "▒" <> pp found <> "▓"
+
+-- | Ability to contain `Error`s.
+class HasErrors h info | h -> info where
+  errors :: h -> [Error info]
+
+-- | For types that have a default replacer with an `Error`.
+class Stubbed a i where
+  stub :: Error i -> a
+
+instance Pretty i => Stubbed Text i where
+  stub = pack . show
+
+-- | This is bad, but I had to.
+--
+--   TODO: Find a way to remove this instance.
+--         I probably need a wrapper around '[]'.
+--
+--         Or I need a @fields@ parser combinator.
+--
+instance Stubbed [a] i where
+  stub = const []
+
+-- | Is `Just` `.` @stubbing@.
+instance Stubbed a i => Stubbed (Maybe a) i where
+  stub = Just . stub
 

tools/lsp/squirrel/src/HasErrors.hs

@@ -1,10 +0,0 @@
-module HasErrors
-  ( HasErrors(..)
-  )
-  where
-
-import Error
-
--- | Ability to contain `Error`s.
-class HasErrors h where
-  errors :: h -> [Error]

tools/lsp/squirrel/src/Parser.hs

@@ -81,7 +81,6 @@ import Range
 import Pretty
 import HasComments
 import Error
-import Stubbed
 
 import Debug.Trace
 
@@ -91,9 +90,9 @@ import Debug.Trace
 --
 newtype Parser a = Parser
   { unParser
-      :: WriterT [Error]                -- Early I though to report errors that way.
+      :: WriterT [Error ASTInfo]        -- Early I though to report errors that way.
       (  StateT  (ParseForest, [Text])  -- Current forest to recognise + comments.
-      (  ExceptT Error                  -- Backtracking. Change `Error` to `()`?
+      (  ExceptT (Error ASTInfo)        -- Backtracking. Change `Error` to `()`?
       (  Identity )))                   -- I forgot why. `#include`? Debug via `print`?
          a
   }
@@ -102,27 +101,26 @@ newtype Parser a = Parser
     , Applicative
     , Monad
     , MonadState   (ParseForest, [Text])
-    , MonadWriter [Error]
-    , MonadError   Error
+    , MonadWriter [Error ASTInfo]
+    , MonadError  (Error ASTInfo)
     )
 
 -- | Generate error originating at current location.
-makeError :: Text -> Parser Error
+makeError :: Text -> Parser (Error ASTInfo)
 makeError msg = do
-  rng <- currentRange
+  rng <- getInfo
   makeError' msg rng
 
 -- | Generate error originating at given location.
-makeError' :: Text -> Range -> Parser Error
-makeError' msg rng = do
-  rng <- currentRange
+makeError' :: Text -> info -> Parser (Error info)
+makeError' msg i = do
   src <- gets (pfGrove . fst) <&> \case
     []                     -> ""
     (,) _ ParseTree { ptSource } : _ -> ptSource
   return Expected
     { eMsg   = msg
     , eWhole = src
-    , eRange = rng
+    , eInfo  = i
     }
 
 -- | Pick next tree in a forest or die with msg.
@@ -211,11 +209,11 @@ field name parser = do
       return res
 
 -- | Variuos error reports.
-fallback  :: Stubbed a => Text          -> Parser a
-fallback' :: Stubbed a => Text -> Range -> Parser a
-die       ::              Text          -> Parser a
-die'      ::              Text -> Range -> Parser a
-complain  ::              Text -> Range -> Parser ()
+fallback  :: Stubbed a ASTInfo => Text            -> Parser a
+fallback' :: Stubbed a ASTInfo => Text -> ASTInfo -> Parser a
+die       ::                      Text            -> Parser a
+die'      ::                      Text -> ASTInfo -> Parser a
+complain  ::                      Text -> ASTInfo -> Parser ()
 fallback  msg     = pure . stub =<< makeError  msg
 fallback' msg rng = pure . stub =<< makeError' msg rng
 die       msg     = throwError  =<< makeError  msg
@@ -223,12 +221,12 @@ die'      msg rng = throwError  =<< makeError' msg rng
 complain  msg rng = tell . pure =<< makeError' msg rng
 
 -- | When tree-sitter found something it was unable to process.
-unexpected :: ParseTree -> Error
+unexpected :: ParseTree -> Error ASTInfo
 unexpected ParseTree { ptSource, ptRange } =
-  Expected "not that" ptSource ptRange
+  Expected "not that" ptSource (ASTInfo ptRange [])
 
 -- | If a parser fails, return stub with error originating here.
-stubbed :: Stubbed a => Text -> Parser a -> Parser a
+stubbed :: Stubbed a ASTInfo => Text -> Parser a -> Parser a
 stubbed msg parser = do
   parser <|> fallback msg
 
@@ -286,7 +284,7 @@ some p = some'
 
 -- | Run parser on given file.
 --
-runParser :: Parser a -> FilePath -> IO (a, [Error])
+runParser :: Parser a -> FilePath -> IO (a, [Error ASTInfo])
 runParser (Parser parser) fin = do
   pforest <- toParseTree fin
   let
@@ -314,10 +312,11 @@ debugParser parser fin = do
 -- | Consume next tree if it has the given name. Or die.
 token :: Text -> Parser Text
 token node = do
-  tree@ParseTree {ptName, ptRange, ptSource} <- takeNext node
+  i <- getInfo
+  tree@ParseTree {ptName, ptSource} <- takeNext node
   if ptName == node
   then return ptSource
-  else die' node ptRange
+  else die' node i
 
 -- | Consume next tree, return its textual representation.
 anything :: Parser Text
@@ -394,7 +393,7 @@ notFollowedBy parser = do
 --   > inside "$field"
 --   > inside ":$treename" -- don't, use "subtree"
 --
-inside :: Stubbed a => Text -> Parser a -> Parser a
+inside :: Stubbed a ASTInfo => Text -> Parser a -> Parser a
 inside sig parser = do
   let (f, st') = Text.breakOn ":" sig
   let st       = Text.drop 1 st'
@@ -420,6 +419,9 @@ data ASTInfo = ASTInfo
   , aiComments :: [Text]
   }
 
+instance Pretty ASTInfo where
+  pp (ASTInfo r comms) = pp r $$ vcat (map (text . unpack) comms)
+
 instance HasComments ASTInfo where
   getComments = aiComments
 

tools/lsp/squirrel/src/Pretty.hs

@@ -52,6 +52,9 @@ class Pretty p where
 class Pretty1 p where
   pp1 :: p Doc -> Doc
 
+instance Pretty () where
+  pp _ = "-"
+
 instance (Pretty1 p, Functor p, Pretty a) => Pretty (p a) where
   pp = pp1 . fmap pp
 

tools/lsp/squirrel/src/Stubbed.hs

@@ -1,33 +0,0 @@
-
-module Stubbed
-  ( Stubbed (..)
-  )
-  where
-
-import Control.Lens
-
-import Data.Text (Text, pack)
-
-import Error
-
--- | For types that have a default replacer with an `Error`.
-class Stubbed a where
-  stub :: Error -> a
-
-instance Stubbed Text where
-  stub = pack . show
-
--- | This is bad, but I had to.
---
---   TODO: Find a way to remove this instance.
---         I probably need a wrapper around '[]'.
---
---         Or I need a @fields@ parser combinator.
---
-instance Stubbed [a] where
-  stub = const []
-
--- | Is `Just` `.` @stubbing@.
-instance Stubbed a => Stubbed (Maybe a) where
-  stub = Just . stub
-

tools/lsp/squirrel/src/Tree.hs

@@ -26,10 +26,8 @@ import Union
 import Update
 import Lattice
 import HasComments
-import HasErrors
 import Pretty
 import Error
-import Stubbed
 
 -- | A tree, where each layer is one of @layers@ `Functor`s.
 --
@@ -38,26 +36,27 @@ import Stubbed
 --   Can contain `Error` instead of all the above.
 --
 newtype Tree layers info = Tree
-  { unTree :: Fix (Either Error `Compose` (,) info `Compose` Union layers)
+  { unTree :: Fix (Either (Error info) `Compose` (,) info `Compose` Union layers)
   }
 
 instance (Functor (Union layers)) => Functor (Tree layers) where
   fmap f (Tree fixpoint) = Tree $ cata (Fix . go) fixpoint
     where
-      go (Compose (Left err)) = Compose $ Left err
+      go (Compose (Left err)) = Compose $ Left $ fmap f err
       go (Compose (Right (Compose (a, rest)))) =
         Compose $ Right $ Compose (f a, rest)
 
 instance (Functor (Union layers), Foldable (Union layers)) => Foldable (Tree layers) where
   foldMap f (Tree fixpoint) = cata go fixpoint
     where
-      go (Compose (Left err))                  = mempty
+      go (Compose (Left err))                  = foldMap f err
       go (Compose (Right (Compose (a, rest)))) = f a <> fold rest
 
 instance
-    ( Functor (Union layers)
+    ( Functor    (Union layers)
     , HasComments info
-    , Pretty  (Union layers Doc)
+    , Pretty     (Union layers Doc)
+    , Pretty      info
     )
   =>
     Show (Tree layers info)
@@ -66,8 +65,9 @@ instance
 
 instance {-# OVERLAPS #-}
     ( HasComments info
-    , Functor (Union fs)
-    , Pretty  (Union fs Doc)
+    , Functor    (Union fs)
+    , Pretty     (Union fs Doc)
+    , Pretty      info
     )
   =>
     Pretty (Tree fs info)
@@ -113,7 +113,8 @@ updateTree act = fmap Tree . go . unTree
       return (Fix (Compose (Right (Compose (b, union')))))
 
     go (Fix (Compose (Left err))) = do
-      return (Fix (Compose (Left err)))
+      err' <- traverse act err
+      return (Fix (Compose (Left err')))
 
 -- | Make a tree out of a layer and an info.
 mk :: (Functor f, Member f fs) => info -> f (Tree fs info) -> Tree fs info
@@ -126,10 +127,10 @@ infoOf (Tree (Fix (Compose it))) =
     (const Nothing)
     (Just . fst . getCompose) it
 
-instance Stubbed (Tree fs info) where
+instance Stubbed (Tree fs info) info where
   stub = Tree . Fix . Compose . Left
 
-instance Foldable (Union fs) => HasErrors (Tree fs info) where
+instance Foldable (Union fs) => HasErrors (Tree fs info) info where
   errors = go . unTree
     where
       go (Fix (Compose (Left err))) = pure err