From de3c39d118730ff7d87350fabcbd5020da63134d Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 22 Feb 2024 15:08:55 -0700 Subject: [PATCH] parser compiles --- src/Core.hs | 1 - src/Core/Parse.y | 51 ++++++++++++++++++++++------------------- src/Core/Parse/Types.hs | 49 +++++++++++++++++++++++++++++++++++++++ src/Core/Syntax.hs | 29 +++++++++++++++++++++-- 4 files changed, 103 insertions(+), 27 deletions(-) create mode 100644 src/Core/Parse/Types.hs diff --git a/src/Core.hs b/src/Core.hs index 04ef41c..19e5fd9 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -1,6 +1,5 @@ module Core ( module Core.Syntax - , parseCore , parseCoreProg , parseCoreExpr , lexCore diff --git a/src/Core/Parse.y b/src/Core/Parse.y index f432479..89111f6 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -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 $ "" <> ":" <> "" <> ": 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 } diff --git a/src/Core/Parse/Types.hs b/src/Core/Parse/Types.hs new file mode 100644 index 0000000..564fa76 --- /dev/null +++ b/src/Core/Parse/Types.hs @@ -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 + diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index e125fa0..4b511ad 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -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) +