From c9d1ca51f5d2375da11cbf2c7976b2db06d1b637 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 1 Feb 2024 18:15:40 -0700 Subject: [PATCH] XRec fix --- README.md | 12 +++++------ app/Main.hs | 2 ++ rlp.cabal | 1 + src/Rlp/Parse/Types.hs | 2 +- src/Rlp/Syntax.hs | 48 ++++++++++++++++++++++++------------------ src/Rlp2Core.hs | 40 +++++++++++++++++++++++++++++++++++ 6 files changed, 77 insertions(+), 28 deletions(-) create mode 100644 src/Rlp2Core.hs diff --git a/README.md b/README.md index ef70c2d..2fa2b72 100644 --- a/README.md +++ b/README.md @@ -57,9 +57,8 @@ Listed in order of importance. - [x] Garbage Collection - [ ] Emitter - [ ] Code-gen (target yet to be decided) - - [ ] Core language emitter - - [ ] Core linter (Type-checker) - - [ ] Core2Core pass + - [x] Core linter (Type-checker) + - [ ] Core2Core pass (optimisations and misc. preprocessing) - [x] GM prep - [x] Non-strict case-floating - [ ] Let-floating @@ -101,9 +100,10 @@ Listed in order of importance. ### January Release Plan - [ ] Beta rl' to Core - [ ] UX improvements - - [ ] Actual compiler errors -- no more unexceptional `error` calls - - [ ] Better CLI dump flags - - [ ] Annotate the AST with token positions for errors + - [x] Actual compiler errors -- no more unexceptional `error` calls + - [x] Better CLI dump flags + - [ ] Annotate the AST with token positions for errors (NOTE: As of Feb. 1, + this has been done, but the locational info is not yet used in error messages) - [ ] More examples ### March Release Plan diff --git a/app/Main.hs b/app/Main.hs index ea31543..524b590 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -68,6 +68,8 @@ options = RLPCOptions <*> option languageReader ( long "language" <> short 'x' + <> metavar "rlp|core" + <> help "the language to be compiled -- see README" ) <*> some (argument str $ metavar "FILES...") where diff --git a/rlp.cabal b/rlp.cabal index daad383..5e1b05d 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -43,6 +43,7 @@ library , Core.Parse , Core.Lex , Core2Core + , Rlp2Core , Control.Monad.Utils build-tool-depends: happy:happy, alex:alex diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 77c6519..ce53274 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -52,7 +52,7 @@ import Compiler.Types data RlpcPs -type instance XRec RlpcPs f = Located (f RlpcPs) +type instance XRec RlpcPs a = Located a type instance IdP RlpcPs = PsName type instance XFunD RlpcPs = () diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 9403e50..16ffe2e 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -8,6 +8,7 @@ module Rlp.Syntax ( -- * AST RlpProgram(..) + , progDecls , Decl(..), Decl', RlpExpr(..), RlpExpr' , Pat(..), Pat' , Assoc(..) @@ -53,15 +54,20 @@ data RlpModule p = RlpModule -- | dear god. type PhaseShow p = - ( Show (XRec p Pat), Show (XRec p RlpExpr) - , Show (XRec p Lit), Show (IdP p) - , Show (XRec p RlpType) - , Show (XRec p Binding) + ( 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)) ) newtype RlpProgram p = RlpProgram [Decl' p] -deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p) +progDecls :: Lens' (RlpProgram p) [Decl' p] +progDecls = lens + (\ (RlpProgram ds) -> ds) + (const RlpProgram) + +deriving instance (PhaseShow p, Show (XRec p (Decl p))) => Show (RlpProgram p) data RlpType p = FunConT | FunT (RlpType' p) (RlpType' p) @@ -69,7 +75,7 @@ data RlpType p = FunConT | VarT (IdP p) | ConT (IdP p) -type RlpType' p = XRec p RlpType +type RlpType' p = XRec p (RlpType p) deriving instance (PhaseShow p) => Show (RlpType p) @@ -95,11 +101,11 @@ type family XInfixD p type family XXDeclD p pattern FunD :: (XFunD p ~ ()) - => (IdP p) -> [Pat' p] -> (RlpExpr' p) -> (Maybe (Where 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 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 pattern FunD n as e wh = FunD' () n as e wh @@ -108,7 +114,7 @@ pattern DataD n as cs = DataD' () n as cs pattern InfixD a p n = InfixD' () a p n pattern XDeclD = XDeclD' () -type Decl' p = XRec p Decl +type Decl' p = XRec p (Decl p) data Assoc = InfixL | InfixR @@ -117,7 +123,7 @@ data Assoc = InfixL data ConAlt p = ConAlt (IdP p) [RlpType' p] -deriving instance (Show (IdP p), Show (XRec p RlpType)) => Show (ConAlt p) +deriving instance (Show (IdP p), Show (XRec p (RlpType p))) => Show (ConAlt p) data RlpExpr p = LetE' (XLetE p) [Binding' p] (RlpExpr' p) | VarE' (XVarE p) (IdP p) @@ -171,15 +177,15 @@ deriving instance , PhaseShow p ) => Show (RlpExpr p) -type RlpExpr' p = XRec p RlpExpr +type RlpExpr' p = XRec p (RlpExpr p) class UnXRec p where - unXRec :: XRec p f -> f p + unXRec :: XRec p a -> a class MapXRec p where - mapXRec :: (f p -> f' p') -> XRec p f -> XRec p' f' + mapXRec :: (a -> b) -> XRec p a -> XRec p b -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 @@ -193,9 +199,9 @@ 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 +type Binding' p = XRec p (Binding p) -deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p) +deriving instance (Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)), Show (IdP p) ) => Show (Binding p) data Pat p = VarP (IdP p) @@ -204,7 +210,7 @@ data Pat p = VarP (IdP p) deriving instance (PhaseShow p) => Show (Pat p) -type Pat' p = XRec p Pat +type Pat' p = XRec p (Pat p) data Lit p = IntL Int | CharL Char @@ -212,7 +218,7 @@ data Lit p = IntL Int deriving instance (PhaseShow p) => Show (Lit p) -type Lit' p = XRec p Lit +type Lit' p = XRec p (Lit p) -- instance HasLHS Alt Alt Pat Pat where -- _lhs = lens @@ -224,7 +230,7 @@ type Lit' p = XRec p Lit -- (\ (AltA _ e) -> e) -- (\ (AltA p _) e' -> AltA p e') -makeBaseFunctor ''RlpExpr +-- makeBaseFunctor ''RlpExpr -- showsTernaryWith :: (Int -> x -> ShowS) -- -> (Int -> y -> ShowS) diff --git a/src/Rlp2Core.hs b/src/Rlp2Core.hs new file mode 100644 index 0000000..c17ff64 --- /dev/null +++ b/src/Rlp2Core.hs @@ -0,0 +1,40 @@ +module Rlp2Core + ( rlpProgToCore + ) + where +-------------------------------------------------------------------------------- +import Control.Monad +import Control.Monad.Writer.CPS +import Lens.Micro +import Lens.Micro.Internal +import Data.Text (Text) +import Data.Text qualified as T +import Data.HashMap.Strict qualified as H + +import Core.Syntax as Core +import Rlp.Syntax as Rlp +import Rlp.Parse.Types (RlpcPs) +-------------------------------------------------------------------------------- + +rlpProgToCore :: RlpProgram RlpcPs -> Program' +rlpProgToCore = foldMapOf (progDecls . each) declToCore + +declToCore :: Decl' RlpcPs -> Program' + +declToCore = undefined + +-- declToCore (TySigD ns t) = +-- mempty & programTypeSigs .~ H.fromList [ (n, typeToCore t) | n <- ns ] + +typeToCore :: RlpType RlpcPs -> Type +typeToCore = undefined +-- typeToCore FunConT = TyFun +-- typeToCore (FunT s t) = typeToCore s :-> typeToCore t +-- typeToCore (AppT s t) = TyApp (typeToCore s) (typeToCore t) +-- typeToCore (ConT n) = TyCon (dsNameToName n) +-- typeToCore (VarT x) = TyVar (dsNameToName x) + +-- | Forwards-compatiblity if IdP RlpDs is changed +dsNameToName :: IdP RlpcPs -> Name +dsNameToName = id +