Prevent many/some from making last error-element

tools/lsp/squirrel/app/Main.hs

@@ -4,7 +4,7 @@ import Data.Foldable (for_)
 import ParseTree
 import Parser
 import AST
-import PrettyPrint
+import Pretty
 
 import System.Environment
 

tools/lsp/squirrel/package.yaml

@@ -15,6 +15,7 @@ default-extensions:
 - OverloadedStrings
 - GeneralisedNewtypeDeriving
 - DerivingStrategies
+- DerivingVia
 - NamedFieldPuns
 - BangPatterns
 

tools/lsp/squirrel/squirrel.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 9aa7bb8abf29ee513a2033ae2b0ef8310107294ad348fa7510ec615a1b11c4ea
+-- hash: 265647f1e4ee30432d151c4651a52d5777306a54afa992c70c83d840f87d5365
 
 name:           squirrel
 version:        0.0.0
@@ -14,17 +14,16 @@ library
   exposed-modules:
       AST
       AST.Parser
-      AST.Pretty
       AST.Types
       Parser
       ParseTree
-      PrettyPrint
+      Pretty
       Range
   other-modules:
       Paths_squirrel
   hs-source-dirs:
       src/
-  default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies NamedFieldPuns BangPatterns
+  default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia NamedFieldPuns BangPatterns
   ghc-options: -freverse-errors -Wall
   include-dirs:
       vendor
@@ -45,7 +44,7 @@ executable squirrel
       Paths_squirrel
   hs-source-dirs:
       app/
-  default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies NamedFieldPuns BangPatterns
+  default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia NamedFieldPuns BangPatterns
   ghc-options: -freverse-errors -Wall
   build-depends:
       base

tools/lsp/squirrel/src/AST.hs

@@ -3,4 +3,3 @@ module AST (module M) where
 
 import AST.Types as M
 import AST.Parser as M
-import AST.Pretty ()

tools/lsp/squirrel/src/AST/Parser.hs

@@ -1,5 +1,5 @@
 
-module AST.Parser where
+module AST.Parser (example, contract) where
 
 import Data.Text (Text)
 
@@ -18,7 +18,9 @@ name = do
 contract :: Parser (Contract Range)
 contract = subtree "contract" do
   (decls, info) <- range do
-    many "declaration" declaration
+    gets (length . pfGrove) >>= traceShowM
+    many "declaration" declaration <* (gets (length . pfGrove) >>= traceShowM)
+
   return (Contract info decls)
 
 declaration :: Parser (Declaration Range)

tools/lsp/squirrel/src/AST/Pretty.hs

@@ -1,102 +0,0 @@
-
-module AST.Pretty () where
-
-import AST.Types
-import PrettyPrint
-import Parser
-
-instance Pretty (Contract i) where
-  pp = \case
-    Contract _ decls ->
-      hang "(* contract *)" 2 do
-        vcat $ map (($$ empty) . pp) decls
-
-    WrongContract err ->
-      pp err
-
-instance Pretty (Declaration i) where
-  pp = \case
-    ValueDecl _ binding -> pp binding
-    WrongDecl err       -> pp err
-
-instance Pretty (Binding i) where
-  pp = \case
-    Irrefutable  _ pat expr -> error "irrefs in pascaligo?"
-    Function     _ isRec name params ty body ->
-      hang
-        ( fsep
-          [ if isRec then "recursive" else empty
-          , "function"
-          , pp name
-          , parens $ fsep $ punctuate "," $ map pp params
-          , ":"
-          , pp ty
-          , "is"
-          ]
-        )
-        2
-        (pp body)
-    WrongBinding err ->
-      pp err
-
-instance Pretty (VarDecl i) where
-  pp = \case
-    Decl _ mutability name ty -> fsep
-      [ pp mutability
-      , pp name
-      , ":"
-      , pp ty
-      ]
-    WrongVarDecl err ->
-      pp err
-
-instance Pretty (Mutable i) where
-  pp = \case
-    Mutable      _   -> "var"
-    Immutable    _   -> "const"
-    WrongMutable err -> pp err
-
-instance Pretty (Type i) where
-  pp = \case
-    TArrow    _ dom codom -> parens (pp dom <+> "->" <+> pp codom)
-    Record    _ fields    -> wrap ["record [", "]"] $ vcat $ map ppField fields
-    TVar      _ name      -> pp name
-    Sum       _ variants  -> vcat $ map ppCtor variants
-    Product   _ elements  -> fsep $ punctuate " *" $ map pp elements
-    TApply    _ f xs      -> pp f <> parens (fsep $ punctuate "," $ map pp xs)
-    WrongType   err       -> pp err
-    where
-      ppField (name, ty) = pp name <> ": " <> pp ty <> ";"
-      ppCtor  (ctor, fields) =
-        "|" <+> pp ctor <+> parens (fsep $ punctuate "," $ map pp fields)
-
-instance Pretty (Expr i) where
-  pp = \case
-    Let       _ decls body -> hang "let" 2 (vcat $ map pp decls)
-                           <> hang "in"  2 (pp body)
-    Apply     _ f xs       -> pp f <> parens (fsep $ punctuate "," $ map pp xs)
-    Constant  _ constant   -> pp constant
-    Ident     _ qname      -> pp qname
-    WrongExpr   err        -> pp err
-
-
-instance Pretty (Constant i) where
-  pp = \case
-    Int           _ c   -> int c
-    String        _ c   -> doubleQuotes (pp c)
-    Float         _ c   -> double c
-    Bytes         _ c   -> pp c
-    WrongConstant   err -> pp err
-
-instance Pretty (QualifiedName i) where
-  pp = \case
-    QualifiedName _ src path -> pp src <> cat (map (("." <>) . pp) path)
-    WrongQualifiedName err   -> pp err
-
-
-instance Pretty (Name i) where
-  pp = \case
-    Name      _ raw -> pp raw
-    WrongName err   -> pp err
-
-wrap [l, r] a = hang (hang l 2 r) 0 r

