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

backstage

Browse Source
This commit is contained in:
crumbtoo
2024-02-17 01:56:29 -07:00
parent 22f19ce9a5
commit 9c498bd0ea
7 changed files with 180 additions and 142 deletions
Download Patch File Download Diff File Expand all files Collapse all files

41
src/Rlp/Parse.y
View File

@@ -71,11 +71,11 @@ import Compiler.Types
%%
StandaloneProgram :: { Program RlpcPs }
StandaloneProgram :: { Program RlpcPs SrcSpan }
StandaloneProgram : layout0(Decl) { Program $1 }
StandaloneExpr :: { Expr RlpcPs }
: VL Expr VR { $2 }
: VL Expr VR { undefined }
VL :: { () }
VL : vlbrace { () }
@@ -88,24 +88,24 @@ VS :: { () }
VS : ';' { () }
| vsemi { () }
Decl :: { Decl RlpcPs }
: FunDecl { undefined }
| TySigDecl { undefined }
| DataDecl { undefined }
| InfixDecl { undefined }
Decl :: { Decl RlpcPs SrcSpan }
: FunDecl { $1 }
| TySigDecl { $1 }
| DataDecl { $1 }
| InfixDecl { $1 }
TySigDecl :: { Decl RlpcPs }
: Var '::' Type { undefined }
TySigDecl :: { Decl RlpcPs SrcSpan }
: Var '::' Type { TySigD [$1] $3 }
InfixDecl :: { Decl RlpcPs }
: InfixWord litint InfixOp { mkInfixD $1 ($2 ^. _litint) $3 }
InfixDecl :: { Decl RlpcPs SrcSpan }
: InfixWord litint InfixOp {% mkInfixD $1 ($2 ^. _litint) $3 }
InfixWord :: { Located Assoc }
: infixl { $1 \$> InfixL }
| infixr { $1 \$> InfixR }
| infix { $1 \$> Infix }
InfixWord :: { Assoc }
: infixl { InfixL }
| infixr { InfixR }
| infix { Infix }
DataDecl :: { Decl RlpcPs }
DataDecl :: { Decl RlpcPs SrcSpan }
: data Con TyParams '=' DataCons { undefined }
TyParams :: { [PsName] }
@@ -136,7 +136,7 @@ TypeApp :: { Ty RlpcPs }
: Type1 { undefined }
| TypeApp Type1 { undefined }
FunDecl :: { Decl RlpcPs }
FunDecl :: { Decl RlpcPs SrcSpan }
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
Params :: { [Pat RlpcPs] }
@@ -157,7 +157,7 @@ Pat1 :: { Pat RlpcPs }
| Lit { undefined }
| '(' Pat ')' { undefined }
Expr :: { Expr RlpcPs }
Expr :: { Expr' RlpcPs SrcSpan }
-- infixities delayed till next release :(
-- : Expr1 InfixOp Expr { undefined }
: TempInfixExpr { undefined }
@@ -235,7 +235,7 @@ Con :: { PsName }
parseRlpProgR = undefined
parseRlpExprR = undefined
mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs)
mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan)
mkInfixD a p ln@(Located ss n) = do
let opl :: Lens' ParseState (Maybe OpInfo)
opl = psOpTable . at n
@@ -278,7 +278,7 @@ extractInt :: RlpToken -> Int
extractInt (TokenLitInt n) = n
extractInt _ = error "extractInt: ugh"
mkProgram :: [Decl RlpcPs] -> P (Program RlpcPs)
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
mkProgram ds = do
pt <- use psOpTable
pure $ Program (associate pt <$> ds)
@@ -298,7 +298,6 @@ tempInfixExprErr (Located a _) (Located b _) =
_litint :: Getter (Located RlpToken) Int
_litint = to extract
. singular _TokenLitInt
. to IntL
mkPsName = undefined
tempInfixExprErr = undefined

2
src/Rlp/Parse/Associate.hs
View File

