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

parser compiles

Browse Source
This commit is contained in:
crumbtoo
2024-02-22 15:08:55 -07:00
parent 4a120f9899
commit de3c39d118
4 changed files with 103 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
src/Core.hs
View File

@@ -1,6 +1,5 @@
module Core
( module Core.Syntax
, parseCore
, parseCoreProg
, parseCoreExpr
, lexCore

51
src/Core/Parse.y
View File

@@ -5,8 +5,7 @@ Description : Parser for the Core language
-}
{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
module Core.Parse
( parseCore
, parseCoreExpr
( parseCoreExpr
, parseCoreExprR
, parseCoreProg
, parseCoreProgR
@@ -31,13 +30,15 @@ import Data.Text.IO qualified as TIO
import Data.Text (Text)
import Data.Text qualified as T
import Data.HashMap.Strict qualified as H
import Core.Parse.Types
}
%name parseCoreExpr StandaloneExpr
%name parseCoreProg StandaloneProgram
%tokentype { Located CoreToken }
%error { parseError }
%monad { RLPC } { happyBind } { happyPure }
%monad { P }
%token
let { Located _ TokenLet }
@@ -74,12 +75,12 @@ Eof :: { () }
Eof : eof { () }
| error { () }
StandaloneProgram :: { Program Var }
StandaloneProgram :: { Program PsName }
StandaloneProgram : Program eof { $1 }
Program :: { Program Var }
Program : ScTypeSig ';' Program { insTypeSig $1 $3 }
| ScTypeSig OptSemi { singletonTypeSig $1 }
Program :: { Program PsName }
Program : ScTypeSig ';' Program { insTypeSig ($1 & _1 %~ Left) $3 }
| ScTypeSig OptSemi { singletonTypeSig ($1 & _1 %~ Left) }
| ScDef ';' Program { insScDef $1 $3 }
| ScDef OptSemi { singletonScDef $1 }
| TLPragma Program {% doTLPragma $1 $2 }
@@ -105,24 +106,25 @@ ScDefs : ScDef ';' ScDefs { $1 : $3 }
| ScDef { [$1] }
ScDef :: { ScDef PsName }
ScDef : Id ParList '=' Expr { ScDef ($1,Nothing) $2 $4 }
ScDef : Id ParList '=' Expr { ScDef (Left $1) $2
($4 & _binders %~ Right) }
Type :: { [(Name, Kind)] -> Kind -> Type }
: Type1 '->' Type { \cases
g TyKindType ->
$1 g TyKindType :-> $3 g TyKindType
_ _ -> error "kind mismatch" }
Type :: { Kind -> Type }
: Type1 '->' Type { \case
TyKindType ->
$1 TyKindType :-> $3 TyKindType
_ -> error "kind mismatch" }
| Type1 { $1 }
-- do we want to allow symbolic names for tyvars and tycons?
Type1 :: { [(Name, Kind)] -> Kind -> Type }
Type1 :: { Kind -> Type }
Type1 : '(' Type ')' { $2 }
| varname { \k -> TyVar $ MkVar $1 k }
| conname { \k -> TyCon $ MkTyCon $1 k }
ParList :: { [PsName] }
ParList : varname ParList { ($1, Nothing) : $2 }
ParList : varname ParList { Left $1 : $2 }
| {- epsilon -} { [] }
StandaloneExpr :: { Expr Var }
@@ -148,7 +150,7 @@ Application : Application AppArg { App $1 $2 }
| Expr1 AppArg { App $1 $2 }
AppArg :: { Expr Var }
: '@' Type1 { Type ($2 [] TyKindInferred) }
: '@' Type1 { Type ($2 TyKindInferred) }
| Expr1 { $1 }
CaseExpr :: { Expr Var }
@@ -189,11 +191,11 @@ Id :: { Name }
| conname { $1 }
Var :: { Var }
Var : '(' varname '::' Type ')' { MkVar $2 ($4 [] TyKindType) }
Var : '(' varname '::' Type ')' { MkVar $2 ($4 TyKindType) }
{
parseError :: [Located CoreToken] -> RLPC a
parseError :: [Located CoreToken] -> P a
parseError (Located _ t : _) =
error $ "<line>" <> ":" <> "<col>"
<> ": parse error at token `" <> show t <> "'"
@@ -224,12 +226,13 @@ singletonScDef :: (Hashable b) => ScDef b -> Program b
singletonScDef sc = insScDef sc mempty
parseCoreExprR :: (Monad m) => [Located CoreToken] -> RLPCT m (Expr Var)
parseCoreExprR = hoistRlpcT generalise . parseCoreExpr
parseCoreExprR = liftMaybe . snd . flip runP def . parseCoreExpr
parseCoreProgR :: forall m. (Monad m) => [Located CoreToken] -> RLPCT m (Program Var)
parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
parseCoreProgR :: forall m. (Monad m)
=> [Located CoreToken] -> RLPCT m (Program PsName)
parseCoreProgR s = ddumpast =<< (liftMaybe . snd $ runP (parseCoreProg s) def)
where
ddumpast :: (Program Var) -> RLPCT m (Program Var)
ddumpast :: (Program PsName) -> RLPCT m (Program PsName)
ddumpast p = do
addDebugMsg "dump-parsed-core" . show $ p
pure p
@@ -240,7 +243,7 @@ happyBind m k = m >>= k
happyPure :: a -> RLPC a
happyPure a = pure a
doTLPragma :: Pragma -> Program' -> RLPC Program'
doTLPragma :: Pragma -> Program PsName -> P (Program PsName)
-- TODO: warn unrecognised pragma
doTLPragma (Pragma []) p = pure p
@@ -252,7 +255,7 @@ doTLPragma (Pragma pr) p = case pr of
readt :: (Read a) => Text -> a
readt = read . T.unpack
type PsName = (Name, Maybe Type)
type PsName = Either Name Var
}

49
src/Core/Parse/Types.hs Normal file
View File

@@ -0,0 +1,49 @@
{-# LANGUAGE TemplateHaskell #-}
module Core.Parse.Types
( P(..)
, psTyVars
, def
)
where
--------------------------------------------------------------------------------
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Default
import Data.Tuple (swap)
import Control.Lens
import Core.Syntax
--------------------------------------------------------------------------------
newtype P a = P { runP :: PState -> (PState, Maybe a) }
deriving Functor
data PState = PState
{ _psTyVars :: [(Name, Kind)]
}
instance Applicative P where
pure a = P (, Just a)
P pf <*> P pa = P \st ->
let (st',mf) = pf st
(st'',ma) = pa st'
in (st'', mf <*> ma)
instance Monad P where
P pa >>= k = P \st ->
let (st',ma) = pa st
in case ma of
Just a -> runP (k a) st'
Nothing -> (st', Nothing)
instance MonadState PState P where
state = P . fmap ((_2 %~ Just) . review swapped)
instance Default PState where
def = undefined
makeLenses ''PState

29
src/Core/Syntax.hs
View File

@@ -19,7 +19,7 @@ module Core.Syntax
, Pragma(..)
-- ** Variables and identifiers
, Name, Var(..), TyCon(..), Tag
, Binding(..), pattern (:=)
, Binding(..), pattern (:=), pattern (:$)
, type Binding'
-- ** Working with the fixed point of ExprF
, Expr, Expr'
@@ -33,6 +33,7 @@ module Core.Syntax
, programScDefs, programTypeSigs, programDataTags
, formalising
, HasRHS(_rhs), HasLHS(_lhs)
, HasBinders(_binders)
)
where
----------------------------------------------------------------------------------
@@ -49,6 +50,7 @@ import Data.Char
import Data.These
import GHC.Generics (Generic, Generically(..))
import Text.Show.Deriving
import Data.Eq.Deriving
import Data.Fix hiding (cata, ana)
import Data.Bifoldable (bifoldr)
@@ -89,6 +91,9 @@ data TyCon = MkTyCon Name Kind
data Var = MkVar Name Type
deriving (Eq, Show, Lift)
instance Hashable Var where
hashWithSalt s (MkVar n _) = hashWithSalt s n
pattern Con :: Tag -> Int -> Expr b
pattern Con t a = Fix (ConF t a)
@@ -129,6 +134,10 @@ infixl 1 :=
pattern (:=) :: b -> Expr b -> Binding b
pattern k := v = Binding k v
infixl 2 :$
pattern (:$) :: Expr b -> Expr b -> Expr b
pattern f :$ x = App f x
data Alter b = Alter AltCon [b] (Expr b)
newtype Pragma = Pragma [T.Text]
@@ -159,7 +168,7 @@ data Module b = Module (Maybe (Name, [Name])) (Program b)
data Program b = Program
{ _programScDefs :: [ScDef b]
, _programTypeSigs :: HashMap b Type
, _programDataTags :: HashMap b (Tag, Int)
, _programDataTags :: HashMap Name (Tag, Int)
-- ^ map constructors to their tag and arity
}
deriving (Generic)
@@ -189,6 +198,14 @@ instance IsString (Expr b) where
----------------------------------------------------------------------------------
class HasBinders s t a b | s -> a, t -> b, s b -> t, t a -> s where
_binders :: Traversal s t a b
instance HasBinders (Expr b) (Expr b') b b' where
_binders k = cata go where
go :: Applicative f => ExprF b (f (Expr b')) -> f (Expr b')
go = undefined
class HasRHS s t a b | s -> a, t -> b, s b -> t, t a -> s where
_rhs :: Lens s t a b
@@ -356,7 +373,15 @@ instance Lift b => Lift1 (ExprF b) where
deriving instance (Show b, Show a) => Show (ExprF b a)
deriving instance Show b => Show (Binding b)
deriving instance Show b => Show (Alter b)
deriving instance Show b => Show (ScDef b)
deriving instance Show b => Show (Program b)
deriving instance Lift b => Lift (Binding b)
deriving instance Lift b => Lift (Alter b)
deriveEq1 ''ExprF
deriving instance Eq b => Eq (Alter b)
deriving instance Eq b => Eq (Binding b)
deriving instance (Eq a, Eq b) => Eq (ExprF b a)