no-ttg

2024-02-15 18:27:04 -07:00
parent 2e13ec2cf4
commit e9cab1ddaf
6 changed files with 80 additions and 353 deletions
--- a/src/Rlp/Parse.y
+++ b/src/Rlp/Parse.y
@@ -248,6 +248,11 @@ Con         :: { Located PsName }

 {

+parseRlpProgR = undefined
+parseRlpExprR = undefined
+    
+{--
+
 parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs)
 parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
    where
@@ -281,10 +286,6 @@ mkProgram ds = do
    pt <- use psOpTable
    pure $ RlpProgram (associate pt <$> ds)

-parseError :: (Located RlpToken, [String]) -> P a
-parseError ((Located ss t), exp) = addFatal $
-    errorMsg ss (RlpParErrUnexpectedToken t exp)
-
 mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
 mkInfixD a p n = do
    let opl :: Lens' ParseState (Maybe OpInfo)
@@ -308,5 +309,17 @@ tempInfixExprErr (Located a _) (Located b _) =
        , "In the mean time, don't mix any infix operators."
        ]

+--}
+
+mkPsName = undefined
+tempInfixExprErr = undefined
+extractName = undefined
+extractInt = undefined
+mkProgram = undefined
+
+parseError :: (Located RlpToken, [String]) -> P a
+parseError ((Located ss t), exp) = addFatal $
+    errorMsg ss (RlpParErrUnexpectedToken t exp)
+
 }

