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 +