From 90a9594e8f8a55c2cf071b7e6c4aebc74a079341 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 9 Jan 2024 14:24:51 -0700 Subject: [PATCH] where --- src/RLP/Parse/Decls.hs | 93 ++++++++++++++++++++++++++++++++---------- src/RLP/Parse/Types.hs | 7 ---- src/RLP/Parse/Utils.hs | 30 ++++++++++++++ src/RLP/Syntax.hs | 24 +++++++---- 4 files changed, 119 insertions(+), 35 deletions(-) create mode 100644 src/RLP/Parse/Utils.hs diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 87668aa..8a95f41 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -18,6 +18,7 @@ import Data.Functor.Foldable import Data.Text (Text) import Data.Text qualified as T import Data.HashMap.Strict qualified as H +import Data.Maybe (maybeToList) import Data.List (foldl1') import Data.Char import Data.Functor @@ -26,6 +27,7 @@ import Data.Fix hiding (cata) import Lens.Micro import Lens.Micro.Platform import Rlp.Parse.Types +import Rlp.Parse.Utils import Rlp.Syntax ---------------------------------------------------------------------------------- @@ -39,6 +41,9 @@ parseTest' p s = case runState (runParserT p "test" s) init of lexeme :: Parser a -> Parser a lexeme = L.lexeme sc +flexeme :: Parser a -> Parser a +flexeme p = L.lineFold scn $ \sc' -> L.lexeme sc' p + symbol :: Text -> Parser Text symbol = L.symbol sc @@ -66,7 +71,16 @@ decl = choice ] funD :: Parser PartialDecl' -funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr) +funD = FunD <$> flexeme varid <*> params <*> (symbol "=" *> body) <*> whereClause + where + params = many pat1 + body = fmap Const partialExpr + +whereClause :: Parser Where' +whereClause = optionalList $ + flexeme "where" *> pure + [ FunB "fixme" [] (VarE "fixme") + ] standalonePartialExpr :: Parser PartialExpr' standalonePartialExpr = standaloneOf partialExpr @@ -75,7 +89,7 @@ standaloneOf :: Parser a -> Parser a standaloneOf = (<* eof) partialExpr :: Parser PartialExpr' -partialExpr = (choice . fmap foldedLexeme) +partialExpr = (choice . fmap flexeme) [ try application , Fix <$> infixExpr ] @@ -87,17 +101,14 @@ partialExpr = (choice . fmap foldedLexeme) mkB a f b = B f a b partialExpr1' = unFix <$> partialExpr1 partialExpr' = unFix <$> partialExpr - infixOp' = foldedLexeme infixOp + infixOp' = flexeme infixOp mkApp :: PartialExpr' -> PartialExpr' -> PartialExpr' mkApp f x = Fix . E $ f `AppEF` x -foldedLexeme :: Parser a -> Parser a -foldedLexeme p = L.lineFold scn $ \sc' -> L.lexeme sc' p - partialExpr1 :: Parser PartialExpr' -partialExpr1 = (choice . fmap foldedLexeme) - [ foldedLexeme "(" *> partialExpr' <* foldedLexeme ")" +partialExpr1 = (choice . fmap flexeme) + [ try $ flexeme "(" *> partialExpr' <* flexeme ")" , Fix <$> varid' , Fix <$> lit' ] @@ -108,7 +119,7 @@ partialExpr1 = (choice . fmap foldedLexeme) lit' = E . LitEF <$> lit infixOp :: Parser Name -infixOp = symvar <|> symcon "infix operator" +infixOp = symvar <|> symcon "operator" symvar :: Parser Name symvar = T.pack <$> @@ -119,20 +130,34 @@ symcon = T.pack <$> liftA2 (:) (char ':') (many $ satisfy isSym) pat1 :: Parser Pat' -pat1 = VarP <$> varid +pat1 = VarP <$> flexeme varid "pattern" +conid :: Parser ConId +conid = NameCon <$> lexeme namecon + <|> SymCon <$> lexeme (char '(' *> symcon <* char ')') + "constructor identifier" + +namecon :: Parser Name +namecon = T.pack <$> + liftA2 (:) (satisfy isUpper) + (many $ satisfy isNameTail) + varid :: Parser VarId -varid = NameVar <$> lexeme namevar +varid = NameVar <$> try (lexeme namevar) <|> SymVar <$> lexeme (char '(' *> symvar <* char ')') "variable identifier" - where - namevar = T.pack <$> + +namevar :: Parser Name +namevar = try word + & withPredicate (`notElem` ["where"]) empty + where word = T.pack <$> liftA2 (:) (satisfy isLower) (many $ satisfy isNameTail) - isNameTail c = isAlphaNum c - || c == '\'' - || c == '_' +isNameTail :: Char -> Bool +isNameTail c = isAlphaNum c + || c == '\'' + || c == '_' isVarSym :: Char -> Bool isVarSym = (`T.elem` "\\!#$%&*+./<=>?@^|-~") @@ -159,7 +184,7 @@ infixD = do prec :: Parser Int prec = do o <- getOffset - n <- lexeme L.decimal + n <- lexeme L.decimal "precedence level (an integer)" if 0 <= n && n <= 9 then pure n else @@ -173,10 +198,36 @@ infixD = do psOpTable <~ H.alterF f op t where f Nothing = pure (Just (a,p)) - f (Just _) = customFailure RlpParErrDuplicateInfixD + f (Just x) = registerCustomFailure RlpParErrDuplicateInfixD + $> Just x tySigD = undefined -dataD = undefined + +dataD :: Parser (Decl' e) +dataD = DataD <$> (flexeme "data" *> conid) <*> many typaram + <*> optionalList (symbol "=" *> conalts) + where + typaram :: Parser Name + typaram = flexeme namevar + + conalts :: Parser [ConAlt] + conalts = (:) <$> conalt <*> optionalList (symbol "|" *> conalts) + + conalt :: Parser ConAlt + conalt = ConAlt <$> conid <*> many type1 + +type1 :: Parser Type +type1 = (choice . fmap flexeme) + [ flexeme "(" *> type_ <* flexeme ")" + , TyVar <$> namevar + , TyCon <$> namecon + ] + +type_ :: Parser Type +type_ = (choice . fmap flexeme) + [ try $ (:->) <$> type1 <*> (flexeme "->" *> type_) + , type1 + ] lit :: Parser Lit' lit = int @@ -184,9 +235,9 @@ lit = int where int = IntL <$> L.decimal ----------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- completing partial expressions --- complete :: OpTable -> Fix Partial -> RlpExpr' complete :: (?pt :: OpTable) => PartialExpr' -> RlpExpr' complete = cata completePartial diff --git a/src/RLP/Parse/Types.hs b/src/RLP/Parse/Types.hs index 16a0ed9..e961d2d 100644 --- a/src/RLP/Parse/Types.hs +++ b/src/RLP/Parse/Types.hs @@ -22,9 +22,6 @@ module Rlp.Parse.Types , RlpParseError(..) , OpTable , OpInfo - - -- * Extras - , registerCustomFailure ) where ---------------------------------------------------------------------------------- @@ -36,7 +33,6 @@ import Data.Functor.Const import Data.Functor.Classes import Data.Void import Data.Maybe -import Data.Set qualified as S import Text.Megaparsec hiding (State) import Text.Printf import Lens.Micro @@ -121,6 +117,3 @@ type PartialExpr' = Fix Partial makeLenses ''ParserState -registerCustomFailure :: MonadParsec e s m => e -> m () -registerCustomFailure = registerFancyFailure . S.singleton . ErrorCustom - diff --git a/src/RLP/Parse/Utils.hs b/src/RLP/Parse/Utils.hs new file mode 100644 index 0000000..cf5fb8c --- /dev/null +++ b/src/RLP/Parse/Utils.hs @@ -0,0 +1,30 @@ +module Rlp.Parse.Utils + ( withPredicate + , registerCustomFailure + , optionalList + ) + where +-------------------------------------------------------------------------------- +import Text.Megaparsec +import Rlp.Parse.Types +import Data.Set qualified as S +import Data.Maybe +import Control.Monad +-------------------------------------------------------------------------------- + +-- TODO: generalise type sig +withPredicate :: (a -> Bool) + -> Parser a -- ^ action to run should the predicate fail + -> Parser a + -> Parser a +withPredicate f r p = do + o <- getOffset + a <- p + if f a then pure a else setOffset o *> r + +registerCustomFailure :: MonadParsec e s m => e -> m () +registerCustomFailure = registerFancyFailure . S.singleton . ErrorCustom + +optionalList :: Parser [a] -> Parser [a] +optionalList = fmap (join . maybeToList) . optional + diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index 4a43cb9..09acb8b 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -2,7 +2,7 @@ {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -- recursion-schemes {-# LANGUAGE TemplateHaskell, TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, PatternSynonyms #-} module Rlp.Syntax ( RlpExpr(..) , RlpExpr' @@ -10,8 +10,15 @@ module Rlp.Syntax , RlpExprF' , Decl(..) , Decl' + , Bind(..) + , Where + , Where' + , ConAlt(..) + , Type(..) + , pattern (:->) , Assoc(..) , VarId(..) + , ConId(..) , Pat(..) , Pat' , Lit(..) @@ -45,9 +52,9 @@ newtype RlpProgram b = RlpProgram [Decl RlpExpr b] -- accounted for, we may complete the parsing task and get a proper @[Decl -- RlpExpr Name]@. -data Decl e b = FunD VarId [Pat b] (e b) +data Decl e b = FunD VarId [Pat b] (e b) (Where b) | TySigD [VarId] Type - | DataD ConId [ConId] [ConAlt] + | DataD ConId [Name] [ConAlt] | InfixD Assoc Int Name deriving Show @@ -58,14 +65,14 @@ data Assoc = InfixL | Infix deriving Show -data ConAlt = ConAlt ConId [ConId] - deriving Show +data ConAlt = ConAlt ConId [Type] + deriving Show data RlpExpr b = LetE [Bind b] (RlpExpr b) | VarE VarId | ConE ConId | LamE [Pat b] (RlpExpr b) - | CaseE (RlpExpr b) [Alt b] + | CaseE (RlpExpr b) [(Alt b, Where b)] | IfE (RlpExpr b) (RlpExpr b) (RlpExpr b) | AppE (RlpExpr b) (RlpExpr b) | LitE (Lit b) @@ -73,9 +80,12 @@ data RlpExpr b = LetE [Bind b] (RlpExpr b) type RlpExpr' = RlpExpr Name +type Where b = [Bind b] +type Where' = [Bind Name] + -- do we want guards? data Alt b = AltA (Pat b) (RlpExpr b) - deriving Show + deriving Show data Bind b = PatB (Pat b) (RlpExpr b) | FunB VarId [Pat b] (RlpExpr b)