backstage

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

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 }
+Decl        :: { Decl RlpcPs SrcSpan }
-            : FunDecl                   { undefined }
+            : FunDecl                   { $1 }
-            | TySigDecl                 { undefined }
+            | TySigDecl                 { $1 }
-            | DataDecl                  { undefined }
+            | DataDecl                  { $1 }
-            | InfixDecl                 { undefined }
+            | InfixDecl                 { $1 }
 
-TySigDecl   :: { Decl RlpcPs }
+TySigDecl   :: { Decl RlpcPs SrcSpan }
-            : Var '::' Type             { undefined }
+            : Var '::' Type             { TySigD [$1] $3 }
 
-InfixDecl   :: { Decl RlpcPs }
+InfixDecl   :: { Decl RlpcPs SrcSpan }
-            : InfixWord litint InfixOp  { mkInfixD $1 ($2 ^. _litint) $3 }
+            : InfixWord litint InfixOp  {% mkInfixD $1 ($2 ^. _litint) $3 }
 
-InfixWord   :: { Located Assoc }
+InfixWord   :: { Assoc }
-            : infixl                    { $1 \$> InfixL }
+            : infixl                    { InfixL }
-            | infixr                    { $1 \$> InfixR }
+            | infixr                    { InfixR }
-            | infix                     { $1 \$> Infix }
+            | 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

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" #-}

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

src/Rlp/Syntax.hs

@@ -1,125 +1,10 @@
--- recursion-schemes
-{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
-{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
 module Rlp.Syntax
-    (
+    ( module Rlp.Syntax.Backstage
-      NameP
+    , module Rlp.Syntax.Types
-    , Assoc(..)
-    , ConAlt(..)
-    , Alt(..)
-    , Ty(..)
-    , Binding(..)
-    , Expr(..), Expr', ExprF(..)
-    , Lit(..)
-    , Pat(..)
-    , Decl(..), Decl'
-    , Program(..)
-    , Where
-
-    -- * Re-exports
-    , Cofree(..)
-    , Trans.Cofree.CofreeF
-    , pattern (:<$)
-    , SrcSpan(..)
     )
     where
-----------------------------------------------------------------------------------
+--------------------------------------------------------------------------------
-import Data.Text                    (Text)
+import Rlp.Syntax.Backstage
-import Data.Text                    qualified as T
+import Rlp.Syntax.Types
-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
-
 --------------------------------------------------------------------------------
 
-makeBaseFunctor ''Expr
-makeLenses ''Program
-
-type Expr' p = Cofree (ExprF p)
-type Decl' p = Cofree (Const (Decl p))
-

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)
+

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
+
+