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

no-ttg

Browse Source
This commit is contained in:
crumbtoo
2024-02-16 15:11:08 -07:00
parent e9cab1ddaf
commit caeec216b5
4 changed files with 157 additions and 138 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
rlp.cabal
View File

@@ -73,6 +73,7 @@ library
, effectful-core ^>=2.3.0.0 , effectful-core ^>=2.3.0.0
, deriving-compat ^>=0.6.0 , deriving-compat ^>=0.6.0
, these >=0.2 && <2.0 , these >=0.2 && <2.0
, free
hs-source-dirs: src hs-source-dirs: src
default-language: GHC2021 default-language: GHC2021

237
src/Rlp/Parse.y
View File

@@ -71,180 +71,175 @@ import Compiler.Types
%% %%
StandaloneProgram :: { RlpProgram RlpcPs } StandaloneProgram :: { Program RlpcPs }
StandaloneProgram : '{' Decls '}' {% mkProgram $2 } StandaloneProgram : '{' Decls '}' { undefined }
| VL DeclsV VR {% mkProgram $2 } | VL DeclsV VR { undefined }
StandaloneExpr :: { RlpExpr RlpcPs } StandaloneExpr :: { Expr RlpcPs }
: VL Expr VR { extract $2 } : VL Expr VR { undefined }
VL :: { () } VL :: { () }
VL : vlbrace { () } VL : vlbrace { undefined }
VR :: { () } VR :: { () }
VR : vrbrace { () } VR : vrbrace { undefined }
| error { () } | error { undefined }
Decls :: { [Decl' RlpcPs] } Decls :: { [Decl RlpcPs] }
Decls : Decl ';' Decls { $1 : $3 } Decls : Decl ';' Decls { undefined }
| Decl ';' { [$1] } | Decl ';' { undefined }
| Decl { [$1] } | Decl { undefined }
DeclsV :: { [Decl' RlpcPs] } DeclsV :: { [Decl RlpcPs] }
DeclsV : Decl VS DeclsV { $1 : $3 } DeclsV : Decl VS DeclsV { undefined }
| Decl VS { [$1] } | Decl VS { undefined }
| Decl { [$1] } | Decl { undefined }
VS :: { Located RlpToken } VS :: { Located RlpToken }
VS : ';' { $1 } VS : ';' { undefined }
| vsemi { $1 } | vsemi { undefined }
Decl :: { Decl' RlpcPs } Decl :: { Decl RlpcPs }
: FunDecl { $1 } : FunDecl { undefined }
| TySigDecl { $1 } | TySigDecl { undefined }
| DataDecl { $1 } | DataDecl { undefined }
| InfixDecl { $1 } | InfixDecl { undefined }
TySigDecl :: { Decl' RlpcPs } TySigDecl :: { Decl RlpcPs }
: Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 } : Var '::' Type { undefined }
InfixDecl :: { Decl' RlpcPs } InfixDecl :: { Decl RlpcPs }
: InfixWord litint InfixOp { $1 =>> \w -> : InfixWord litint InfixOp { undefined }
InfixD (extract $1) (extractInt $ extract $2)
(extract $3) }
InfixWord :: { Located Assoc } InfixWord :: { Located Assoc }
: infixl { $1 \$> InfixL } : infixl { undefined }
| infixr { $1 \$> InfixR } | infixr { undefined }
| infix { $1 \$> Infix } | infix { undefined }
DataDecl :: { Decl' RlpcPs } DataDecl :: { Decl RlpcPs }
: data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 } : data Con TyParams '=' DataCons { undefined }
TyParams :: { [PsName] } TyParams :: { [PsName] }
: {- epsilon -} { [] } : {- epsilon -} { undefined }
| TyParams varname { $1 `snoc` (extractName . extract $ $2) } | TyParams varname { undefined }
DataCons :: { [ConAlt RlpcPs] } DataCons :: { [ConAlt RlpcPs] }
: DataCons '|' DataCon { $1 `snoc` $3 } : DataCons '|' DataCon { undefined }
| DataCon { [$1] } | DataCon { undefined }
DataCon :: { ConAlt RlpcPs } DataCon :: { ConAlt RlpcPs }
: Con Type1s { ConAlt (extract $1) $2 } : Con Type1s { undefined }
Type1s :: { [RlpType' RlpcPs] } Type1s :: { [Ty RlpcPs] }
: {- epsilon -} { [] } : {- epsilon -} { undefined }
| Type1s Type1 { $1 `snoc` $2 } | Type1s Type1 { undefined }
Type1 :: { RlpType' RlpcPs } Type1 :: { Ty RlpcPs }
: '(' Type ')' { $2 } : '(' Type ')' { undefined }
| conname { fmap ConT (mkPsName $1) } | conname { undefined }
| varname { fmap VarT (mkPsName $1) } | varname { undefined }
Type :: { RlpType' RlpcPs } Type :: { Ty RlpcPs }
: Type '->' Type { FunT <<~ $1 <~> $3 } : Type '->' Type { undefined }
| TypeApp { $1 } | TypeApp { undefined }
TypeApp :: { RlpType' RlpcPs } TypeApp :: { Ty RlpcPs }
: Type1 { $1 } : Type1 { undefined }
| TypeApp Type1 { AppT <<~ $1 <~> $2 } | TypeApp Type1 { undefined }
FunDecl :: { Decl' RlpcPs } FunDecl :: { Decl RlpcPs }
FunDecl : Var Params '=' Expr { $4 =>> \e -> FunDecl : Var Params '=' Expr { undefined }
FunD (extract $1) $2 e Nothing }
Params :: { [Pat' RlpcPs] } Params :: { [Pat RlpcPs] }
Params : {- epsilon -} { [] } Params : {- epsilon -} { undefined }
| Params Pat1 { $1 `snoc` $2 } | Params Pat1 { undefined }
Pat :: { Pat' RlpcPs } Pat :: { Pat RlpcPs }
: Con Pat1s { $1 =>> \cn -> : Con Pat1s { undefined }
ConP (extract $1) $2 } | Pat1 { undefined }
| Pat1 { $1 }
Pat1s :: { [Pat' RlpcPs] } Pat1s :: { [Pat RlpcPs] }
: Pat1s Pat1 { $1 `snoc` $2 } : Pat1s Pat1 { undefined }
| Pat1 { [$1] } | Pat1 { undefined }
Pat1 :: { Pat' RlpcPs } Pat1 :: { Pat RlpcPs }
: Con { fmap (`ConP` []) $1 } : Con { undefined }
| Var { fmap VarP $1 } | Var { undefined }
| Lit { LitP <<= $1 } | Lit { undefined }
| '(' Pat ')' { $1 .> $2 <. $3 } | '(' Pat ')' { undefined }
Expr :: { RlpExpr' RlpcPs } Expr :: { Expr RlpcPs }
-- infixities delayed till next release :( -- infixities delayed till next release :(
-- : Expr1 InfixOp Expr { $2 =>> \o -> -- : Expr1 InfixOp Expr { undefined }
-- OAppE (extract o) $1 $3 } : TempInfixExpr { undefined }
: TempInfixExpr { $1 } | LetExpr { undefined }
| LetExpr { $1 } | CaseExpr { undefined }
| CaseExpr { $1 } | AppExpr { undefined }
| AppExpr { $1 }
TempInfixExpr :: { RlpExpr' RlpcPs } TempInfixExpr :: { Expr RlpcPs }
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 } TempInfixExpr : Expr1 InfixOp TempInfixExpr { undefined }
| Expr1 InfixOp Expr1 { $2 =>> \o -> | Expr1 InfixOp Expr1 { undefined }
OAppE (extract o) $1 $3 }
AppExpr :: { RlpExpr' RlpcPs } AppExpr :: { Expr RlpcPs }
: Expr1 { $1 } : Expr1 { undefined }
| AppExpr Expr1 { AppE <<~ $1 <~> $2 } | AppExpr Expr1 { undefined }
LetExpr :: { RlpExpr' RlpcPs } LetExpr :: { Expr RlpcPs }
: let layout1(Binding) in Expr { $1 \$> LetE $2 $4 } : let layout1(Binding) in Expr { undefined }
| letrec layout1(Binding) in Expr { $1 \$> LetrecE $2 $4 } | letrec layout1(Binding) in Expr { undefined }
CaseExpr :: { RlpExpr' RlpcPs } CaseExpr :: { Expr RlpcPs }
: case Expr of layout0(CaseAlt) : case Expr of layout0(CaseAlt) { undefined }
{ CaseE <<~ $2 <#> $4 }
-- TODO: where-binds -- TODO: where-binds
CaseAlt :: { (Alt RlpcPs, Where RlpcPs) } CaseAlt :: { (Alt RlpcPs, Where RlpcPs) }
: Alt { ($1, []) } : Alt { undefined }
Alt :: { Alt RlpcPs } Alt :: { Alt RlpcPs }
: Pat '->' Expr { AltA $1 $3 } : Pat '->' Expr { undefined }
-- layout0(p : β) :: [β] -- layout0(p : β) :: [β]
layout0(p) : '{' layout_list0(';',p) '}' { $2 } layout0(p) : '{' layout_list0(';',p) '}' { undefined }
| VL layout_list0(VS,p) VR { $2 } | VL layout_list0(VS,p) VR { undefined }
-- layout_list0(sep : α, p : β) :: [β] -- layout_list0(sep : α, p : β) :: [β]
layout_list0(sep,p) : p { [$1] } layout_list0(sep,p) : p { undefined }
| layout_list1(sep,p) sep p { $1 `snoc` $3 } | layout_list1(sep,p) sep p { undefined }
| {- epsilon -} { [] } | {- epsilon -} { undefined }
-- layout1(p : β) :: [β] -- layout1(p : β) :: [β]
layout1(p) : '{' layout_list1(';',p) '}' { $2 } layout1(p) : '{' layout_list1(';',p) '}' { undefined }
| VL layout_list1(VS,p) VR { $2 } | VL layout_list1(VS,p) VR { undefined }
-- layout_list1(sep : α, p : β) :: [β] -- layout_list1(sep : α, p : β) :: [β]
layout_list1(sep,p) : p { [$1] } layout_list1(sep,p) : p { undefined }
| layout_list1(sep,p) sep p { $1 `snoc` $3 } | layout_list1(sep,p) sep p { undefined }
Binding :: { Binding' RlpcPs } Binding :: { Binding RlpcPs }
: Pat '=' Expr { PatB <<~ $1 <~> $3 } : Pat '=' Expr { undefined }
Expr1 :: { RlpExpr' RlpcPs } Expr1 :: { Expr RlpcPs }
: '(' Expr ')' { $1 .> $2 <. $3 } : '(' Expr ')' { undefined }
| Lit { fmap LitE $1 } | Lit { undefined }
| Var { fmap VarE $1 } | Var { undefined }
| Con { fmap VarE $1 } | Con { undefined }
InfixOp :: { Located PsName } InfixOp :: { Located PsName }
: consym { mkPsName $1 } : consym { undefined }
| varsym { mkPsName $1 } | varsym { undefined }
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms) -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
Lit :: { Lit' RlpcPs } Lit :: { Lit RlpcPs }
: litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) } : litint { undefined }
Var :: { Located PsName } Var :: { Located PsName }
Var : varname { mkPsName $1 } Var : varname { undefined }
| varsym { mkPsName $1 } | varsym { undefined }
Con :: { Located PsName } Con :: { Located PsName }
: conname { mkPsName $1 } : conname { undefined }
--}
{ {
@@ -253,12 +248,12 @@ parseRlpExprR = undefined
{-- {--
parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs) parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs)
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
where where
st = programInitState s st = programInitState s
parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs) parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs)
parseRlpProgR s = do parseRlpProgR s = do
a <- liftErrorful $ pToErrorful parseRlpProg st a <- liftErrorful $ pToErrorful parseRlpProg st
addDebugMsg @_ @String "dump-parsed" $ show a addDebugMsg @_ @String "dump-parsed" $ show a
@@ -281,12 +276,12 @@ extractInt :: RlpToken -> Int
extractInt (TokenLitInt n) = n extractInt (TokenLitInt n) = n
extractInt _ = error "extractInt: ugh" extractInt _ = error "extractInt: ugh"
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs) mkProgram :: [Decl RlpcPs] -> P (Program RlpcPs)
mkProgram ds = do mkProgram ds = do
pt <- use psOpTable pt <- use psOpTable
pure $ RlpProgram (associate pt <$> ds) pure $ Program (associate pt <$> ds)
mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs) mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs)
mkInfixD a p n = do mkInfixD a p n = do
let opl :: Lens' ParseState (Maybe OpInfo) let opl :: Lens' ParseState (Maybe OpInfo)
opl = psOpTable . at n opl = psOpTable . at n
@@ -302,7 +297,7 @@ mkInfixD a p n = do
intOfToken :: Located RlpToken -> Int intOfToken :: Located RlpToken -> Int
intOfToken (Located _ (TokenLitInt n)) = n intOfToken (Located _ (TokenLitInt n)) = n
tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
tempInfixExprErr (Located a _) (Located b _) = tempInfixExprErr (Located a _) (Located b _) =
addFatal $ errorMsg (a <> b) $ RlpParErrOther addFatal $ errorMsg (a <> b) $ RlpParErrOther
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :(" [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("

18
src/Rlp/Parse/Types.hs
View File

@@ -256,13 +256,13 @@ initAlexInput s = AlexInput
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
deriving instance Lift (Program RlpcPs) -- deriving instance Lift (Program RlpcPs)
deriving instance Lift (Decl RlpcPs) -- deriving instance Lift (Decl RlpcPs)
deriving instance Lift (Pat RlpcPs) -- deriving instance Lift (Pat RlpcPs)
deriving instance Lift (Lit RlpcPs) -- deriving instance Lift (Lit RlpcPs)
deriving instance Lift (Expr RlpcPs) -- deriving instance Lift (Expr RlpcPs)
deriving instance Lift (Binding RlpcPs) -- deriving instance Lift (Binding RlpcPs)
deriving instance Lift (Ty RlpcPs) -- deriving instance Lift (Ty RlpcPs)
deriving instance Lift (Alt RlpcPs) -- deriving instance Lift (Alt RlpcPs)
deriving instance Lift (ConAlt RlpcPs) -- deriving instance Lift (ConAlt RlpcPs)

39
src/Rlp/Syntax.hs
View File

@@ -1,8 +1,6 @@
-- recursion-schemes -- recursion-schemes
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable {-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-}
, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-} {-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-} {-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
module Rlp.Syntax module Rlp.Syntax
( (
@@ -17,20 +15,24 @@ module Rlp.Syntax
, Pat(..) , Pat(..)
, Decl(..) , Decl(..)
, Program(..) , Program(..)
, Where
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
import Data.Text (Text) import Data.Text (Text)
import Data.Text qualified as T import Data.Text qualified as T
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.Functor.Classes import Data.Functor.Classes
import Data.Functor.Identity import Data.Functor.Identity
import Data.Kind (Type) import Data.Kind (Type)
import GHC.Generics import GHC.Generics
import Language.Haskell.TH.Syntax (Lift) import Language.Haskell.TH.Syntax (Lift)
import Control.Lens import Control.Lens
import Control.Comonad.Cofree
import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Core.Syntax qualified as Core import Core.Syntax qualified as Core
import Core (Rec(..), HasRHS(..), HasLHS(..)) import Core (Rec(..), HasRHS(..), HasLHS(..))
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -38,13 +40,18 @@ import Core (Rec(..), HasRHS(..), HasLHS(..))
type PsName = Text type PsName = Text
type family NameP p type family NameP p
data Program p data Program p = Program
{ _programDecls :: [Decl p]
}
deriving instance (Show (NameP p)) => Show (Program p)
data Decl p = FunD (NameP p) [Pat p] (Expr p) (Maybe (Where p)) data Decl p = FunD (NameP p) [Pat p] (Expr p) (Maybe (Where p))
| TySigD [NameP p] (Ty p) | TySigD [NameP p] (Ty p)
| DataD (NameP p) [NameP p] [ConAlt p] | DataD (NameP p) [NameP p] [ConAlt p]
| InfixD Assoc Int (NameP p) | InfixD Assoc Int (NameP p)
deriving instance (Lift (NameP p)) => Lift (Decl p)
deriving instance (Show (NameP p)) => Show (Decl p) deriving instance (Show (NameP p)) => Show (Decl p)
data Expr p = LetE Rec [Binding p] (Expr p) data Expr p = LetE Rec [Binding p] (Expr p)
@@ -58,34 +65,50 @@ data Expr p = LetE Rec [Binding p] (Expr p)
| InfixE (NameP p) (Expr p) (Expr p) | InfixE (NameP p) (Expr p) (Expr p)
deriving (Generic) deriving (Generic)
deriving instance (Lift (NameP p)) => Lift (Expr p)
deriving instance (Show (NameP p)) => Show (Expr p) deriving instance (Show (NameP p)) => Show (Expr p)
data ConAlt p = ConAlt (NameP p) [Ty p] data ConAlt p = ConAlt (NameP p) [Ty p]
deriving instance (Lift (NameP p)) => Lift (ConAlt p)
deriving instance (Show (NameP p)) => Show (ConAlt p) deriving instance (Show (NameP p)) => Show (ConAlt p)
data Ty p data Ty p = TyCon (NameP p)
deriving Show
deriving instance (Show (NameP p)) => Show (Ty p)
deriving instance (Lift (NameP p)) => Lift (Ty p)
data Pat p = VarP (NameP p) data Pat p = VarP (NameP p)
| LitP (Lit p) | LitP (Lit p)
| ConP (NameP p) [Pat p] | ConP (NameP p) [Pat p]
deriving instance (Lift (NameP p)) => Lift (Pat p)
deriving instance (Show (NameP p)) => Show (Pat p) deriving instance (Show (NameP p)) => Show (Pat p)
data Binding p = PatB (Pat p) (Expr p) data Binding p = PatB (Pat p) (Expr p)
deriving instance (Lift (NameP p)) => Lift (Binding p)
deriving instance (Show (NameP p)) => Show (Binding p) deriving instance (Show (NameP p)) => Show (Binding p)
data Lit p = IntL Int data Lit p = IntL Int
deriving Show deriving Show
deriving instance (Lift (NameP p)) => Lift (Lit p)
data Alt p = AltA (Pat p) (Expr p) (Maybe (Where p)) data Alt p = AltA (Pat p) (Expr p) (Maybe (Where p))
deriving instance (Show (NameP p)) => Show (Alt p) deriving instance (Show (NameP p)) => Show (Alt p)
deriving instance (Lift (NameP p)) => Lift (Alt p)
type Where p = [Binding p] type Where p = [Binding p]
data Assoc = InfixL | InfixR | Infix data Assoc = InfixL | InfixR | Infix
deriving (Lift, Show) deriving (Lift, Show)
--------------------------------------------------------------------------------
makeBaseFunctor ''Expr
makeLenses ''Program
type Expr' p = Cofree (ExprF p)