Prevent many/some from making last error-element

This commit is contained in:
Kirill Andreev 2020-05-01 19:04:29 +04:00
parent 00b4dabe36
commit 0cec59988e
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
12 changed files with 182 additions and 152 deletions

View File

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

View File

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

View File

@ -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

View File

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

View File

@ -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)

View File

@ -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

View File

@ -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)

View File

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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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