diff --git a/rlp.cabal b/rlp.cabal index e4d9342..bcb9162 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -32,6 +32,8 @@ library , Core.HindleyMilner , Control.Monad.Errorful , Rlp.Syntax + , Rlp.Syntax.Backstage + , Rlp.Syntax.Types -- , Rlp.Parse.Decls , Rlp.Parse , Rlp.Parse.Associate diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index a4e6b91..6546667 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -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 diff --git a/src/Rlp/Parse/Associate.hs b/src/Rlp/Parse/Associate.hs index d4d13e4..efdb091 100644 --- a/src/Rlp/Parse/Associate.hs +++ b/src/Rlp/Parse/Associate.hs @@ -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" #-} diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 10a5fd9..76a5440 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -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 diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 0e0870e..bbf0160 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -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)) - diff --git a/src/Rlp/Syntax/Backstage.hs b/src/Rlp/Syntax/Backstage.hs new file mode 100644 index 0000000..ee7fc51 --- /dev/null +++ b/src/Rlp/Syntax/Backstage.hs @@ -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) + diff --git a/src/Rlp/Syntax/Types.hs b/src/Rlp/Syntax/Types.hs new file mode 100644 index 0000000..ae908c4 --- /dev/null +++ b/src/Rlp/Syntax/Types.hs @@ -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 + +