tools/lsp/squirrel/src/AST/Types.hs

@@ -11,6 +11,7 @@ import Data.Void
 
 import Parser
 import ParseTree
+import Pretty
 
 import Debug.Trace
 
@@ -19,14 +20,14 @@ type TODO = Text
 data Contract info
   = Contract      info [Declaration info]
   | WrongContract      Error
-  deriving stock (Show)
+  deriving (Show) via PP (Contract info)
 
 instance Stubbed (Contract info) where stub = WrongContract
 
 data Declaration info
   = ValueDecl info (Binding info)
   | WrongDecl      Error
-  deriving stock (Show)
+  deriving (Show) via PP (Declaration info)
 
 instance Stubbed (Declaration info) where stub = WrongDecl
 
@@ -34,14 +35,14 @@ data Binding info
   = Irrefutable  info (Pattern info) (Expr info)
   | Function     info Bool (Name info) [VarDecl info] (Type info) (Expr info)
   | WrongBinding      Error
-  deriving stock (Show)
+  deriving (Show) via PP (Binding info)
 
 instance Stubbed (Binding info) where stub = WrongBinding
 
 data VarDecl info
   = Decl         info (Mutable info) (Name info) (Type info)
   | WrongVarDecl      Error
-  deriving stock (Show)
+  deriving (Show) via PP (VarDecl info)
 
 instance Stubbed (VarDecl info) where stub = WrongVarDecl
 
@@ -49,7 +50,8 @@ data Mutable info
   = Mutable      info
   | Immutable    info
   | WrongMutable      Error
-  deriving stock (Show)
+  deriving (Show) via PP (Mutable info)
+
 
 instance Stubbed (Mutable info) where stub = WrongMutable
 
@@ -61,7 +63,7 @@ data Type info
   | Product   info  [Type info]
   | TApply    info  (Name info) [Type info]
   | WrongType      Error
-  deriving stock (Show)
+  deriving (Show) via PP (Type info)
 
 instance Stubbed (Type info) where stub = WrongType
 
@@ -71,7 +73,7 @@ data Expr info
   | Constant  info (Constant info)
   | Ident     info (QualifiedName info)
   | WrongExpr      Error
-  deriving stock (Show)
+  deriving (Show) via PP (Expr info)
 
 instance Stubbed (Expr info) where stub = WrongExpr
 
@@ -81,7 +83,7 @@ data Constant info
   | Float   info Double
   | Bytes   info Text
   | WrongConstant Error
-  deriving stock (Show)
+  deriving (Show) via PP (Constant info)
 
 instance Stubbed (Constant info) where stub = WrongConstant
 
@@ -90,7 +92,7 @@ data Pattern info
   | IsConstant   info (Constant info)
   | IsVar        info (Name info)
   | WrongPattern      Error
-  deriving stock (Show)
+  deriving (Show) via PP (Pattern info)
 
 instance Stubbed (Pattern info) where stub = WrongPattern
 
@@ -101,7 +103,7 @@ data QualifiedName info
     , qnPath   :: [Name info]
     }
   | WrongQualifiedName Error
