diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 3fd5b5d06..65291fac8 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/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 diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index ad8ab1f84..9cbd68da1 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -15,6 +15,7 @@ default-extensions: - OverloadedStrings - GeneralisedNewtypeDeriving - DerivingStrategies +- DerivingVia - NamedFieldPuns - BangPatterns diff --git a/tools/lsp/squirrel/squirrel.cabal b/tools/lsp/squirrel/squirrel.cabal index 5d65b8a13..f54d21ec3 100644 --- a/tools/lsp/squirrel/squirrel.cabal +++ b/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 diff --git a/tools/lsp/squirrel/src/AST.hs b/tools/lsp/squirrel/src/AST.hs index aa05217c7..5b11b277e 100644 --- a/tools/lsp/squirrel/src/AST.hs +++ b/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 () \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index 1cdad1e35..8ffc22e5d 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/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) diff --git a/tools/lsp/squirrel/src/AST/Pretty.hs b/tools/lsp/squirrel/src/AST/Pretty.hs deleted file mode 100644 index 16efc53fa..000000000 --- a/tools/lsp/squirrel/src/AST/Pretty.hs +++ /dev/null @@ -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 \ No newline at end of file diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs index 31af78534..888156706 100644 --- a/tools/lsp/squirrel/src/AST/Types.hs +++ b/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) \ No newline at end of file diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index f71acbf71..daeebf75f 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/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 diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 4f48b559f..378fb9e23 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/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 diff --git a/tools/lsp/squirrel/src/Pretty.hs b/tools/lsp/squirrel/src/Pretty.hs new file mode 100644 index 000000000..888980a5e --- /dev/null +++ b/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 \ No newline at end of file diff --git a/tools/lsp/squirrel/src/PrettyPrint.hs b/tools/lsp/squirrel/src/PrettyPrint.hs deleted file mode 100644 index cb96ac958..000000000 --- a/tools/lsp/squirrel/src/PrettyPrint.hs +++ /dev/null @@ -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 \ No newline at end of file diff --git a/tools/lsp/squirrel/src/Range.hs b/tools/lsp/squirrel/src/Range.hs index ef89b9906..0301112cf 100644 --- a/tools/lsp/squirrel/src/Range.hs +++ b/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