@@ -16,7 +16,7 @@ import Rlp.Parse.Types
import Rlp.Syntax
--------------------------------------------------------------------------------
associate :: OpTable -> Decl RlpcPs -> Decl RlpcPs
associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
associate _ p = p
{-# WARNING associate "unimplemented" #-}

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

@@ -1,6 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}
module Rlp.Parse.Types
(
-- * Trees That Grow
@@ -26,6 +27,7 @@ module Rlp.Parse.Types
where
--------------------------------------------------------------------------------
import Core.Syntax (Name)
import Text.Show.Deriving
import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Errorful

125
src/Rlp/Syntax.hs
View File

@@ -1,125 +1,10 @@
-- recursion-schemes
{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
module Rlp.Syntax
(
NameP
, Assoc(..)
, ConAlt(..)
, Alt(..)
, Ty(..)
, Binding(..)
, Expr(..), Expr', ExprF(..)
, Lit(..)
, Pat(..)
, Decl(..), Decl'
, Program(..)
, Where
-- * Re-exports
, Cofree(..)
, Trans.Cofree.CofreeF
, pattern (:<$)
, SrcSpan(..)
( module Rlp.Syntax.Backstage
, module Rlp.Syntax.Types
)
where
----------------------------------------------------------------------------------
import Data.Text (Text)
import Data.Text qualified as T
import Data.String (IsString(..))
import Data.Functor.Classes
import Data.Functor.Identity
import Data.Kind (Type)
import GHC.Generics
import Language.Haskell.TH.Syntax (Lift)
import Control.Lens
import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
import Control.Comonad.Cofree
import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Compiler.Types (SrcSpan(..), Located(..))
import Core.Syntax qualified as Core
import Core (Rec(..), HasRHS(..), HasLHS(..))
----------------------------------------------------------------------------------
type family NameP 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))
| TySigD [NameP p] (Ty p)
| DataD (NameP p) [NameP p] [ConAlt p]
| InfixD Assoc Int (NameP p)
deriving instance (Lift (NameP p)) => Lift (Decl p)
deriving instance (Show (NameP p)) => Show (Decl p)
data Expr p = LetE Rec [Binding p] (Expr p)
| VarE (NameP p)
| LamE [Pat p] (Expr p)
| CaseE (Expr p) [Alt p]
| IfE (Expr p) (Expr p) (Expr p)
| AppE (Expr p) (Expr p)
| LitE (Lit p)
| ParE (Expr p)
| InfixE (NameP p) (Expr p) (Expr p)
deriving (Generic)
deriving instance (Lift (NameP p)) => Lift (Expr p)
deriving instance (Show (NameP p)) => Show (Expr 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)
data Ty p = TyCon (NameP p)
deriving instance (Show (NameP p)) => Show (Ty p)
deriving instance (Lift (NameP p)) => Lift (Ty p)
data Pat p = VarP (NameP p)
| LitP (Lit p)
| ConP (NameP p) [Pat p]
deriving instance (Lift (NameP p)) => Lift (Pat p)
deriving instance (Show (NameP p)) => Show (Pat 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)
data Lit p = IntL Int
deriving Show
deriving instance (Lift (NameP p)) => Lift (Lit p)
data Alt p = AltA (Pat p) (Expr p) (Maybe (Where p))
deriving instance (Show (NameP p)) => Show (Alt p)
deriving instance (Lift (NameP p)) => Lift (Alt p)
type Where p = [Binding p]
data Assoc = InfixL | InfixR | Infix
deriving (Lift, Show)
pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
pattern a :<$ b = a Trans.Cofree.:< b
--------------------------------------------------------------------------------
import Rlp.Syntax.Backstage
import Rlp.Syntax.Types
--------------------------------------------------------------------------------
makeBaseFunctor ''Expr
makeLenses ''Program
type Expr' p = Cofree (ExprF p)
type Decl' p = Cofree (Const (Decl p))

24
src/Rlp/Syntax/Backstage.hs Normal file
View File

@@ -0,0 +1,24 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Rlp.Syntax.Backstage
(
)
where
--------------------------------------------------------------------------------
import Data.Functor.Classes
import Rlp.Syntax.Types
import Text.Show.Deriving
import Language.Haskell.TH.Syntax (Lift)
--------------------------------------------------------------------------------
-- oprhan instances because TH
instance (Show (NameP p)) => Show1 (ExprF p) where
liftShowsPrec = $(makeLiftShowsPrec ''ExprF)
deriving instance (Lift (NameP p), Lift a) => Lift (Expr' p a)
deriving instance (Lift (NameP p), Lift a) => Lift (Decl p a)
deriving instance (Show (NameP p), Show a) => Show (Decl p a)
deriving instance (Show (NameP p), Show a) => Show (Program p a)

126
src/Rlp/Syntax/Types.hs Normal file
View File

@@ -0,0 +1,126 @@
-- recursion-schemes
{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
module Rlp.Syntax.Types
(
NameP
, Assoc(..)
, ConAlt(..)
, Alt(..)
, Ty(..)
, Binding(..)
, Expr(..), Expr', ExprF(..)
, Lit(..)
, Pat(..)
, Decl(..)
, Program(..)
, Where
-- * Re-exports
, Cofree(..)
, Trans.Cofree.CofreeF
, pattern (:<$)
, SrcSpan(..)
)
where
----------------------------------------------------------------------------------
import Data.Text (Text)
import Data.Text qualified as T
import Data.String (IsString(..))
import Data.Functor.Classes
import Data.Functor.Identity
import Data.Functor.Compose
import Data.Fix
import Data.Kind (Type)
import GHC.Generics
import Language.Haskell.TH.Syntax (Lift)
import Control.Lens
import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
import Control.Comonad.Cofree
import Data.Functor.Foldable
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Compiler.Types (SrcSpan(..), Located(..))
import Core.Syntax qualified as Core
import Core (Rec(..), HasRHS(..), HasLHS(..))
----------------------------------------------------------------------------------
type family NameP p
data Expr p = LetE Rec [Binding p] (Expr p)
| VarE (NameP p)
| LamE [Pat p] (Expr p)
| CaseE (Expr p) [Alt p]
| IfE (Expr p) (Expr p) (Expr p)
| AppE (Expr p) (Expr p)
| LitE (Lit p)
| ParE (Expr p)
| InfixE (NameP p) (Expr p) (Expr p)
deriving (Generic)
deriving instance (Lift (NameP p)) => Lift (Expr p)
deriving instance (Show (NameP p)) => Show (Expr 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)
data Ty p = TyCon (NameP p)
deriving instance (Show (NameP p)) => Show (Ty p)
deriving instance (Lift (NameP p)) => Lift (Ty p)
data Pat p = VarP (NameP p)
| LitP (Lit p)
| ConP (NameP p) [Pat p]
deriving instance (Lift (NameP p)) => Lift (Pat p)
deriving instance (Show (NameP p)) => Show (Pat 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)
data Lit p = IntL Int
deriving Show
deriving instance (Lift (NameP p)) => Lift (Lit p)
data Alt p = AltA (Pat p) (Expr p) (Maybe (Where p))
deriving instance (Show (NameP p)) => Show (Alt p)
deriving instance (Lift (NameP p)) => Lift (Alt p)
type Where p = [Binding p]
data Assoc = InfixL | InfixR | Infix
deriving (Lift, Show)
pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
pattern a :<$ b = a Trans.Cofree.:< b
makeBaseFunctor ''Expr
deriving instance (Show (NameP p), Show a) => Show (ExprF p a)
deriving instance (Lift (NameP p), Lift a) => Lift (ExprF p a)
--------------------------------------------------------------------------------
data Program p a = Program
{ _programDecls :: [Decl p a]
}
data Decl p a = FunD (NameP p) [Pat p] (Expr' p a) (Maybe (Where p))
| TySigD [NameP p] (Ty p)
| DataD (NameP p) [NameP p] [ConAlt p]
| InfixD Assoc Int (NameP p)
type Expr' p = Cofree (ExprF p)
makeLenses ''Program