-  deriving stock (Show)
+  deriving (Show) via PP (QualifiedName info)
 
 instance Stubbed (QualifiedName info) where stub = WrongQualifiedName
 
@@ -117,3 +119,107 @@ instance Show (Name info) where
   show = \case
     Name _ raw  -> Text.unpack raw
     WrongName r -> "(Name? " ++ show r ++ ")"
+
+instance Pretty (Contract i) where
+  pp = \case
+    Contract _ decls ->
+      hang "(* contract *)" 2 do
+        vcat $ map (($$ empty) . pp) decls
+
+    WrongContract err ->
+      pp err
+
+instance Pretty (Declaration i) where
+  pp = \case
+    ValueDecl _ binding -> pp binding
+    WrongDecl err       -> pp err
+
+instance Pretty (Binding i) where
+  pp = \case
+    Irrefutable  _ pat expr -> error "irrefs in pascaligo?"
+    Function     _ isRec name params ty body ->
+      hang
+        ( fsep
+          [ if isRec then "recursive" else empty
+          , "function"
+          , pp name
+          , tuple params
+          , ":"
+          , pp ty
+          , "is"
+          ]
+        )
+        2
+        (pp body)
+    WrongBinding err ->
+      pp err
+
+instance Pretty (VarDecl i) where
+  pp = \case
+    Decl _ mutability name ty -> fsep
+      [ pp mutability
+      , pp name
+      , ":"
+      , pp ty
+      ]
+    WrongVarDecl err ->
+      pp err
+
+instance Pretty (Mutable i) where
+  pp = \case
+    Mutable      _   -> "var"
+    Immutable    _   -> "const"
+    WrongMutable err -> pp err
+
+instance Pretty (Type i) where
+  pp = \case
+    TArrow    _ dom codom -> parens (pp dom <+> "->" <+> pp codom)
+    Record    _ fields    -> wrap ["record [", "]"] $ vcat $ map ppField fields
+    TVar      _ name      -> pp name
+    Sum       _ variants  -> vcat $ map ppCtor variants
+    Product   _ elements  -> fsep $ punctuate " *" $ map pp elements
+    TApply    _ f xs      -> pp f <> parens (fsep $ punctuate "," $ map pp xs)
+    WrongType   err       -> pp err
+    where
+      ppField (name, ty) = pp name <> ": " <> pp ty <> ";"
+      ppCtor  (ctor, fields) =
+        "|" <+> pp ctor <+> parens (fsep $ punctuate "," $ map pp fields)
+
+instance Pretty (Expr i) where
+  pp = \case
+    Let       _ decls body -> hang "let" 2 (vcat $ map pp decls)
+                           <> hang "in"  2 (pp body)
+    Apply     _ f xs       -> pp f <> tuple xs
+    Constant  _ constant   -> pp constant
+    Ident     _ qname      -> pp qname
+    WrongExpr   err        -> pp err
+
+
+instance Pretty (Constant i) where
+  pp = \case
+    Int           _ c   -> int c
+    String        _ c   -> doubleQuotes (pp c)
+    Float         _ c   -> double c
+    Bytes         _ c   -> pp c
+    WrongConstant   err -> pp err
+
+instance Pretty (QualifiedName i) where
+  pp = \case
+    QualifiedName _ src path -> pp src <> cat (map (("." <>) . pp) path)
+    WrongQualifiedName err   -> pp err
+
+instance Pretty (Pattern info) where
+  pp = \case
+    IsConstr     _ ctor args -> pp ctor <> tuple args
+    IsConstant   _ c         -> pp c
+    IsVar        _ name      -> pp name
+    WrongPattern   err       -> pp err
+
+
+instance Pretty (Name i) where
+  pp = \case
+    Name      _ raw -> pp raw
+    WrongName err   -> pp err
+
+tuple :: Pretty p => [p] -> Doc
+tuple xs = parens (fsep $ punctuate "," $ map pp xs)

tools/lsp/squirrel/src/ParseTree.hs

@@ -30,7 +30,7 @@ import Text.PrettyPrint hiding ((<>))
 import Paths_squirrel
 
 import Range
-import PrettyPrint
+import Pretty
 
 -- import Debug.Trace
 

tools/lsp/squirrel/src/Parser.hs

@@ -1,5 +1,5 @@
 
-module Parser where
+module Parser (module Parser, gets, pfGrove) where
 
 import Control.Monad.State
 import Control.Monad.Writer
@@ -7,6 +7,7 @@ import Control.Monad.Reader
 import Control.Monad.Except
 import Control.Monad.Identity
 
+import Data.Foldable
 import Data.Text.Encoding
 import Data.Text (Text, pack, unpack)
 
