From 9b95006a71a636619577321cbc56da8d9fb3a903 Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Thu, 4 Jun 2020 16:29:06 +0400 Subject: [PATCH] Make Error a Functor; move all Error stuff to Error.hs --- tools/lsp/squirrel/app/Main.hs | 5 ++- tools/lsp/squirrel/package.yaml | 2 ++ tools/lsp/squirrel/squirrel.cabal | 10 +++--- tools/lsp/squirrel/src/Error.hs | 40 ++++++++++++++++++++---- tools/lsp/squirrel/src/HasErrors.hs | 10 ------ tools/lsp/squirrel/src/Parser.hs | 48 +++++++++++++++-------------- tools/lsp/squirrel/src/Pretty.hs | 3 ++ tools/lsp/squirrel/src/Stubbed.hs | 33 -------------------- tools/lsp/squirrel/src/Tree.hs | 25 +++++++-------- 9 files changed, 83 insertions(+), 93 deletions(-) delete mode 100644 tools/lsp/squirrel/src/HasErrors.hs delete mode 100644 tools/lsp/squirrel/src/Stubbed.hs diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 4a598852d..4dc2b40ee 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/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) diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index 7e2df4fe5..ea5510d0a 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -36,6 +36,8 @@ default-extensions: - TypeFamilies - TypeOperators - UndecidableInstances + - FunctionalDependencies + - ViewPatterns ghc-options: -freverse-errors -Wall -threaded diff --git a/tools/lsp/squirrel/squirrel.cabal b/tools/lsp/squirrel/squirrel.cabal index 4c26925cc..6463c1fd9 100644 --- a/tools/lsp/squirrel/squirrel.cabal +++ b/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 diff --git a/tools/lsp/squirrel/src/Error.hs b/tools/lsp/squirrel/src/Error.hs index a35ab2a0c..ac04cc125 100644 --- a/tools/lsp/squirrel/src/Error.hs +++ b/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 diff --git a/tools/lsp/squirrel/src/HasErrors.hs b/tools/lsp/squirrel/src/HasErrors.hs deleted file mode 100644 index 14be7d3bf..000000000 --- a/tools/lsp/squirrel/src/HasErrors.hs +++ /dev/null @@ -1,10 +0,0 @@ -module HasErrors - ( HasErrors(..) - ) - where - -import Error - --- | Ability to contain `Error`s. -class HasErrors h where - errors :: h -> [Error] diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 263371344..f8f5667bb 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/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 diff --git a/tools/lsp/squirrel/src/Pretty.hs b/tools/lsp/squirrel/src/Pretty.hs index 2c5330853..75b017cec 100644 --- a/tools/lsp/squirrel/src/Pretty.hs +++ b/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 diff --git a/tools/lsp/squirrel/src/Stubbed.hs b/tools/lsp/squirrel/src/Stubbed.hs deleted file mode 100644 index 28e9203f9..000000000 --- a/tools/lsp/squirrel/src/Stubbed.hs +++ /dev/null @@ -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 - diff --git a/tools/lsp/squirrel/src/Tree.hs b/tools/lsp/squirrel/src/Tree.hs index 63b1af450..e4ec448d0 100644 --- a/tools/lsp/squirrel/src/Tree.hs +++ b/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