From 7ed565fc240230961ef3a165ca4c8d0817763a03 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 2 Jan 2024 02:33:31 -0700 Subject: [PATCH 01/21] grammar reference --- doc/src/conf.py | 1 + doc/src/references/rlp-grammar.rst | 67 ++++++++++++++++++++++++++++++ 2 files changed, 68 insertions(+) create mode 100644 doc/src/references/rlp-grammar.rst diff --git a/doc/src/conf.py b/doc/src/conf.py index d344334..533296a 100644 --- a/doc/src/conf.py +++ b/doc/src/conf.py @@ -32,6 +32,7 @@ html_theme = 'alabaster' imgmath_latex_preamble = r''' \usepackage{amsmath} \usepackage{tabularray} +\usepackage{syntax} \newcommand{\transrule}[2] {\begin{tblr}{|rrrlc|} diff --git a/doc/src/references/rlp-grammar.rst b/doc/src/references/rlp-grammar.rst new file mode 100644 index 0000000..c81fea7 --- /dev/null +++ b/doc/src/references/rlp-grammar.rst @@ -0,0 +1,67 @@ +The Complete Syntax of rl' +========================== + +WIP. + +Provided is the complete syntax of rl' in (pseudo) EBNF. {A} represents zero or +more A's, [A] means optional A, and terminals are wrapped in 'single-quotes'. + +.. math + :nowrap: + + \setlength{\grammarparsep}{20pt plus 1pt minus 1pt} + \setlength{\grammarindent}{12em} + \begin{grammar} + ::= + \alt + \alt + \alt + + ::= `litint' + ::= `infix' + \alt `infixl' + \alt `infixr' + + ::= `data' `conname' {} + + \end{grammar} + +.. code-block:: bnf + + Decl ::= InfixDecl + | DataDecl + | TypeSig + | FunDef + + InfixDecl ::= InfixWord 'litint' Operator + InfixWord ::= 'infix' + | 'infixl' + | 'infixr' + + DataDecl ::= 'data' 'conname' {'name'} '=' Data + DataCons ::= 'conname' {Type1} ['|' DataCons] + + TypeSig ::= Var '::' Type + FunDef ::= Var {Pat1} '=' Expr + + Type ::= Type1 {Type1} + -- note that (->) is right-associative, + -- and extends as far as possible + | Type '->' Type + Type1 ::= '(' Type ')' + | 'conname' + + Pat ::= 'conname' Pat1 {Pat1} + | Pat 'consym' Pat + + Pat1 ::= Literal + | 'conname' + | '(' Pat ')' + + Literal ::= 'litint' + + Var ::= 'varname' + | '(' 'varsym' ')' + Con ::= 'conname' + | '(' 'consym' ')' + From bf4abeb8b4a2f80e8aed42a6cf7cb64ecba1d4da Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 2 Jan 2024 05:34:11 -0700 Subject: [PATCH 02/21] 4:00 AM psychopath code --- rlp.cabal | 3 +- src/RLP/ParseDecls.hs | 139 ++++++++++++++++++++++++++++++++++++++++++ src/RLP/Syntax.hs | 65 +++++++++++++++++--- 3 files changed, 198 insertions(+), 9 deletions(-) create mode 100644 src/RLP/ParseDecls.hs diff --git a/rlp.cabal b/rlp.cabal index 660a3d8..b960ec6 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -30,6 +30,8 @@ library , Core.TH , Core.HindleyMilner , Control.Monad.Errorful + , Rlp.Syntax + , Rlp.ParseDecls other-modules: Data.Heap , Data.Pretty @@ -37,7 +39,6 @@ library , Core.Lex , Core2Core , Control.Monad.Utils - , RLP.Syntax build-tool-depends: happy:happy, alex:alex diff --git a/src/RLP/ParseDecls.hs b/src/RLP/ParseDecls.hs new file mode 100644 index 0000000..4d18e22 --- /dev/null +++ b/src/RLP/ParseDecls.hs @@ -0,0 +1,139 @@ +-- Show Y +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +module Rlp.ParseDecls + ( + ) + where +---------------------------------------------------------------------------------- +import Rlp.Syntax +import Text.Megaparsec hiding (State) +import Text.Megaparsec.Char +import Text.Megaparsec.Char.Lexer qualified as L +import Data.Functor.Const +import Data.Text (Text) +import Data.Text qualified as T +import Data.Void +import Data.Char +import Data.Functor +import Data.HashMap.Strict qualified as H +import Control.Monad +import Core.Syntax +import Control.Monad.State +---------------------------------------------------------------------------------- + +type Parser = ParsecT Void Text (State ParserState) + +data ParserState = ParserState + { _psPrecTable :: PrecTable + } + deriving Show + +type PrecTable = H.HashMap Name (Assoc, Int) + +---------------------------------------------------------------------------------- + +parseTest' :: (Show a) => Parser a -> Text -> IO () +parseTest' p s = case runState (runParserT p "test" s) init of + (Left e, _) -> putStr (errorBundlePretty e) + (Right x, st) -> print st *> print x + where + init = ParserState mempty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: Text -> Parser Text +symbol = L.symbol sc + +sc :: Parser () +sc = L.space space1 (void lineComment) (void blockComment) + +-- TODO: return comment text +-- TODO: '---' should not start a comment +lineComment :: Parser Text +lineComment = L.skipLineComment "--" $> "" + +-- TODO: return comment text +blockComment :: Parser Text +blockComment = L.skipBlockCommentNested "{-" "-}" $> "" + +decl :: Parser PartialDecl' +decl = choice + [ funD + , tySigD + , dataD + , infixD + ] + +funD :: Parser PartialDecl' +funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr) + +partialExpr :: Parser PartialExpr' +partialExpr = choice + [ fmap Y $ U <$> varid' <*> lexeme infixOp <*> varid' + ] + where varid' = E . VarEF <$> varid + + +infixOp :: Parser Name +infixOp = symvar <|> symcon + +symvar :: Parser Name +symvar = T.pack <$> + liftA2 (:) (satisfy isVarSym) (many $ satisfy isSym) + +symcon :: Parser Name +symcon = T.pack <$> + liftA2 (:) (char ':') (many $ satisfy isSym) + +-- partialExpr :: Parser (Const Text a) +-- partialExpr = fmap Const $ L.lineFold w $ \w' -> +-- try w' <> w +-- where +-- w = L.space eat (void lineComment) (void blockComment) +-- eat = void . some $ satisfy (not . isSpace) + +pat1 :: Parser Pat' +pat1 = VarP <$> varid + +varid :: Parser VarId +varid = NameVar <$> lexeme namevar + <|> SymVar <$> lexeme (char '(' *> symvar <* char ')') + "variable identifier" + where + namevar = T.pack <$> + liftA2 (:) (satisfy isLower) (many $ satisfy isNameTail) + + isNameTail c = isAlphaNum c + || c == '\'' + || c == '_' + +isVarSym :: Char -> Bool +isVarSym = (`T.elem` "\\!#$%&*+./<=>?@^|-~") + +isSym :: Char -> Bool +isSym c = c == ':' || isVarSym c + +infixD = undefined + +tySigD = undefined +dataD = undefined + +---------------------------------------------------------------------------------- + +-- absolute psycho shit + +type PartialDecl' = Decl (Const PartialExpr') Name + +newtype Y f = Y (f (Y f)) + +instance (Show (f (Y f))) => Show (Y f) where + showsPrec p (Y f) = showsPrec p f + +data Partial a = E (RlpExprF Name a) + | U (Partial a) Name (Partial a) + deriving Show + +type PartialExpr' = Y Partial + diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index 6efdc4e..9e5c53b 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -1,23 +1,52 @@ +-- recursion-schemes +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +-- recursion-schemes +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} -module RLP.Syntax - ( RlpExpr +module Rlp.Syntax + ( RlpExpr(..) + , RlpExprF(..) + , RlpExprF' + , Decl(..) + , Assoc(..) + , VarId(..) + , Pat(..) + , Pat' ) where ---------------------------------------------------------------------------------- +import Data.Functor.Const import Data.Text (Text) +import Data.Text qualified as T +import Data.String (IsString(..)) +import Data.Functor.Foldable.TH (makeBaseFunctor) import Lens.Micro +import Core.Syntax hiding (Lit) import Core (HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- -newtype RlpProgram b = RlpProgram [Decl b] +newtype RlpProgram b = RlpProgram [Decl RlpExpr b] -data Decl b = InfixD InfixAssoc Int VarId - | FunD VarId [Pat b] (RlpExpr b) - | DataD ConId [ConId] [ConAlt] +-- | The @e@ parameter is used for partial results. When parsing an input, we +-- first parse all top-level declarations in order to extract infix[lr] +-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const +-- Text@ stores the remaining unparsed function bodies. Once infixities are +-- 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) + | TySigD [VarId] Type + | DataD ConId [ConId] [ConAlt] + | InfixD Assoc Int Name + deriving Show + +data Assoc = InfixL + | InfixR + | Infix + deriving Show data ConAlt = ConAlt ConId [ConId] - -data InfixAssoc = Assoc | AssocL | AssocR + deriving Show data RlpExpr b = LetE [Bind b] (RlpExpr b) | VarE VarId @@ -27,26 +56,39 @@ data RlpExpr b = LetE [Bind b] (RlpExpr b) | IfE (RlpExpr b) (RlpExpr b) (RlpExpr b) | AppE (RlpExpr b) (RlpExpr b) | LitE (Lit b) + deriving Show -- do we want guards? data Alt b = AltA (Pat b) (RlpExpr b) + deriving Show data Bind b = PatB (Pat b) (RlpExpr b) | FunB VarId [Pat b] (RlpExpr b) + deriving Show data VarId = NameVar Text | SymVar Text + deriving Show + +instance IsString VarId where + -- TODO: use symvar if it's an operator + fromString = NameVar . T.pack data ConId = NameCon Text | SymCon Text + deriving Show data Pat b = VarP VarId | LitP (Lit b) | ConP ConId [Pat b] + deriving Show + +type Pat' = Pat Name data Lit b = IntL Int | CharL Char | ListL [RlpExpr b] + deriving Show -- instance HasLHS Alt Alt Pat Pat where -- _lhs = lens @@ -57,3 +99,10 @@ data Lit b = IntL Int -- _rhs = lens -- (\ (AltA _ e) -> e) -- (\ (AltA p _) e' -> AltA p e') + +makeBaseFunctor ''RlpExpr + +deriving instance (Show b, Show a) => Show (RlpExprF b a) + +type RlpExprF' = RlpExprF Name + From 060d48f9e18ac077bf3a5e50d02c26b59c6e9b82 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 2 Jan 2024 06:26:48 -0700 Subject: [PATCH 03/21] oh boy am i going to hate this code in 12 hours --- src/RLP/ParseDecls.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/RLP/ParseDecls.hs b/src/RLP/ParseDecls.hs index 4d18e22..376ef37 100644 --- a/src/RLP/ParseDecls.hs +++ b/src/RLP/ParseDecls.hs @@ -71,7 +71,8 @@ funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr) partialExpr :: Parser PartialExpr' partialExpr = choice - [ fmap Y $ U <$> varid' <*> lexeme infixOp <*> varid' + [ try $ fmap Y $ U <$> varid' <*> lexeme infixOp <*> fmap unY partialExpr + , fmap Y $ varid' ] where varid' = E . VarEF <$> varid @@ -128,6 +129,9 @@ type PartialDecl' = Decl (Const PartialExpr') Name newtype Y f = Y (f (Y f)) +unY :: Y f -> f (Y f) +unY (Y f) = f + instance (Show (f (Y f))) => Show (Y f) where showsPrec p (Y f) = showsPrec p f From 9a357a99b71b193ea060b069fadf30c948e590cf Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 2 Jan 2024 07:03:45 -0700 Subject: [PATCH 04/21] application and lits appl --- src/RLP/ParseDecls.hs | 37 ++++++++++++++++++++++++++----------- src/RLP/Syntax.hs | 5 +++++ 2 files changed, 31 insertions(+), 11 deletions(-) diff --git a/src/RLP/ParseDecls.hs b/src/RLP/ParseDecls.hs index 376ef37..1789c83 100644 --- a/src/RLP/ParseDecls.hs +++ b/src/RLP/ParseDecls.hs @@ -13,12 +13,12 @@ import Text.Megaparsec.Char.Lexer qualified as L import Data.Functor.Const import Data.Text (Text) import Data.Text qualified as T +import Data.List (foldl1') import Data.Void import Data.Char import Data.Functor import Data.HashMap.Strict qualified as H import Control.Monad -import Core.Syntax import Control.Monad.State ---------------------------------------------------------------------------------- @@ -71,11 +71,25 @@ funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr) partialExpr :: Parser PartialExpr' partialExpr = choice - [ try $ fmap Y $ U <$> varid' <*> lexeme infixOp <*> fmap unY partialExpr - , fmap Y $ varid' + [ try $ fmap Y $ U <$> partialExpr1' <*> lexeme infixOp <*> partialExpr' + , foldl1' papp <$> some partialExpr1 ] - where varid' = E . VarEF <$> varid + where + partialExpr1' = unY <$> partialExpr1 + partialExpr' = unY <$> partialExpr + papp :: PartialExpr' -> PartialExpr' -> PartialExpr' + papp f x = Y . E $ f `AppEF` x + +partialExpr1 :: Parser PartialExpr' +partialExpr1 = choice + [ try $ char '(' *> partialExpr <* char ')' + , fmap Y $ varid' + , fmap Y $ lit' + ] + where + varid' = E . VarEF <$> varid + lit' = E . LitEF <$> lit infixOp :: Parser Name infixOp = symvar <|> symcon @@ -88,13 +102,6 @@ symcon :: Parser Name symcon = T.pack <$> liftA2 (:) (char ':') (many $ satisfy isSym) --- partialExpr :: Parser (Const Text a) --- partialExpr = fmap Const $ L.lineFold w $ \w' -> --- try w' <> w --- where --- w = L.space eat (void lineComment) (void blockComment) --- eat = void . some $ satisfy (not . isSpace) - pat1 :: Parser Pat' pat1 = VarP <$> varid @@ -121,6 +128,11 @@ infixD = undefined tySigD = undefined dataD = undefined +lit :: Parser Lit' +lit = int + where + int = IntL <$> L.decimal + ---------------------------------------------------------------------------------- -- absolute psycho shit @@ -132,6 +144,9 @@ newtype Y f = Y (f (Y f)) unY :: Y f -> f (Y f) unY (Y f) = f +ymap :: (Functor f) => (forall a. f a -> g a) -> Y f -> Y g +ymap m (Y f) = Y $ m (ymap m <$> f) + instance (Show (f (Y f))) => Show (Y f) where showsPrec p (Y f) = showsPrec p f diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index 9e5c53b..8a93059 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -12,6 +12,9 @@ module Rlp.Syntax , VarId(..) , Pat(..) , Pat' + , Lit(..) + , Lit' + , Name ) where ---------------------------------------------------------------------------------- @@ -90,6 +93,8 @@ data Lit b = IntL Int | ListL [RlpExpr b] deriving Show +type Lit' = Lit Name + -- instance HasLHS Alt Alt Pat Pat where -- _lhs = lens -- (\ (AltA p _) -> p) From 8aa9bb843f3e2ab9d682566462fca5bfd0d19b20 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 2 Jan 2024 08:04:49 -0700 Subject: [PATCH 05/21] something --- src/RLP/ParseDecls.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/RLP/ParseDecls.hs b/src/RLP/ParseDecls.hs index 1789c83..9472063 100644 --- a/src/RLP/ParseDecls.hs +++ b/src/RLP/ParseDecls.hs @@ -47,7 +47,7 @@ symbol :: Text -> Parser Text symbol = L.symbol sc sc :: Parser () -sc = L.space space1 (void lineComment) (void blockComment) +sc = L.space hspace1 (void lineComment) (void blockComment) -- TODO: return comment text -- TODO: '---' should not start a comment @@ -156,3 +156,7 @@ data Partial a = E (RlpExprF Name a) type PartialExpr' = Y Partial +---------------------------------------------------------------------------------- + + + From f31726b43d94e9a8620c9a1fe4e990b5715a9f73 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 2 Jan 2024 08:43:34 -0700 Subject: [PATCH 06/21] goofy --- src/RLP/ParseDecls.hs | 14 +++++++++----- src/RLP/Syntax.hs | 3 +++ 2 files changed, 12 insertions(+), 5 deletions(-) diff --git a/src/RLP/ParseDecls.hs b/src/RLP/ParseDecls.hs index 9472063..83db884 100644 --- a/src/RLP/ParseDecls.hs +++ b/src/RLP/ParseDecls.hs @@ -1,5 +1,6 @@ -- Show Y {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Rlp.ParseDecls ( @@ -17,6 +18,7 @@ import Data.List (foldl1') import Data.Void import Data.Char import Data.Functor +import Data.Functor.Foldable import Data.HashMap.Strict qualified as H import Control.Monad import Control.Monad.State @@ -83,7 +85,7 @@ partialExpr = choice partialExpr1 :: Parser PartialExpr' partialExpr1 = choice - [ try $ char '(' *> partialExpr <* char ')' + [ try $ char '(' *> (hoistY P <$> partialExpr) <* char ')' , fmap Y $ varid' , fmap Y $ lit' ] @@ -144,19 +146,21 @@ newtype Y f = Y (f (Y f)) unY :: Y f -> f (Y f) unY (Y f) = f -ymap :: (Functor f) => (forall a. f a -> g a) -> Y f -> Y g -ymap m (Y f) = Y $ m (ymap m <$> f) +hoistY :: (Functor f) => (forall a. f a -> g a) -> Y f -> Y g +hoistY m (Y f) = Y $ m (hoistY m <$> f) instance (Show (f (Y f))) => Show (Y f) where showsPrec p (Y f) = showsPrec p f data Partial a = E (RlpExprF Name a) | U (Partial a) Name (Partial a) - deriving Show + | P (Partial a) + deriving (Show, Functor) type PartialExpr' = Y Partial ---------------------------------------------------------------------------------- - +mkOp :: RlpExpr b -> RlpExpr b -> RlpExpr b -> RlpExpr b +mkOp f a b = (f `AppE` a) `AppE` b diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index 8a93059..eaf6b12 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} module Rlp.Syntax ( RlpExpr(..) + , RlpExpr' , RlpExprF(..) , RlpExprF' , Decl(..) @@ -61,6 +62,8 @@ data RlpExpr b = LetE [Bind b] (RlpExpr b) | LitE (Lit b) deriving Show +type RlpExpr' = RlpExpr Name + -- do we want guards? data Alt b = AltA (Pat b) (RlpExpr b) deriving Show From d1e64eb12d8da0f7fcb845560782f4b37a31568c Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 3 Jan 2024 10:04:42 -0700 Subject: [PATCH 07/21] Show1 instances --- rlp.cabal | 3 +++ src/RLP/ParseDecls.hs | 45 ++++++++++++++++++++++++------------------- src/RLP/Syntax.hs | 30 ++++++++++++++++++++++++++++- 3 files changed, 57 insertions(+), 21 deletions(-) diff --git a/rlp.cabal b/rlp.cabal index b960ec6..172e047 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -43,6 +43,8 @@ library build-tool-depends: happy:happy, alex:alex -- other-extensions: + + -- TODO: version bounds build-depends: base ^>=4.18.0.0 , containers , microlens @@ -62,6 +64,7 @@ library , recursion-schemes , megaparsec , text + , data-fix hs-source-dirs: src default-language: GHC2021 diff --git a/src/RLP/ParseDecls.hs b/src/RLP/ParseDecls.hs index 83db884..7a36248 100644 --- a/src/RLP/ParseDecls.hs +++ b/src/RLP/ParseDecls.hs @@ -1,7 +1,8 @@ --- Show Y +-- Show Fix {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Rlp.ParseDecls ( ) @@ -12,6 +13,7 @@ import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L import Data.Functor.Const +import Data.Functor.Classes import Data.Text (Text) import Data.Text qualified as T import Data.List (foldl1') @@ -19,6 +21,7 @@ import Data.Void import Data.Char import Data.Functor import Data.Functor.Foldable +import Data.Fix import Data.HashMap.Strict qualified as H import Control.Monad import Control.Monad.State @@ -73,21 +76,21 @@ funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr) partialExpr :: Parser PartialExpr' partialExpr = choice - [ try $ fmap Y $ U <$> partialExpr1' <*> lexeme infixOp <*> partialExpr' + [ try $ fmap Fix $ U <$> partialExpr1' <*> lexeme infixOp <*> partialExpr' , foldl1' papp <$> some partialExpr1 ] where - partialExpr1' = unY <$> partialExpr1 - partialExpr' = unY <$> partialExpr + partialExpr1' = unFix <$> partialExpr1 + partialExpr' = unFix <$> partialExpr papp :: PartialExpr' -> PartialExpr' -> PartialExpr' - papp f x = Y . E $ f `AppEF` x + papp f x = Fix . E $ f `AppEF` x partialExpr1 :: Parser PartialExpr' partialExpr1 = choice - [ try $ char '(' *> (hoistY P <$> partialExpr) <* char ')' - , fmap Y $ varid' - , fmap Y $ lit' + [ try $ char '(' *> (hoistFix P <$> partialExpr) <* char ')' + , fmap Fix $ varid' + , fmap Fix $ lit' ] where varid' = E . VarEF <$> varid @@ -141,23 +144,25 @@ lit = int type PartialDecl' = Decl (Const PartialExpr') Name -newtype Y f = Y (f (Y f)) - -unY :: Y f -> f (Y f) -unY (Y f) = f - -hoistY :: (Functor f) => (forall a. f a -> g a) -> Y f -> Y g -hoistY m (Y f) = Y $ m (hoistY m <$> f) - -instance (Show (f (Y f))) => Show (Y f) where - showsPrec p (Y f) = showsPrec p f - data Partial a = E (RlpExprF Name a) | U (Partial a) Name (Partial a) | P (Partial a) deriving (Show, Functor) -type PartialExpr' = Y Partial +instance Show1 Partial where + liftShowsPrec :: forall a. (Int -> a -> ShowS) + -> ([a] -> ShowS) + -> Int -> Partial a -> ShowS + + liftShowsPrec sp sl p m = case m of + (E e) -> showsUnaryWith lshow "E" p e + (U a f b) -> showsTernaryWith lshow showsPrec lshow "U" p a f b + (P e) -> showsUnaryWith lshow "P" p e + where + lshow :: forall f. (Show1 f) => Int -> f a -> ShowS + lshow = liftShowsPrec sp sl + +type PartialExpr' = Fix Partial ---------------------------------------------------------------------------------- diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index eaf6b12..4a47b7a 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -16,6 +16,9 @@ module Rlp.Syntax , Lit(..) , Lit' , Name + + -- TODO: ugh move this somewhere else later + , showsTernaryWith ) where ---------------------------------------------------------------------------------- @@ -24,11 +27,12 @@ import Data.Text (Text) import Data.Text qualified as T import Data.String (IsString(..)) import Data.Functor.Foldable.TH (makeBaseFunctor) +import Data.Functor.Classes import Lens.Micro import Core.Syntax hiding (Lit) import Core (HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- - + newtype RlpProgram b = RlpProgram [Decl RlpExpr b] -- | The @e@ parameter is used for partial results. When parsing an input, we @@ -114,3 +118,27 @@ deriving instance (Show b, Show a) => Show (RlpExprF b a) type RlpExprF' = RlpExprF Name +-- society if derivable Show1 +instance (Show b) => Show1 (RlpExprF b) where + liftShowsPrec sp _ p m = case m of + (LetEF bs e) -> showsBinaryWith showsPrec sp "LetEF" p bs e + (VarEF n) -> showsUnaryWith showsPrec "VarEF" p n + (ConEF n) -> showsUnaryWith showsPrec "ConEF" p n + (LamEF bs e) -> showsBinaryWith showsPrec sp "LamEF" p bs e + (CaseEF e as) -> showsBinaryWith sp showsPrec "CaseEF" p e as + (IfEF a b c) -> showsTernaryWith sp sp sp "IfEF" p a b c + (AppEF f x) -> showsBinaryWith sp sp "AppEF" p f x + (LitEF l) -> showsUnaryWith showsPrec "LitEF" p l + +showsTernaryWith :: (Int -> x -> ShowS) + -> (Int -> y -> ShowS) + -> (Int -> z -> ShowS) + -> String -> Int + -> x -> y -> z + -> ShowS +showsTernaryWith sa sb sc name p a b c = showParen (p > 10) + $ showString name + . showChar ' ' . sa 11 a + . showChar ' ' . sb 11 b + . showChar ' ' . sc 11 c + From a71c099fe0c0ea93235cfaa96e95fda4bc6e061a Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Mon, 8 Jan 2024 13:39:12 -0700 Subject: [PATCH 08/21] fixation fufilled - back to work! --- rlp.cabal | 3 +- src/RLP/{ParseDecls.hs => Parse/Decls.hs} | 88 +++++++++++------------ src/RLP/Parse/Types.hs | 65 +++++++++++++++++ src/RLP/Syntax.hs | 6 +- 4 files changed, 115 insertions(+), 47 deletions(-) rename src/RLP/{ParseDecls.hs => Parse/Decls.hs} (69%) create mode 100644 src/RLP/Parse/Types.hs diff --git a/rlp.cabal b/rlp.cabal index 172e047..88ab65c 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -31,7 +31,8 @@ library , Core.HindleyMilner , Control.Monad.Errorful , Rlp.Syntax - , Rlp.ParseDecls + , Rlp.Parse.Decls + , Rlp.Parse.Types other-modules: Data.Heap , Data.Pretty diff --git a/src/RLP/ParseDecls.hs b/src/RLP/Parse/Decls.hs similarity index 69% rename from src/RLP/ParseDecls.hs rename to src/RLP/Parse/Decls.hs index 7a36248..18e85aa 100644 --- a/src/RLP/ParseDecls.hs +++ b/src/RLP/Parse/Decls.hs @@ -1,41 +1,30 @@ --- Show Fix -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE LambdaCase, BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module Rlp.ParseDecls +module Rlp.Parse.Decls ( ) where ---------------------------------------------------------------------------------- -import Rlp.Syntax +import Control.Monad +import Control.Monad.State import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer qualified as L -import Data.Functor.Const import Data.Functor.Classes +import Data.Functor.Foldable import Data.Text (Text) import Data.Text qualified as T import Data.List (foldl1') -import Data.Void import Data.Char import Data.Functor -import Data.Functor.Foldable -import Data.Fix -import Data.HashMap.Strict qualified as H -import Control.Monad -import Control.Monad.State ----------------------------------------------------------------------------------- - -type Parser = ParsecT Void Text (State ParserState) - -data ParserState = ParserState - { _psPrecTable :: PrecTable - } - deriving Show - -type PrecTable = H.HashMap Name (Assoc, Int) - +import Data.Functor.Const +import Data.Fix hiding (cata) +import Lens.Micro +import Rlp.Parse.Types +import Rlp.Syntax ---------------------------------------------------------------------------------- parseTest' :: (Show a) => Parser a -> Text -> IO () @@ -76,10 +65,11 @@ funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr) partialExpr :: Parser PartialExpr' partialExpr = choice - [ try $ fmap Fix $ U <$> partialExpr1' <*> lexeme infixOp <*> partialExpr' + [ try $ fmap Fix $ mkB <$> partialExpr1' <*> lexeme infixOp <*> partialExpr' , foldl1' papp <$> some partialExpr1 ] where + mkB a f b = B f a b partialExpr1' = unFix <$> partialExpr1 partialExpr' = unFix <$> partialExpr @@ -140,32 +130,42 @@ lit = int ---------------------------------------------------------------------------------- --- absolute psycho shit +type PartialE = Partial RlpExpr' -type PartialDecl' = Decl (Const PartialExpr') Name +-- complete :: OpTable -> Fix Partial -> RlpExpr' +complete :: OpTable -> PartialExpr' -> RlpExpr' +complete pt = let ?pt = pt in cata completePartial -data Partial a = E (RlpExprF Name a) - | U (Partial a) Name (Partial a) - | P (Partial a) - deriving (Show, Functor) +completePartial :: PartialE -> RlpExpr' +completePartial (E e) = completeRlpExpr e +completePartial p@(B o l r) = completeB (build p) +completePartial (P e) = completePartial e -instance Show1 Partial where - liftShowsPrec :: forall a. (Int -> a -> ShowS) - -> ([a] -> ShowS) - -> Int -> Partial a -> ShowS +completeRlpExpr :: RlpExprF' RlpExpr' -> RlpExpr' +completeRlpExpr = embed - liftShowsPrec sp sl p m = case m of - (E e) -> showsUnaryWith lshow "E" p e - (U a f b) -> showsTernaryWith lshow showsPrec lshow "U" p a f b - (P e) -> showsUnaryWith lshow "P" p e - where - lshow :: forall f. (Show1 f) => Int -> f a -> ShowS - lshow = liftShowsPrec sp sl +completeB :: PartialE -> RlpExpr' +completeB = build -type PartialExpr' = Fix Partial +build :: PartialE -> PartialE +build e = go id e (rightmost e) where + rightmost :: Partial -> Partial + rightmost (B _ _ _) = rightmost r + rightmost (E n) = undefined ----------------------------------------------------------------------------------- + go :: (?pt :: OpTable) + => (PartialE -> PartialE) + -> PartialE -> PartialE -> PartialE + go f p@(WithPrec o _ r) = case r of + E _ -> mkHole o (f . f') + P _ -> undefined + B _ _ _ -> go (mkHole o (f . f')) r + where f' r' = p & pR .~ r' -mkOp :: RlpExpr b -> RlpExpr b -> RlpExpr b -> RlpExpr b -mkOp f a b = (f `AppE` a) `AppE` b +mkHole :: (?pt :: OpTable) + => OpInfo + -> (PartialE -> PartialE) + -> PartialE + -> PartialE +mkHole = undefined diff --git a/src/RLP/Parse/Types.hs b/src/RLP/Parse/Types.hs new file mode 100644 index 0000000..cb1d6bf --- /dev/null +++ b/src/RLP/Parse/Types.hs @@ -0,0 +1,65 @@ +module Rlp.Parse.Types + ( + -- * Partial ASTs + Partial(..) + , PartialExpr' + , PartialDecl' + + -- * Parser types + , Parser + , ParserState(..) + , OpTable + , OpInfo + ) + where +---------------------------------------------------------------------------------- +import Control.Monad.State +import Data.HashMap.Strict qualified as H +import Data.Fix +import Data.Functor.Foldable +import Data.Functor.Const +import Data.Functor.Classes +import Data.Void +import Text.Megaparsec hiding (State) +import Rlp.Syntax +---------------------------------------------------------------------------------- + +-- parser types + +type Parser = ParsecT Void Text (State ParserState) + +data ParserState = ParserState + { _psOpTable :: OpTable + } + deriving Show + +type OpTable = H.HashMap Name OpInfo +type OpInfo = (Assoc, Int) + +---------------------------------------------------------------------------------- + +-- absolute psycho shit (partial ASTs) + +type PartialDecl' = Decl (Const PartialExpr') Name + +data Partial a = E (RlpExprF Name a) + | B Name (Partial a) (Partial a) + | P (Partial a) + deriving (Show, Functor) + +-- required to satisfy constraint on Fix's show instance +instance Show1 Partial where + liftShowsPrec :: forall a. (Int -> a -> ShowS) + -> ([a] -> ShowS) + -> Int -> Partial a -> ShowS + + liftShowsPrec sp sl p m = case m of + (E e) -> showsUnaryWith lshow "E" p e + (B f a b) -> showsTernaryWith showsPrec lshow lshow "B" p f a b + (P e) -> showsUnaryWith lshow "P" p e + where + lshow :: forall f. (Show1 f) => Int -> f a -> ShowS + lshow = liftShowsPrec sp sl + +type PartialExpr' = Fix Partial + diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index 4a47b7a..b314d7b 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -19,10 +19,12 @@ module Rlp.Syntax -- TODO: ugh move this somewhere else later , showsTernaryWith + + -- * Convenience re-exports + , Text ) where ---------------------------------------------------------------------------------- -import Data.Functor.Const import Data.Text (Text) import Data.Text qualified as T import Data.String (IsString(..)) @@ -32,7 +34,7 @@ import Lens.Micro import Core.Syntax hiding (Lit) import Core (HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- - + newtype RlpProgram b = RlpProgram [Decl RlpExpr b] -- | The @e@ parameter is used for partial results. When parsing an input, we From 2f783d96e88a354b298b463460759e3cb7ed85b7 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Mon, 8 Jan 2024 18:56:14 -0700 Subject: [PATCH 09/21] works --- src/RLP/Parse/Decls.hs | 70 +++++++++++++++++++++++++++++++++--------- src/RLP/Parse/Types.hs | 27 ++++++++++++++++ 2 files changed, 82 insertions(+), 15 deletions(-) diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 18e85aa..965a4c5 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -17,6 +17,7 @@ import Data.Functor.Classes import Data.Functor.Foldable import Data.Text (Text) import Data.Text qualified as T +import Data.HashMap.Strict qualified as H import Data.List (foldl1') import Data.Char import Data.Functor @@ -130,42 +131,81 @@ lit = int ---------------------------------------------------------------------------------- -type PartialE = Partial RlpExpr' - -- complete :: OpTable -> Fix Partial -> RlpExpr' -complete :: OpTable -> PartialExpr' -> RlpExpr' -complete pt = let ?pt = pt in cata completePartial +complete :: (?pt :: OpTable) => PartialExpr' -> RlpExpr' +complete = cata completePartial -completePartial :: PartialE -> RlpExpr' +completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr' completePartial (E e) = completeRlpExpr e completePartial p@(B o l r) = completeB (build p) completePartial (P e) = completePartial e -completeRlpExpr :: RlpExprF' RlpExpr' -> RlpExpr' +completeRlpExpr :: (?pt :: OpTable) => RlpExprF' RlpExpr' -> RlpExpr' completeRlpExpr = embed -completeB :: PartialE -> RlpExpr' -completeB = build +completeB :: (?pt :: OpTable) => PartialE -> RlpExpr' +completeB p = case build p of + B o l r -> (o' `AppE` l') `AppE` r' + where + -- TODO: how do we know it's symbolic? + o' = VarE (SymVar o) + l' = completeB l + r' = completeB r + P e -> completeB e + E e -> completeRlpExpr e -build :: PartialE -> PartialE +build :: (?pt :: OpTable) => PartialE -> PartialE build e = go id e (rightmost e) where - rightmost :: Partial -> Partial - rightmost (B _ _ _) = rightmost r - rightmost (E n) = undefined + rightmost :: PartialE -> PartialE + rightmost (B _ _ r) = rightmost r + rightmost p@(E _) = p + rightmost p@(P _) = p go :: (?pt :: OpTable) => (PartialE -> PartialE) -> PartialE -> PartialE -> PartialE - go f p@(WithPrec o _ r) = case r of + go f p@(WithInfo o _ r) = case r of E _ -> mkHole o (f . f') - P _ -> undefined + P _ -> mkHole o (f . f') B _ _ _ -> go (mkHole o (f . f')) r where f' r' = p & pR .~ r' + go f _ = id mkHole :: (?pt :: OpTable) => OpInfo -> (PartialE -> PartialE) -> PartialE -> PartialE -mkHole = undefined +mkHole _ hole p@(P _) = hole p +mkHole _ hole p@(E _) = hole p +mkHole (a,d) hole p@(WithInfo (a',d') _ _) + | d' < d = above + | d' > d = below + | d == d' = case (a,a') of + -- left-associative operators of equal precedence are + -- associated left + (InfixL,InfixL) -> above + -- right-associative operators are handled similarly + (InfixR,InfixR) -> below + -- non-associative operators of equal precedence, or equal + -- precedence operators of different associativities are + -- invalid + (_, _) -> error "invalid expression" + where + above = p & pL %~ hole + below = hole p + +examplePrecTable :: OpTable +examplePrecTable = H.fromList + [ ("+", (InfixL,6)) + , ("*", (InfixL,7)) + , ("^", (InfixR,8)) + , (".", (InfixR,7)) + , ("~", (Infix, 9)) + , ("=", (Infix, 4)) + , ("&&", (Infix, 3)) + , ("||", (Infix, 2)) + , ("$", (InfixR,0)) + , ("&", (InfixL,0)) + ] diff --git a/src/RLP/Parse/Types.hs b/src/RLP/Parse/Types.hs index cb1d6bf..d3e7bd1 100644 --- a/src/RLP/Parse/Types.hs +++ b/src/RLP/Parse/Types.hs @@ -1,9 +1,17 @@ +{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-} +{- +Description : Supporting types for the parser +-} module Rlp.Parse.Types ( -- * Partial ASTs Partial(..) + , PartialE , PartialExpr' , PartialDecl' + , pattern WithInfo + , pR + , pL -- * Parser types , Parser @@ -20,7 +28,9 @@ import Data.Functor.Foldable import Data.Functor.Const import Data.Functor.Classes import Data.Void +import Data.Maybe import Text.Megaparsec hiding (State) +import Lens.Micro import Rlp.Syntax ---------------------------------------------------------------------------------- @@ -47,6 +57,23 @@ data Partial a = E (RlpExprF Name a) | P (Partial a) deriving (Show, Functor) +pL :: Traversal' (Partial a) (Partial a) +pL k (B o l r) = (\l' -> B o l' r) <$> k l +pL _ x = pure x + +pR :: Traversal' (Partial a) (Partial a) +pR k (B o l r) = (\r' -> B o l r') <$> k r +pR _ x = pure x + +type PartialE = Partial RlpExpr' + +-- i love you haskell +pattern WithInfo :: (?pt :: OpTable) => OpInfo -> PartialE -> PartialE -> PartialE +pattern WithInfo p l r <- B (opInfoOrDef -> p) l r + +opInfoOrDef :: (?pt :: OpTable) => Name -> OpInfo +opInfoOrDef c = fromMaybe (InfixL,9) $ H.lookup c ?pt + -- required to satisfy constraint on Fix's show instance instance Show1 Partial where liftShowsPrec :: forall a. (Int -> a -> ShowS) From cb7cdf7ed7422d1e144a371234d8654a59fc8e36 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Mon, 8 Jan 2024 20:14:18 -0700 Subject: [PATCH 10/21] labels --- src/RLP/Parse/Decls.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 965a4c5..c8a0a33 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -64,11 +64,18 @@ decl = choice funD :: Parser PartialDecl' funD = FunD <$> varid <*> many pat1 <*> (symbol "=" *> fmap Const partialExpr) +standalonePartialExpr :: Parser PartialExpr' +standalonePartialExpr = standaloneOf partialExpr + +standaloneOf :: Parser a -> Parser a +standaloneOf = (<* eof) + partialExpr :: Parser PartialExpr' partialExpr = choice [ try $ fmap Fix $ mkB <$> partialExpr1' <*> lexeme infixOp <*> partialExpr' , foldl1' papp <$> some partialExpr1 ] + "expression" where mkB a f b = B f a b partialExpr1' = unFix <$> partialExpr1 @@ -83,12 +90,13 @@ partialExpr1 = choice , fmap Fix $ varid' , fmap Fix $ lit' ] + "expression" where varid' = E . VarEF <$> varid lit' = E . LitEF <$> lit infixOp :: Parser Name -infixOp = symvar <|> symcon +infixOp = symvar <|> symcon "infix operator" symvar :: Parser Name symvar = T.pack <$> @@ -100,6 +108,7 @@ symcon = T.pack <$> pat1 :: Parser Pat' pat1 = VarP <$> varid + "pattern" varid :: Parser VarId varid = NameVar <$> lexeme namevar @@ -126,6 +135,7 @@ dataD = undefined lit :: Parser Lit' lit = int + "literal" where int = IntL <$> L.decimal From 37d9e6f219523f4b1584cf62e9ffb09286683ca5 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 9 Jan 2024 11:39:26 -0700 Subject: [PATCH 11/21] infix decl --- rlp.cabal | 2 +- src/RLP/Parse/Decls.hs | 36 +++++++++++++++++++++++++++++++++++- src/RLP/Parse/Types.hs | 36 +++++++++++++++++++++++++++++++++++- src/RLP/Syntax.hs | 3 +++ 4 files changed, 74 insertions(+), 3 deletions(-) diff --git a/rlp.cabal b/rlp.cabal index 88ab65c..f4a93e2 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -63,7 +63,7 @@ library -- TODO: either learn recursion-schemes, or stop depending -- on it. , recursion-schemes - , megaparsec + , megaparsec ^>=9.6.0 , text , data-fix diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index c8a0a33..3c28017 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -24,6 +24,7 @@ import Data.Functor import Data.Functor.Const import Data.Fix hiding (cata) import Lens.Micro +import Lens.Micro.Platform import Rlp.Parse.Types import Rlp.Syntax ---------------------------------------------------------------------------------- @@ -128,7 +129,40 @@ isVarSym = (`T.elem` "\\!#$%&*+./<=>?@^|-~") isSym :: Char -> Bool isSym c = c == ':' || isVarSym c -infixD = undefined +infixD :: Parser (Decl' e) +infixD = do + o <- getOffset + a <- infixWord + p <- prec + op <- infixOp + region (setErrorOffset o) $ updateOpTable a p op + pure $ InfixD a p op + where + infixWord :: Parser Assoc + infixWord = choice $ lexeme <$> + [ "infixr" $> InfixR + , "infixl" $> InfixL + , "infix" $> Infix + ] + + prec :: Parser Int + prec = do + o <- getOffset + n <- lexeme L.decimal + if 0 <= n && n <= 9 then + pure n + else + region (setErrorOffset o) $ + registerCustomFailure (RlpParErrOutOfBoundsPrecedence n) + $> 9 + + updateOpTable :: Assoc -> Int -> Name -> Parser () + updateOpTable a p op = do + t <- use psOpTable + psOpTable <~ H.alterF f op t + where + f Nothing = pure (Just (a,p)) + f (Just _) = customFailure RlpParErrDuplicateInfixD tySigD = undefined dataD = undefined diff --git a/src/RLP/Parse/Types.hs b/src/RLP/Parse/Types.hs index d3e7bd1..16a0ed9 100644 --- a/src/RLP/Parse/Types.hs +++ b/src/RLP/Parse/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-} {- Description : Supporting types for the parser @@ -16,8 +18,13 @@ module Rlp.Parse.Types -- * Parser types , Parser , ParserState(..) + , psOpTable + , RlpParseError(..) , OpTable , OpInfo + + -- * Extras + , registerCustomFailure ) where ---------------------------------------------------------------------------------- @@ -29,14 +36,17 @@ 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 +import Lens.Micro.TH import Rlp.Syntax ---------------------------------------------------------------------------------- -- parser types -type Parser = ParsecT Void Text (State ParserState) +type Parser = ParsecT RlpParseError Text (State ParserState) data ParserState = ParserState { _psOpTable :: OpTable @@ -46,6 +56,23 @@ data ParserState = ParserState type OpTable = H.HashMap Name OpInfo type OpInfo = (Assoc, Int) +-- data WithLocation a = WithLocation [String] a + +data RlpParseError = RlpParErrOutOfBoundsPrecedence Int + | RlpParErrDuplicateInfixD + deriving (Eq, Ord, Show) + +instance ShowErrorComponent RlpParseError where + showErrorComponent = \case + -- TODO: wrap text to 80 characters + RlpParErrOutOfBoundsPrecedence n -> + printf "%d is an invalid precedence level! rl' currently only\ + \allows custom precedences between 0 and 9 (inclusive).\ + \ This is an arbitrary limit put in place for legibility\ + \ concerns, and may change in the future." n + RlpParErrDuplicateInfixD -> + "duplicate infix decl" + ---------------------------------------------------------------------------------- -- absolute psycho shit (partial ASTs) @@ -90,3 +117,10 @@ instance Show1 Partial where type PartialExpr' = Fix Partial +---------------------------------------------------------------------------------- + +makeLenses ''ParserState + +registerCustomFailure :: MonadParsec e s m => e -> m () +registerCustomFailure = registerFancyFailure . S.singleton . ErrorCustom + diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index b314d7b..4a43cb9 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -9,6 +9,7 @@ module Rlp.Syntax , RlpExprF(..) , RlpExprF' , Decl(..) + , Decl' , Assoc(..) , VarId(..) , Pat(..) @@ -50,6 +51,8 @@ data Decl e b = FunD VarId [Pat b] (e b) | InfixD Assoc Int Name deriving Show +type Decl' e = Decl e Name + data Assoc = InfixL | InfixR | Infix From 074350768c259f4ac65aac530368ce9edec7578a Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 9 Jan 2024 12:26:53 -0700 Subject: [PATCH 12/21] expr fixups --- src/RLP/Parse/Decls.hs | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 3c28017..87668aa 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -45,6 +45,9 @@ symbol = L.symbol sc sc :: Parser () sc = L.space hspace1 (void lineComment) (void blockComment) +scn :: Parser () +scn = L.space space1 (void lineComment) (void blockComment) + -- TODO: return comment text -- TODO: '---' should not start a comment lineComment :: Parser Text @@ -72,27 +75,35 @@ standaloneOf :: Parser a -> Parser a standaloneOf = (<* eof) partialExpr :: Parser PartialExpr' -partialExpr = choice - [ try $ fmap Fix $ mkB <$> partialExpr1' <*> lexeme infixOp <*> partialExpr' - , foldl1' papp <$> some partialExpr1 +partialExpr = (choice . fmap foldedLexeme) + [ try application + , Fix <$> infixExpr ] "expression" where + application = foldl1' mkApp <$> some partialExpr1 + infixExpr = mkB <$> partialExpr1' <*> infixOp' <*> partialExpr' + mkB a f b = B f a b partialExpr1' = unFix <$> partialExpr1 partialExpr' = unFix <$> partialExpr + infixOp' = foldedLexeme infixOp - papp :: PartialExpr' -> PartialExpr' -> PartialExpr' - papp f x = Fix . E $ f `AppEF` x + 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 - [ try $ char '(' *> (hoistFix P <$> partialExpr) <* char ')' - , fmap Fix $ varid' - , fmap Fix $ lit' +partialExpr1 = (choice . fmap foldedLexeme) + [ foldedLexeme "(" *> partialExpr' <* foldedLexeme ")" + , Fix <$> varid' + , Fix <$> lit' ] "expression" where + partialExpr' = wrapFix . P . unwrapFix <$> partialExpr varid' = E . VarEF <$> varid lit' = E . LitEF <$> lit From 90a9594e8f8a55c2cf071b7e6c4aebc74a079341 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 9 Jan 2024 14:24:51 -0700 Subject: [PATCH 13/21] 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) From 4b44f57066d8fdb82c5030f81d41254021f79806 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 9 Jan 2024 22:57:14 -0700 Subject: [PATCH 14/21] cool --- src/RLP/Parse/Decls.hs | 44 ++++++++++++++++++++++++++++-------------- src/RLP/Syntax.hs | 15 +++++++++++++- 2 files changed, 44 insertions(+), 15 deletions(-) diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 8a95f41..9d4a911 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase, BlockArguments #-} @@ -71,14 +72,14 @@ decl = choice ] funD :: Parser PartialDecl' -funD = FunD <$> flexeme varid <*> params <*> (symbol "=" *> body) <*> whereClause +funD = FunD <$> lexeme varid <*> params <*> (symbol "=" *> body) <*> whereClause where params = many pat1 body = fmap Const partialExpr whereClause :: Parser Where' whereClause = optionalList $ - flexeme "where" *> pure + lexeme "where" *> pure [ FunB "fixme" [] (VarE "fixme") ] @@ -89,7 +90,7 @@ standaloneOf :: Parser a -> Parser a standaloneOf = (<* eof) partialExpr :: Parser PartialExpr' -partialExpr = (choice . fmap flexeme) +partialExpr = choice [ try application , Fix <$> infixExpr ] @@ -101,14 +102,14 @@ partialExpr = (choice . fmap flexeme) mkB a f b = B f a b partialExpr1' = unFix <$> partialExpr1 partialExpr' = unFix <$> partialExpr - infixOp' = flexeme infixOp + infixOp' = lexeme infixOp mkApp :: PartialExpr' -> PartialExpr' -> PartialExpr' mkApp f x = Fix . E $ f `AppEF` x partialExpr1 :: Parser PartialExpr' -partialExpr1 = (choice . fmap flexeme) - [ try $ flexeme "(" *> partialExpr' <* flexeme ")" +partialExpr1 = choice + [ try $ lexeme "(" *> partialExpr' <* lexeme ")" , Fix <$> varid' , Fix <$> lit' ] @@ -130,7 +131,7 @@ symcon = T.pack <$> liftA2 (:) (char ':') (many $ satisfy isSym) pat1 :: Parser Pat' -pat1 = VarP <$> flexeme varid +pat1 = VarP <$> lexeme varid "pattern" conid :: Parser ConId @@ -148,8 +149,23 @@ varid = NameVar <$> try (lexeme namevar) <|> SymVar <$> lexeme (char '(' *> symvar <* char ')') "variable identifier" +decls :: Parser [PartialDecl'] +decls = L.indentBlock scn p where + p = do + a <- "wtf" + pure (L.IndentSome (Just pos1) pure decl) + +t :: Parser [PartialDecl'] +t = do + space + i <- L.indentLevel + let indentGuard = L.indentGuard scn EQ i + -- indentGuard *> decl *> eol *> indentGuard *> decl + rec ds <- indentGuard *> decl <|> eof + many $ indentGuard *> decl <* (eol <|> eof) + namevar :: Parser Name -namevar = try word +namevar = word & withPredicate (`notElem` ["where"]) empty where word = T.pack <$> liftA2 (:) (satisfy isLower) (many $ satisfy isNameTail) @@ -204,11 +220,11 @@ infixD = do tySigD = undefined dataD :: Parser (Decl' e) -dataD = DataD <$> (flexeme "data" *> conid) <*> many typaram +dataD = DataD <$> (lexeme "data" *> conid) <*> many typaram <*> optionalList (symbol "=" *> conalts) where typaram :: Parser Name - typaram = flexeme namevar + typaram = lexeme namevar conalts :: Parser [ConAlt] conalts = (:) <$> conalt <*> optionalList (symbol "|" *> conalts) @@ -217,15 +233,15 @@ dataD = DataD <$> (flexeme "data" *> conid) <*> many typaram conalt = ConAlt <$> conid <*> many type1 type1 :: Parser Type -type1 = (choice . fmap flexeme) - [ flexeme "(" *> type_ <* flexeme ")" +type1 = choice + [ lexeme "(" *> type_ <* lexeme ")" , TyVar <$> namevar , TyCon <$> namecon ] type_ :: Parser Type -type_ = (choice . fmap flexeme) - [ try $ (:->) <$> type1 <*> (flexeme "->" *> type_) +type_ = choice + [ try $ (:->) <$> type1 <*> (lexeme "->" *> type_) , type1 ] diff --git a/src/RLP/Syntax.hs b/src/RLP/Syntax.hs index 09acb8b..58843b5 100644 --- a/src/RLP/Syntax.hs +++ b/src/RLP/Syntax.hs @@ -4,7 +4,10 @@ {-# LANGUAGE TemplateHaskell, TypeFamilies #-} {-# LANGUAGE OverloadedStrings, PatternSynonyms #-} module Rlp.Syntax - ( RlpExpr(..) + ( RlpModule(..) + , rlpmodName + , rlpmodProgram + , RlpExpr(..) , RlpExpr' , RlpExprF(..) , RlpExprF' @@ -39,10 +42,16 @@ import Data.String (IsString(..)) import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.Functor.Classes import Lens.Micro +import Lens.Micro.TH import Core.Syntax hiding (Lit) import Core (HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- +data RlpModule b = RlpModule + { _rlpmodName :: Text + , _rlpmodProgram :: RlpProgram b + } + newtype RlpProgram b = RlpProgram [Decl RlpExpr b] -- | The @e@ parameter is used for partial results. When parsing an input, we @@ -157,3 +166,7 @@ showsTernaryWith sa sb sc name p a b c = showParen (p > 10) . showChar ' ' . sb 11 b . showChar ' ' . sc 11 c +-------------------------------------------------------------------------------- + +makeLenses ''RlpModule + From 1d43c1d3049fe759cbbc91232c3bff948811f2c5 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 10 Jan 2024 10:46:53 -0700 Subject: [PATCH 15/21] aaaaa --- src/RLP/Parse/Decls.hs | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 9d4a911..201316b 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -65,10 +65,12 @@ blockComment = L.skipBlockCommentNested "{-" "-}" $> "" decl :: Parser PartialDecl' decl = choice - [ funD - , tySigD + -- declarations that begin with a keyword before those beginning with an + -- arbitrary name + [ infixD , dataD - , infixD + , funD + , tySigD ] funD :: Parser PartialDecl' @@ -150,26 +152,28 @@ varid = NameVar <$> try (lexeme namevar) "variable identifier" decls :: Parser [PartialDecl'] -decls = L.indentBlock scn p where - p = do - a <- "wtf" - pure (L.IndentSome (Just pos1) pure decl) - -t :: Parser [PartialDecl'] -t = do +decls = do space i <- L.indentLevel let indentGuard = L.indentGuard scn EQ i -- indentGuard *> decl *> eol *> indentGuard *> decl - rec ds <- indentGuard *> decl <|> eof - many $ indentGuard *> decl <* (eol <|> eof) + many $ indentGuard *> decl + -- many $ indentGuard *> decl <* (eol <|> eof) namevar :: Parser Name namevar = word - & withPredicate (`notElem` ["where"]) empty + & withPredicate (`notElem` keywords) empty where word = T.pack <$> liftA2 (:) (satisfy isLower) (many $ satisfy isNameTail) +keywords :: (IsString a) => [a] +keywords = + [ "where" + , "infix" + , "infixr" + , "infixl" + ] + isNameTail :: Char -> Bool isNameTail c = isAlphaNum c || c == '\'' @@ -217,7 +221,8 @@ infixD = do f (Just x) = registerCustomFailure RlpParErrDuplicateInfixD $> Just x -tySigD = undefined +tySigD :: Parser (Decl' e) +tySigD = undefined -- TySigD <$> (flexeme) dataD :: Parser (Decl' e) dataD = DataD <$> (lexeme "data" *> conid) <*> many typaram From 86cd1075ca93f2072d4521849d09ae9a9139859e Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 10 Jan 2024 11:03:06 -0700 Subject: [PATCH 16/21] decls fix --- src/RLP/Parse/Decls.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 201316b..07c8263 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -22,9 +22,11 @@ import Data.HashMap.Strict qualified as H import Data.Maybe (maybeToList) import Data.List (foldl1') import Data.Char +import Data.Function (fix) import Data.Functor import Data.Functor.Const import Data.Fix hiding (cata) +import GHC.Exts (IsString) import Lens.Micro import Lens.Micro.Platform import Rlp.Parse.Types @@ -156,9 +158,8 @@ decls = do space i <- L.indentLevel let indentGuard = L.indentGuard scn EQ i - -- indentGuard *> decl *> eol *> indentGuard *> decl - many $ indentGuard *> decl - -- many $ indentGuard *> decl <* (eol <|> eof) + fix \ds -> (:) <$> (indentGuard *> decl) + <*> (try ds <|> eof *> pure []) namevar :: Parser Name namevar = word From 981c5d8a831b6d266fec499984166dbbfcb2bd57 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 10 Jan 2024 11:26:17 -0700 Subject: [PATCH 17/21] finally in a decent state --- src/RLP/Parse/Decls.hs | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 07c8263..480bea3 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -44,9 +44,6 @@ 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 @@ -56,6 +53,8 @@ sc = L.space hspace1 (void lineComment) (void blockComment) scn :: Parser () scn = L.space space1 (void lineComment) (void blockComment) +type OnFold = (?foldGuard :: Parser ()) + -- TODO: return comment text -- TODO: '---' should not start a comment lineComment :: Parser Text @@ -65,7 +64,7 @@ lineComment = L.skipLineComment "--" $> "" blockComment :: Parser Text blockComment = L.skipBlockCommentNested "{-" "-}" $> "" -decl :: Parser PartialDecl' +decl :: (OnFold) => Parser PartialDecl' decl = choice -- declarations that begin with a keyword before those beginning with an -- arbitrary name @@ -75,12 +74,18 @@ decl = choice , tySigD ] -funD :: Parser PartialDecl' -funD = FunD <$> lexeme varid <*> params <*> (symbol "=" *> body) <*> whereClause +funD :: (OnFold) => Parser PartialDecl' +funD = FunD <$> lexeme varid <*> params <*> (fsymbol "=" *> body) <*> whereClause where params = many pat1 body = fmap Const partialExpr +fsymbol :: (OnFold) => Text -> Parser Text +fsymbol p = scn *> ?foldGuard *> symbol p + +flexeme :: (OnFold) => Parser a -> Parser a +flexeme p = scn *> ?foldGuard *> lexeme p + whereClause :: Parser Where' whereClause = optionalList $ lexeme "where" *> pure @@ -134,8 +139,8 @@ symcon :: Parser Name symcon = T.pack <$> liftA2 (:) (char ':') (many $ satisfy isSym) -pat1 :: Parser Pat' -pat1 = VarP <$> lexeme varid +pat1 :: (OnFold) => Parser Pat' +pat1 = VarP <$> flexeme varid "pattern" conid :: Parser ConId @@ -158,6 +163,7 @@ decls = do space i <- L.indentLevel let indentGuard = L.indentGuard scn EQ i + let ?foldGuard = void $ L.indentGuard scn GT i fix \ds -> (:) <$> (indentGuard *> decl) <*> (try ds <|> eof *> pure []) From 05226373eed319d056780b6fd4ec8ee48230e998 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 10 Jan 2024 11:33:27 -0700 Subject: [PATCH 18/21] replace uses of many+satisfy with takeWhileP --- src/RLP/Parse/Decls.hs | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 480bea3..3e86529 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -132,12 +132,10 @@ infixOp :: Parser Name infixOp = symvar <|> symcon "operator" symvar :: Parser Name -symvar = T.pack <$> - liftA2 (:) (satisfy isVarSym) (many $ satisfy isSym) +symvar = T.cons <$> satisfy isVarSym <*> takeWhileP Nothing isSym symcon :: Parser Name -symcon = T.pack <$> - liftA2 (:) (char ':') (many $ satisfy isSym) +symcon = T.cons <$> char ':' <*> takeWhileP Nothing isSym pat1 :: (OnFold) => Parser Pat' pat1 = VarP <$> flexeme varid @@ -149,9 +147,7 @@ conid = NameCon <$> lexeme namecon "constructor identifier" namecon :: Parser Name -namecon = T.pack <$> - liftA2 (:) (satisfy isUpper) - (many $ satisfy isNameTail) +namecon = T.cons <$> satisfy isUpper <*> takeWhileP Nothing isNameTail varid :: Parser VarId varid = NameVar <$> try (lexeme namevar) @@ -170,8 +166,8 @@ decls = do namevar :: Parser Name namevar = word & withPredicate (`notElem` keywords) empty - where word = T.pack <$> - liftA2 (:) (satisfy isLower) (many $ satisfy isNameTail) + where + word = T.cons <$> satisfy isLower <*> takeWhileP Nothing isNameTail keywords :: (IsString a) => [a] keywords = From 55dbc9de70528429b258b4d5e5729d5f71697944 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 10 Jan 2024 14:10:46 -0700 Subject: [PATCH 19/21] layout layouts oh my layouts --- src/RLP/Parse/Decls.hs | 55 +++++++++++++++++++++++++++++++++--------- 1 file changed, 43 insertions(+), 12 deletions(-) diff --git a/src/RLP/Parse/Decls.hs b/src/RLP/Parse/Decls.hs index 3e86529..5199b92 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/RLP/Parse/Decls.hs @@ -64,6 +64,31 @@ lineComment = L.skipLineComment "--" $> "" blockComment :: Parser Text blockComment = L.skipBlockCommentNested "{-" "-}" $> "" +layout :: forall a. ((OnFold) => Parser a) -> Parser [a] +layout item = scn *> (explicit <|> implicit) where + explicit :: Parser [a] + explicit = let ?foldGuard = scn -- line folds just go to the semicolon + in sym "{" *> fix \items -> choice + [ sym "}" $> [] + , (:) <$> item + <*> (sym ";" *> items <|> sym "}" $> []) + ] + where + sym = L.symbol scn + + implicit :: Parser [a] + implicit = do + i <- L.indentLevel + -- items must be aligned + let indentGuard = L.indentGuard scn EQ i + -- override foldGuard in order with new indentation + let ?foldGuard = void $ L.indentGuard scn GT i + fix \ds -> (:) <$> (indentGuard *> item) + <*> (ds <|> pure []) + +t :: (?foldGuard :: Parser ()) => Parser [Text] +t = (:) <$> lexeme "soge" <*> many (flexeme "doge") + decl :: (OnFold) => Parser PartialDecl' decl = choice -- declarations that begin with a keyword before those beginning with an @@ -80,11 +105,13 @@ funD = FunD <$> lexeme varid <*> params <*> (fsymbol "=" *> body) <*> whereClaus params = many pat1 body = fmap Const partialExpr +-- we may not need to call scn here fsymbol :: (OnFold) => Text -> Parser Text -fsymbol p = scn *> ?foldGuard *> symbol p +fsymbol p = try ?foldGuard *> symbol p +-- we may not need to call scn here flexeme :: (OnFold) => Parser a -> Parser a -flexeme p = scn *> ?foldGuard *> lexeme p +flexeme p = try ?foldGuard *> lexeme p whereClause :: Parser Where' whereClause = optionalList $ @@ -94,18 +121,19 @@ whereClause = optionalList $ standalonePartialExpr :: Parser PartialExpr' standalonePartialExpr = standaloneOf partialExpr + where ?foldGuard = undefined standaloneOf :: Parser a -> Parser a standaloneOf = (<* eof) -partialExpr :: Parser PartialExpr' +partialExpr :: (OnFold) => Parser PartialExpr' partialExpr = choice [ try application , Fix <$> infixExpr ] "expression" where - application = foldl1' mkApp <$> some partialExpr1 + application = foldl1' mkApp <$> some (flexeme partialExpr1) infixExpr = mkB <$> partialExpr1' <*> infixOp' <*> partialExpr' mkB a f b = B f a b @@ -116,7 +144,7 @@ partialExpr = choice mkApp :: PartialExpr' -> PartialExpr' -> PartialExpr' mkApp f x = Fix . E $ f `AppEF` x -partialExpr1 :: Parser PartialExpr' +partialExpr1 :: (OnFold) => Parser PartialExpr' partialExpr1 = choice [ try $ lexeme "(" *> partialExpr' <* lexeme ")" , Fix <$> varid' @@ -155,13 +183,16 @@ varid = NameVar <$> try (lexeme namevar) "variable identifier" decls :: Parser [PartialDecl'] -decls = do - space - i <- L.indentLevel - let indentGuard = L.indentGuard scn EQ i - let ?foldGuard = void $ L.indentGuard scn GT i - fix \ds -> (:) <$> (indentGuard *> decl) - <*> (try ds <|> eof *> pure []) +decls = layout decl <* eof + +-- decls :: Parser [PartialDecl'] +-- decls = do +-- space +-- i <- L.indentLevel +-- let indentGuard = L.indentGuard scn EQ i +-- let ?foldGuard = void $ L.indentGuard scn GT i +-- fix \ds -> (:) <$> (indentGuard *> decl) +-- <*> (try ds <|> eof *> pure []) namevar :: Parser Name namevar = word From 8ad967fac0207b5c6a1c14b335de14e8e7563209 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 10 Jan 2024 14:33:03 -0700 Subject: [PATCH 20/21] i did not realise my fs is case insensitive --- src/{RLP => Rlp}/Parse/Decls.hs | 4 ++-- src/{RLP => Rlp}/Parse/Types.hs | 0 src/{RLP => Rlp}/Parse/Utils.hs | 0 src/{RLP => Rlp}/Syntax.hs | 0 tst/Rlp/Parse/DeclsSpec.hs | 0 5 files changed, 2 insertions(+), 2 deletions(-) rename src/{RLP => Rlp}/Parse/Decls.hs (99%) rename src/{RLP => Rlp}/Parse/Types.hs (100%) rename src/{RLP => Rlp}/Parse/Utils.hs (100%) rename src/{RLP => Rlp}/Syntax.hs (100%) create mode 100644 tst/Rlp/Parse/DeclsSpec.hs diff --git a/src/RLP/Parse/Decls.hs b/src/Rlp/Parse/Decls.hs similarity index 99% rename from src/RLP/Parse/Decls.hs rename to src/Rlp/Parse/Decls.hs index 5199b92..d8af6ca 100644 --- a/src/RLP/Parse/Decls.hs +++ b/src/Rlp/Parse/Decls.hs @@ -128,8 +128,8 @@ standaloneOf = (<* eof) partialExpr :: (OnFold) => Parser PartialExpr' partialExpr = choice - [ try application - , Fix <$> infixExpr + [ try $ Fix <$> infixExpr + , application ] "expression" where diff --git a/src/RLP/Parse/Types.hs b/src/Rlp/Parse/Types.hs similarity index 100% rename from src/RLP/Parse/Types.hs rename to src/Rlp/Parse/Types.hs diff --git a/src/RLP/Parse/Utils.hs b/src/Rlp/Parse/Utils.hs similarity index 100% rename from src/RLP/Parse/Utils.hs rename to src/Rlp/Parse/Utils.hs diff --git a/src/RLP/Syntax.hs b/src/Rlp/Syntax.hs similarity index 100% rename from src/RLP/Syntax.hs rename to src/Rlp/Syntax.hs diff --git a/tst/Rlp/Parse/DeclsSpec.hs b/tst/Rlp/Parse/DeclsSpec.hs new file mode 100644 index 0000000..e69de29 From cb9ec43c14e69373e8cafffbd8f18e85ab9956b3 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Wed, 10 Jan 2024 15:11:26 -0700 Subject: [PATCH 21/21] tysigs --- src/Rlp/Parse/Decls.hs | 43 +++++++++++++++++++++--------------------- src/Rlp/Parse/Types.hs | 3 +++ 2 files changed, 25 insertions(+), 21 deletions(-) diff --git a/src/Rlp/Parse/Decls.hs b/src/Rlp/Parse/Decls.hs index d8af6ca..d61c0d4 100644 --- a/src/Rlp/Parse/Decls.hs +++ b/src/Rlp/Parse/Decls.hs @@ -83,7 +83,7 @@ layout item = scn *> (explicit <|> implicit) where let indentGuard = L.indentGuard scn EQ i -- override foldGuard in order with new indentation let ?foldGuard = void $ L.indentGuard scn GT i - fix \ds -> (:) <$> (indentGuard *> item) + fix \ds -> (:) <$> (indentGuard *> item <* scn) <*> (ds <|> pure []) t :: (?foldGuard :: Parser ()) => Parser [Text] @@ -95,7 +95,7 @@ decl = choice -- arbitrary name [ infixD , dataD - , funD + , try funD , tySigD ] @@ -182,17 +182,11 @@ varid = NameVar <$> try (lexeme namevar) <|> SymVar <$> lexeme (char '(' *> symvar <* char ')') "variable identifier" -decls :: Parser [PartialDecl'] -decls = layout decl <* eof - --- decls :: Parser [PartialDecl'] --- decls = do --- space --- i <- L.indentLevel --- let indentGuard = L.indentGuard scn EQ i --- let ?foldGuard = void $ L.indentGuard scn GT i --- fix \ds -> (:) <$> (indentGuard *> decl) --- <*> (try ds <|> eof *> pure []) +program :: Parser [Decl' RlpExpr] +program = do + ds <- layout decl <* eof + pt <- use psOpTable + pure $ complete pt <$> ds namevar :: Parser Name namevar = word @@ -255,10 +249,10 @@ infixD = do f (Just x) = registerCustomFailure RlpParErrDuplicateInfixD $> Just x -tySigD :: Parser (Decl' e) -tySigD = undefined -- TySigD <$> (flexeme) +tySigD :: (OnFold) => Parser (Decl' e) +tySigD = TySigD <$> (pure <$> varid) <*> (flexeme "::" *> flexeme type_) -dataD :: Parser (Decl' e) +dataD :: (OnFold) => Parser (Decl' e) dataD = DataD <$> (lexeme "data" *> conid) <*> many typaram <*> optionalList (symbol "=" *> conalts) where @@ -271,16 +265,16 @@ dataD = DataD <$> (lexeme "data" *> conid) <*> many typaram conalt :: Parser ConAlt conalt = ConAlt <$> conid <*> many type1 -type1 :: Parser Type +type1 :: (OnFold) => Parser Type type1 = choice [ lexeme "(" *> type_ <* lexeme ")" , TyVar <$> namevar , TyCon <$> namecon ] -type_ :: Parser Type +type_ :: (OnFold) => Parser Type type_ = choice - [ try $ (:->) <$> type1 <*> (lexeme "->" *> type_) + [ try $ (:->) <$> type1 <*> (flexeme "->" *> type_) , type1 ] @@ -293,8 +287,15 @@ lit = int -------------------------------------------------------------------------------- -- completing partial expressions -complete :: (?pt :: OpTable) => PartialExpr' -> RlpExpr' -complete = cata completePartial +complete :: OpTable -> PartialDecl' -> Decl' RlpExpr +complete pt (FunD n as b w) = FunD n as b' w + where b' = let ?pt = pt in completeExpr (getConst b) +complete pt (TySigD ns t) = TySigD ns t +complete pt (DataD n as cs) = DataD n as cs +complete pt (InfixD a p n) = InfixD a p n + +completeExpr :: (?pt :: OpTable) => PartialExpr' -> RlpExpr' +completeExpr = cata completePartial completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr' completePartial (E e) = completeRlpExpr e diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index e961d2d..41e67f8 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -42,6 +42,9 @@ import Rlp.Syntax -- parser types +-- TODO: the State is only used for building an operator table from infix[lr] +-- declarations. we should switch to a normal Parsec monad in the future + type Parser = ParsecT RlpParseError Text (State ParserState) data ParserState = ParserState