140 lines
3.5 KiB
Haskell
140 lines
3.5 KiB
Haskell
-- 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 "--" $> "<unimpl>"
|
|
|
|
-- TODO: return comment text
|
|
blockComment :: Parser Text
|
|
blockComment = L.skipBlockCommentNested "{-" "-}" $> "<unimpl>"
|
|
|
|
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
|
|
|