@@ -15,7 +16,7 @@ import Data.ByteString (ByteString)
 
 import ParseTree
 import Range
-import PrettyPrint
+import Pretty
 
 import Debug.Trace
 
@@ -28,8 +29,7 @@ data Error
   deriving stock (Show)
 
 instance Pretty Error where
-  pp (Expected msg found r) = "<" <> pp msg <> pp r <> ": " <> pp found <> ">"
-
+  pp (Expected msg found r) = "<<<" <> pp msg <> pp r <> ": " <> pp found <> ">>>"
 
 newtype Parser a = Parser
   { unParser
@@ -37,7 +37,7 @@ newtype Parser a = Parser
       (  ReaderT ParserEnv
       (  StateT  ParseForest
       (  ExceptT Error
-      (  Identity ))))
+      (  IO ))))
          a
   }
   deriving newtype
@@ -48,6 +48,7 @@ newtype Parser a = Parser
     , MonadWriter [Error]
     , MonadReader  ParserEnv
     , MonadError   Error
+    , MonadIO
     )
 
 makeError :: Text -> Parser Error
@@ -145,6 +146,7 @@ many msg p = many'
   where
     many' = some' <|> pure []
     some' = do
+      hasPossibleInput
       (x, consumed) <- productive p
       if consumed then do
         xs <- many'
@@ -157,6 +159,7 @@ some msg p = some'
   where
     many' = some' <|> pure []
     some' = do
+      hasPossibleInput
       (x, consumed) <- productive p
       if consumed then do
         xs <- many'
@@ -177,26 +180,41 @@ productive p = do
   now <- getTreeID
   return (res, was /= now)
 
+hasPossibleInput :: Parser ()
+hasPossibleInput = do
+  yes <- gets (not . null . pfGrove)
+  unless yes do
+    die "something"
+
 data ParserEnv = ParserEnv
-  { peRange  :: Range
-  , peSource :: ByteString
+  { peSource :: ByteString
   }
 
+puts :: MonadIO m => Show a => a -> m ()
+puts = liftIO . print
+
 runParser :: Parser a -> FilePath -> IO (a, [Error])
 runParser (Parser parser) fin = do
   pforest <- toParseTree fin
   text    <- ByteString.readFile fin
-  let
-    res
-      =      runIdentity
-      $      runExceptT
+  res <-
+             runExceptT
       $ flip runStateT pforest
-      $ flip runReaderT (ParserEnv (pfRange pforest) text)
+      $ flip runReaderT (ParserEnv text)
       $      runWriterT
       $ parser
 
   either (error . show) (return . fst) res
 
+debugParser :: Parser a -> FilePath -> IO a
+debugParser parser fin = do
+  (res, errs) <- runParser parser fin
+  putStrLn "Errors:"
+  for_ errs (print . nest 2 . pp)
+  putStrLn ""
+  putStrLn "Result:"
+  return res
+
 token :: Text -> Parser Text
 token node = do
   tree@ParseTree {ptName, ptRange} <- takeNext node

tools/lsp/squirrel/src/Pretty.hs

@@ -0,0 +1,23 @@
+
+module Pretty
+  ( module Pretty
+  , module Text.PrettyPrint
+  )
+  where
+
+import Data.Text
+
+import Text.PrettyPrint hiding ((<>))
+
+newtype PP a = PP { unPP :: a }
+
+instance Pretty a => Show (PP a) where
+  show = show . pp . unPP
+
+class Pretty p where
+  pp :: p -> Doc
+
+instance Pretty Text where
+  pp = text . unpack
+
+wrap [l, r] a = hang (hang l 2 r) 0 r

tools/lsp/squirrel/src/PrettyPrint.hs

@@ -1,16 +0,0 @@
-
-module PrettyPrint
-  ( module PrettyPrint
-  , module Text.PrettyPrint
-  )
-  where
-
-import Data.Text
-
-import Text.PrettyPrint hiding ((<>))
-
-class Pretty p where
-  pp :: p -> Doc
-
-instance Pretty Text where
-  pp = text . unpack

tools/lsp/squirrel/src/Range.hs

@@ -1,13 +1,13 @@
 
 module Range where
 
-import PrettyPrint
+import Pretty
 
 data Range = Range
   { rStart  :: (Int, Int, Int)
   , rFinish :: (Int, Int, Int)
   }
-  deriving stock (Show)
+  deriving (Show) via PP Range
 
 diffRange :: Range -> Range -> Range
 diffRange (Range ws wf) (Range ps _) = Range (max ws ps) wf