msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

where

Browse Source
This commit is contained in:
crumbtoo
2024-01-09 14:24:51 -07:00
parent 074350768c
commit 90a9594e8f
4 changed files with 119 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files

93
src/RLP/Parse/Decls.hs
View File

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

7
src/RLP/Parse/Types.hs
View File

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

30
src/RLP/Parse/Utils.hs Normal file
View File

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

24
src/RLP/Syntax.hs
View File

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