--- 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 -> Decl RlpcPs
 associate _ p = p

 {-# WARNING associate "unimplemented" #-}
--- a/src/Rlp/Parse/Types.hs
+++ b/src/Rlp/Parse/Types.hs
@@ -53,35 +53,10 @@ import Compiler.Types

 data RlpcPs

-type instance XRec RlpcPs a = Located a
-type instance IdP RlpcPs = PsName
-
-type instance XFunD RlpcPs = ()
-type instance XDataD RlpcPs = ()
-type instance XInfixD RlpcPs = ()
-type instance XTySigD RlpcPs = ()
-type instance XXDeclD RlpcPs = ()
-
-type instance XLetE RlpcPs = ()
-type instance XLetrecE RlpcPs = ()
-type instance XVarE RlpcPs = ()
-type instance XLamE RlpcPs = ()
-type instance XCaseE RlpcPs = ()
-type instance XIfE RlpcPs = ()
-type instance XAppE RlpcPs = ()
-type instance XLitE RlpcPs = ()
-type instance XParE RlpcPs = ()
-type instance XOAppE RlpcPs = ()
-type instance XXRlpExprE RlpcPs = ()
+type instance NameP RlpcPs = PsName

 type PsName = Text

-instance MapXRec RlpcPs where
-    mapXRec = fmap
-
-instance UnXRec RlpcPs where
-    unXRec = extract
-
 --------------------------------------------------------------------------------

 spanFromPos :: Position -> Int -> SrcSpan
@@ -281,13 +256,13 @@ initAlexInput s = AlexInput

 --------------------------------------------------------------------------------

-deriving instance Lift (RlpProgram RlpcPs)
+deriving instance Lift (Program RlpcPs)
 deriving instance Lift (Decl RlpcPs)
 deriving instance Lift (Pat RlpcPs)
 deriving instance Lift (Lit RlpcPs)
-deriving instance Lift (RlpExpr RlpcPs)
+deriving instance Lift (Expr RlpcPs)
 deriving instance Lift (Binding RlpcPs)
-deriving instance Lift (RlpType RlpcPs)
+deriving instance Lift (Ty RlpcPs)
 deriving instance Lift (Alt RlpcPs)
 deriving instance Lift (ConAlt RlpcPs)

--- a/src/Rlp/Syntax.hs
+++ b/src/Rlp/Syntax.hs
@@ -6,44 +6,17 @@
 {-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
 module Rlp.Syntax
    (
-    -- * AST
-      RlpProgram(..)
-    , progDecls
-    , Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..)
-    , Pat(..), Pat'
-    , Alt(..), Where
+      NameP
    , Assoc(..)
-    , Lit(..), Lit'
-    , RlpType(..), RlpType'
    , ConAlt(..)
-    , Binding(..), Binding'
-
-    , _PatB, _FunB
-    , _VarP, _LitP, _ConP
-
-    -- * Trees That Grow boilerplate
-    -- ** Extension points
-    , IdP, IdP', XRec, UnXRec(..), MapXRec(..)
-    -- *** Decl
-    , XFunD, XTySigD, XInfixD, XDataD, XXDeclD
-    -- *** RlpExpr
-    , XLetE, XLetrecE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
-    , XParE, XOAppE, XXRlpExprE
-    -- ** Pattern synonyms
-    -- *** Decl
-    , pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
-    , pattern FunD'', pattern TySigD'', pattern InfixD'', pattern DataD''
-    -- *** RlpExpr
-    , pattern LetE, pattern LetrecE, pattern VarE, pattern LamE, pattern CaseE
-    , pattern IfE , pattern AppE, pattern LitE, pattern ParE, pattern OAppE
-    , pattern XRlpExprE
-    -- *** RlpType
-    , pattern FunConT'', pattern FunT'', pattern AppT'', pattern VarT''
-    , pattern ConT''
-    -- *** Pat
-    , pattern VarP'', pattern LitP'', pattern ConP''
-    -- *** Binding
-    , pattern PatB''
+    , Alt(..)
+    , Ty(..)
+    , Binding(..)
+    , Expr(..)
+    , Lit(..)
+    , Pat(..)
+    , Decl(..)
+    , Program(..)
    )
    where
 ----------------------------------------------------------------------------------
@@ -58,305 +31,61 @@ import Data.Kind                    (Type)
 import GHC.Generics
 import Language.Haskell.TH.Syntax   (Lift)
 import Control.Lens
-import Core.Syntax                  hiding (Lit, Type, Binding, Binding')
-import Core                         (HasRHS(..), HasLHS(..))
+import Core.Syntax                  qualified as Core
+import Core                         (Rec(..), HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------

-data RlpModule p = RlpModule
-    { _rlpmodName       :: Text
-    , _rlpmodProgram    :: RlpProgram p
-    }
+type PsName = Text
+type family NameP p

-- | dear god.
-type PhaseShow p =
-    ( Show (XRec p (Pat p)), Show (XRec p (RlpExpr p))
-    , Show (XRec p (Lit p)), Show (IdP p)
-    , Show (XRec p (RlpType p))
-    , Show (XRec p (Binding p))
-    )
+data Program p

-newtype RlpProgram p = RlpProgram [Decl' 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)

-progDecls :: Lens' (RlpProgram p) [Decl' p]
-progDecls = lens
-    (\ (RlpProgram ds) -> ds)
-    (const RlpProgram)
+deriving instance (Show (NameP p)) => Show (Decl p)

-deriving instance (PhaseShow p, Show (XRec p (Decl p))) => Show (RlpProgram 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)

-data RlpType p = FunConT
-               | FunT (RlpType' p) (RlpType' p)
-               | AppT (RlpType' p) (RlpType' p)
-               | VarT (IdP p)
-               | ConT (IdP p)
+deriving instance (Show (NameP p)) => Show (Expr p)

-type RlpType' p = XRec p (RlpType p)
+data ConAlt p = ConAlt (NameP p) [Ty p]

-pattern FunConT'' :: (UnXRec p) => RlpType' p
-pattern FunT''    :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
-pattern AppT''    :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
-pattern VarT''    :: (UnXRec p) => IdP p -> RlpType' p
-pattern ConT''    :: (UnXRec p) => IdP p -> RlpType' p
+deriving instance (Show (NameP p)) => Show (ConAlt p)

-pattern FunConT''     <- (unXRec -> FunConT)
-pattern FunT''    s t <- (unXRec -> FunT s t)
-pattern AppT''    s t <- (unXRec -> AppT s t)
-pattern VarT''    n   <- (unXRec -> VarT n)
-pattern ConT''    n   <- (unXRec -> ConT n)
+data Ty p
+    deriving Show

-deriving instance (PhaseShow p)
-                  => Show (RlpType p)
+data Pat p = VarP (NameP p)
+           | LitP (Lit p)
+           | ConP (NameP p) [Pat p]

-data Decl p = FunD'   (XFunD p)    (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
-            | TySigD' (XTySigD p)  [IdP p] (RlpType' p)
-            | DataD'  (XDataD p)   (IdP p) [IdP p] [ConAlt p]
-            | InfixD' (XInfixD p)  Assoc Int (IdP p)
-            | XDeclD' !(XXDeclD p)
+deriving instance (Show (NameP p)) => Show (Pat p)

-deriving instance
-    ( Show (XFunD p), Show (XTySigD p)
-    , Show (XDataD p), Show (XInfixD p)
-    , Show (XXDeclD p)
-    , PhaseShow p
-    ) 
-    => Show (Decl p)
+data Binding p = PatB (Pat p) (Expr p)

-type family XFunD p
-type family XTySigD p
-type family XDataD p
-type family XInfixD p
-type family XXDeclD p
+deriving instance (Show (NameP p)) => Show (Binding p)

-pattern FunD   :: (XFunD p ~ ())
-               => IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
-               -> Decl p
-pattern TySigD :: (XTySigD p ~ ()) => [IdP p] -> RlpType' p -> Decl p
-pattern DataD  :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p
-pattern InfixD :: (XInfixD p ~ ()) => Assoc -> Int -> IdP p -> Decl p
-pattern XDeclD :: (XXDeclD p ~ ()) => Decl p
+data Lit p = IntL Int
+    deriving Show

-pattern FunD n as e wh = FunD' () n as e wh
-pattern TySigD ns t    = TySigD' () ns t
-pattern DataD n as cs  = DataD' () n as cs
-pattern InfixD a p n   = InfixD' () a p n
-pattern XDeclD         = XDeclD' ()
+data Alt p = AltA (Pat p) (Expr p) (Maybe (Where p))

-pattern FunD''   :: (UnXRec p)
-                 => IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
-                 -> Decl' p
-pattern TySigD'' :: (UnXRec p)
-                 => [IdP p] -> RlpType' p -> Decl' p
-pattern DataD''  :: (UnXRec p)
-                 => IdP p -> [IdP p] -> [ConAlt p] -> Decl' p
-pattern InfixD'' :: (UnXRec p)
-                 => Assoc -> Int -> IdP p -> Decl' p
-
-pattern FunD''   n as e wh <- (unXRec -> FunD' _ n as e wh)
-pattern TySigD'' ns t      <- (unXRec -> TySigD' _ ns t)
-pattern DataD''  n as ds   <- (unXRec -> DataD' _ n as ds)
-pattern InfixD'' a p n     <- (unXRec -> InfixD' _ a p n)
-
-type Decl' p = XRec p (Decl p)
-
-data Assoc = InfixL
-           | InfixR
-           | Infix
-           deriving (Show, Lift)
-
-data ConAlt p = ConAlt (IdP p) [RlpType' p]
-
-deriving instance (Show (IdP p), Show (XRec p (RlpType p))) => Show (ConAlt p)
-
-data RlpExpr p = LetE'      (XLetE p) [Binding' p] (RlpExpr' p)
-               | LetrecE'   (XLetrecE p) [Binding' p] (RlpExpr' p)
-               | VarE'      (XVarE p) (IdP p)
-               | LamE'      (XLamE p) [Pat p] (RlpExpr' p)
-               | CaseE'     (XCaseE p) (RlpExpr' p) [(Alt p, Where p)]
-               | IfE'       (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
-               | AppE'      (XAppE p) (RlpExpr' p) (RlpExpr' p)
-               | LitE'      (XLitE p) (Lit p)
-               | ParE'      (XParE p) (RlpExpr' p)
-               | OAppE'     (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
-               | XRlpExprE' !(XXRlpExprE p)
-               deriving (Generic)
-
-type family XLetE p
-type family XLetrecE p
-type family XVarE p
-type family XLamE p
-type family XCaseE p
-type family XIfE p
-type family XAppE p
-type family XLitE p
-type family XParE p
-type family XOAppE p
-type family XXRlpExprE p
-
-pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
-pattern LetrecE :: (XLetrecE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
-pattern VarE :: (XVarE p ~ ()) => IdP p -> RlpExpr p
-pattern LamE :: (XLamE p ~ ()) => [Pat p] -> RlpExpr' p -> RlpExpr p
-pattern CaseE :: (XCaseE p ~ ()) => RlpExpr' p -> [(Alt p, Where p)] -> RlpExpr p
-pattern IfE :: (XIfE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
-pattern AppE :: (XAppE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr p
-pattern LitE :: (XLitE p ~ ()) => Lit p -> RlpExpr p
-pattern ParE :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p
-pattern OAppE :: (XOAppE p ~ ()) => IdP p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
-pattern XRlpExprE :: (XXRlpExprE p ~ ()) => RlpExpr p
-
-pattern LetE bs e = LetE' () bs e
-pattern LetrecE bs e = LetrecE' () bs e
-pattern VarE n = VarE' () n
-pattern LamE as e = LamE' () as e
-pattern CaseE e as = CaseE' () e as
-pattern IfE c a b = IfE' () c a b
-pattern AppE f x = AppE' () f x
-pattern LitE l = LitE' () l
-pattern ParE e = ParE' () e
-pattern OAppE n a b = OAppE' () n a b
-pattern XRlpExprE = XRlpExprE' ()
-
-deriving instance
-    ( Show (XLetE p), Show (XLetrecE p), Show (XVarE p)
-    , Show (XLamE p), Show (XCaseE p), Show (XIfE p)
-    , Show (XAppE p), Show (XLitE p), Show (XParE p)
-    , Show (XOAppE p), Show (XXRlpExprE p)
-    , PhaseShow p
-    ) => Show (RlpExpr p)
-
-type RlpExpr' p = XRec p (RlpExpr p)
-
-class UnXRec p where
-    unXRec :: XRec p a -> a
-
-class WrapXRec p where
-    wrapXRec :: a -> XRec p a
-
-class MapXRec p where
-    mapXRec :: (a -> b) -> XRec p a -> XRec p b
-
-- old definition:
-- type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f
-type family XRec p a = (r :: Type) | r -> p a
-
-type family IdP p
-
-type IdP' p = XRec p (IdP p)
+deriving instance (Show (NameP p)) => Show (Alt p)

 type Where p = [Binding p]

-- do we want guards?
-data Alt p = AltA (Pat' p) (RlpExpr' p)
-
-deriving instance (PhaseShow p) => Show (Alt p)
-
-data Binding p = PatB (Pat' p) (RlpExpr' p)
-               | FunB (IdP p) [Pat' p] (RlpExpr' p)
-
-type Binding' p = XRec p (Binding p)
-
-pattern PatB'' :: (UnXRec p) => Pat' p -> RlpExpr' p -> Binding' p
-pattern PatB'' p e <- (unXRec -> PatB p e)
-
-deriving instance (Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)), Show (IdP p)
-                  ) => Show (Binding p)
-
-data Pat p = VarP (IdP p)
-           | LitP (Lit' p)
-           | ConP (IdP p) [Pat' p]
-
-pattern VarP'' :: (UnXRec p) => IdP p -> Pat' p
-pattern LitP'' :: (UnXRec p) => Lit' p -> Pat' p
-pattern ConP'' :: (UnXRec p) => IdP p -> [Pat' p] -> Pat' p
-
-pattern VarP'' n    <- (unXRec -> VarP n)
-pattern LitP'' l    <- (unXRec -> LitP l)
-pattern ConP'' c as <- (unXRec -> ConP c as)
-
-deriving instance (PhaseShow p) => Show (Pat p)
-
-type Pat' p = XRec p (Pat p)
-
-data Lit p = IntL Int
-           | CharL Char
-           | ListL [RlpExpr' p]
-
-deriving instance (PhaseShow p) => Show (Lit p)
-
-type Lit' p = XRec p (Lit p)
-
-- instance HasLHS Alt Alt Pat Pat where
--     _lhs = lens
--         (\ (AltA p _) -> p)
--         (\ (AltA _ e) p' -> AltA p' e)
-
-- instance HasRHS Alt Alt RlpExpr RlpExpr where
--     _rhs = lens
--         (\ (AltA _ e) -> e)
--         (\ (AltA p _) e' -> AltA p e')
-
-- makeBaseFunctor ''RlpExpr
-
-- showsTernaryWith :: (Int -> x -> ShowS)
--                  -> (Int -> y -> ShowS)
--                  -> (Int -> z -> ShowS)
--                  -> String -> Int
--                  -> x -> y -> z
--                  -> ShowS
-- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
--     $ showString name
--     . showChar ' ' . sa 11 a 
--     . showChar ' ' . sb 11 b
--     . showChar ' ' . sc 11 c
-
--------------------------------------------------------------------------------
-
-makeLenses ''RlpModule
-makePrisms ''Pat
-makePrisms ''Binding
-
--------------------------------------------------------------------------------
-
-data RlpExprF p a = LetE'F  (XLetE p) [Binding' p] a
-                  | LetrecE'F  (XLetrecE p) [Binding' p] a
-                  | VarE'F  (XVarE p) (IdP p)
-                  | LamE'F  (XLamE p) [Pat p] a
-                  | CaseE'F (XCaseE p) a [(Alt p, Where p)]
-                  | IfE'F   (XIfE p) a a a
-                  | AppE'F  (XAppE p) a a
-                  | LitE'F  (XLitE p) (Lit p)
-                  | ParE'F  (XParE p) a
-                  | OAppE'F (XOAppE p) (IdP p) a a
-                  | XRlpExprE'F !(XXRlpExprE p)
-                  deriving (Functor, Foldable, Traversable, Generic)
-
-type instance Base (RlpExpr p) = RlpExprF p
-
-instance (UnXRec p) => Recursive (RlpExpr p) where
-    project = \case
-        LetE' xx bs e   -> LetE'F xx bs (unXRec e)
-        LetrecE' xx bs e   -> LetrecE'F xx bs (unXRec e)
-        VarE' xx n      -> VarE'F xx n
-        LamE' xx ps e   -> LamE'F xx ps (unXRec e)
-        CaseE' xx e as  -> CaseE'F xx (unXRec e) as
-        IfE' xx a b c   -> IfE'F xx (unXRec a) (unXRec b) (unXRec c)
-        AppE' xx f x    -> AppE'F xx (unXRec f) (unXRec x)
-        LitE' xx l      -> LitE'F xx l
-        ParE' xx e      -> ParE'F xx (unXRec e)
-        OAppE' xx f a b -> OAppE'F xx f (unXRec a) (unXRec b)
-        XRlpExprE' xx   -> XRlpExprE'F xx
-
-instance (WrapXRec p) => Corecursive (RlpExpr p) where
-    embed = \case
-        LetE'F xx bs e   -> LetE' xx bs (wrapXRec e)
-        LetrecE'F xx bs e   -> LetrecE' xx bs (wrapXRec e)
-        VarE'F xx n      -> VarE' xx n
-        LamE'F xx ps e   -> LamE' xx ps (wrapXRec e)
-        CaseE'F xx e as  -> CaseE' xx (wrapXRec e) as
-        IfE'F xx a b c   -> IfE' xx (wrapXRec a) (wrapXRec b) (wrapXRec c)
-        AppE'F xx f x    -> AppE' xx (wrapXRec f) (wrapXRec x)
-        LitE'F xx l      -> LitE' xx l
-        ParE'F xx e      -> ParE' xx (wrapXRec e)
-        OAppE'F xx f a b -> OAppE' xx f (wrapXRec a) (wrapXRec b)
-        XRlpExprE'F xx   -> XRlpExprE' xx
+data Assoc = InfixL | InfixR | Infix
+    deriving (Lift, Show)

--- a/src/Rlp/TH.hs
+++ b/src/Rlp/TH.hs
@@ -17,10 +17,12 @@ import Rlp.Parse
 --------------------------------------------------------------------------------

 rlpProg :: QuasiQuoter
-rlpProg = mkqq parseRlpProgR
+rlpProg = undefined
+-- rlpProg = mkqq parseRlpProgR

 rlpExpr :: QuasiQuoter
-rlpExpr = mkqq parseRlpExprR
+rlpExpr = undefined
+-- rlpExpr = mkqq parseRlpExprR

 mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
 mkq parse = evalAndParse >=> lift where