From 83dda869f8f2733b6743137202e9ba957715d6e9 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Sun, 28 Jan 2024 16:24:08 -0700 Subject: [PATCH] show --- rlp.cabal | 4 +-- src/Rlp/Parse.y | 11 +++++--- src/Rlp/Parse/Associate.hs | 2 +- src/Rlp/Parse/Types.hs | 39 ++++++++++++++++++++++++++-- src/Rlp/Syntax.hs | 52 ++++++++++++++++++++++++++++++++------ 5 files changed, 91 insertions(+), 17 deletions(-) diff --git a/rlp.cabal b/rlp.cabal index 6105295..dac6a5b 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -48,7 +48,7 @@ library build-tool-depends: happy:happy, alex:alex -- other-extensions: - build-depends: base ^>=4.18.0.0 + build-depends: base >=4.17 && <4.20 -- required for happy , array >= 0.5.5 && < 0.6 , containers >= 0.6.7 && < 0.7 @@ -85,7 +85,7 @@ executable rlpc main-is: Main.hs -- other-modules: -- other-extensions: - build-depends: base ^>=4.18.0.0 + build-depends: base >=4.17.0.0 && <4.20.0.0 , rlp , optparse-applicative >= 0.18.1 && < 0.19 , microlens >= 0.4.13 && < 0.5 diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 9792878..538b9ab 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -1,5 +1,5 @@ { -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, ViewPatterns #-} module Rlp.Parse ( parseRlpProg ) @@ -86,7 +86,7 @@ Decl :: { Decl' RlpcPs } | InfixDecl { $1 } InfixDecl :: { Decl' RlpcPs } - : InfixWord litint InfixOp {% mkInfixD $1 $2 $3 } + : InfixWord litint InfixOp {% mkInfixD $1 (intOfToken $2) $3 } InfixWord :: { Assoc } : infixl { InfixL } @@ -94,11 +94,11 @@ InfixWord :: { Assoc } | infix { Infix } DataDecl :: { Decl' RlpcPs } - : data Con TyParams '=' DataCons { DataD $2 $3 $5 } + : data Con TyParams '=' DataCons { $1 =>> \_ -> DataD' (extract $2) $3 $5 } TyParams :: { [PsName] } : {- epsilon -} { [] } - | TyParams varname { $1 `snoc` $2 } + | TyParams varname { $1 `snoc` extract (mkPsName $2) } DataCons :: { [ConAlt RlpcPs] } : DataCons '|' DataCon { $1 `snoc` $3 } @@ -193,4 +193,7 @@ mkInfixD a p n = do pos <- use (psInput . aiPos) pure $ Located (spanFromPos pos 0) (InfixD' a p n) +intOfToken :: Located RlpToken -> Int +intOfToken (Located _ (TokenLitInt n)) = n + } diff --git a/src/Rlp/Parse/Associate.hs b/src/Rlp/Parse/Associate.hs index 8dd89f2..99349d9 100644 --- a/src/Rlp/Parse/Associate.hs +++ b/src/Rlp/Parse/Associate.hs @@ -14,6 +14,6 @@ import Rlp.Parse.Types import Rlp.Syntax -------------------------------------------------------------------------------- -associate = undefined +associate x y = y {-# WARNING associate "temporarily undefined" #-} diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 5a3e6d4..c7cefb5 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -53,9 +53,22 @@ type instance XRec RlpcPs f = Located (f RlpcPs) type instance IdP RlpcPs = PsName type instance XInfixD RlpcPs = () -type instance XVarE RlpcPs = () -type instance XLitE RlpcPs = () type instance XFunD RlpcPs = () +type instance XDataD RlpcPs = () +type instance XTySigD RlpcPs = () +type instance XXDecl RlpcPs = () + +type instance XLetE 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 XXRlpExpr RlpcPs = () +type instance XLitE RlpcPs = () type PsName = Text @@ -198,6 +211,28 @@ spanAcross (la,ca,aa,sa) (lb,cb,ab,sb) = (l,c,a,s) LT -> max sa (ab + sb) GT -> max sb (aa + sa) +-- | A synonym for '(<<=)' with a different precedence for use with '(<~>)' in a +-- sort of, comonadic pseudo-applicative style. + +(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b +(<<~) = (<<=) + +infixl 4 <<~ + +-- | Similar to '(<*>)', but with a cokleisli arrow. + +(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b +mc <~> ma = mc >>- \f -> ma =>> f + +infixl 4 <~> + +-- f :: (w a -> w b -> c) +-- a :: w a +-- b :: w b + +-- result :: w c +-- result = f >~~ a <~> b + instance Comonad Located where extract (Located _ a) = a extend ck w@(Located p _) = Located p (ck w) diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 69d5d0d..3e8b9e5 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -3,6 +3,7 @@ , TemplateHaskell, TypeFamilies #-} {-# LANGUAGE OverloadedStrings, PatternSynonyms #-} {-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-} module Rlp.Syntax ( -- * AST @@ -17,14 +18,15 @@ module Rlp.Syntax -- * Pattern synonyms for unused extensions -- ** Decl - , pattern InfixD', pattern FunD' + , pattern InfixD', pattern FunD', pattern DataD' -- ** RlpExpr , pattern ParE', pattern VarE', pattern LitE' -- * Trees That Grow extensions , UnXRec(..), MapXRec(..), XRec, IdP -- ** RlpExpr - , XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XXRlpExpr + , XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XParE, XOAppE + , XXRlpExpr -- ** Decl , XFunD, XTySigD, XDataD, XInfixD, XXDecl ) @@ -37,7 +39,7 @@ import Data.Functor.Foldable.TH (makeBaseFunctor) import Data.Functor.Classes import Lens.Micro import Lens.Micro.TH -import Core.Syntax hiding (Lit) +import Core.Syntax hiding (Lit, Binding) import Core (HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- @@ -46,7 +48,15 @@ data RlpModule p = RlpModule , _rlpmodProgram :: RlpProgram p } -newtype RlpProgram p = RlpProgram [Decl p] +-- | dear god. +type PhaseShow p = + ( Show (XRec p Pat), Show (XRec p RlpExpr) + , Show (XRec p Lit), Show (IdP p) + ) + +newtype RlpProgram p = RlpProgram [Decl' p] + +deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p) data Decl p = FunD (XFunD p) (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p)) | TySigD (XTySigD p) [IdP p] Type @@ -54,6 +64,12 @@ data Decl p = FunD (XFunD p) (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p)) | InfixD (XInfixD p) Assoc Int (IdP p) | XDecl !(XXDecl p) +deriving instance ( Show (XFunD p), Show (XTySigD p) + , Show (XDataD p), Show (XInfixD p) + , Show (XXDecl p), Show (IdP p) + , PhaseShow p + ) => Show (Decl p) + type family XFunD p type family XTySigD p type family XDataD p @@ -68,6 +84,9 @@ pattern FunD' n as e wh = FunD () n as e wh pattern InfixD' :: (XInfixD p ~ ()) => Assoc -> Int -> (IdP p) -> Decl p pattern InfixD' a p n = InfixD () a p n +pattern DataD' :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p +pattern DataD' n as ds = DataD () n as ds + type Decl' p = XRec p Decl data Assoc = InfixL @@ -77,7 +96,9 @@ data Assoc = InfixL data ConAlt p = ConAlt (IdP p) [Type] -data RlpExpr p = LetE (XLetE p) [Bind p] (RlpExpr' p) +deriving instance (Show (IdP p)) => Show (ConAlt p) + +data RlpExpr p = LetE (XLetE 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)] @@ -88,6 +109,12 @@ data RlpExpr p = LetE (XLetE p) [Bind p] (RlpExpr' p) | OAppE (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p) | XRlpExpr !(XXRlpExpr p) +deriving instance + ( Show (XLetE 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 (XXRlpExpr p), PhaseShow p) + => Show (RlpExpr p) + type RlpExpr' p = XRec p RlpExpr class UnXRec p where @@ -121,24 +148,33 @@ pattern LitE' e = LitE () e pattern VarE' :: (XVarE p ~ ()) => IdP p -> RlpExpr p pattern VarE' e = VarE () e -type Where p = [Bind p] +type Where p = [Binding p] -- do we want guards? data Alt p = AltA (Pat' p) (RlpExpr' p) -data Bind p = PatB (Pat' p) (RlpExpr' p) - | FunB (IdP p) [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) + +deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p) + ) => Show (Binding p) data Pat p = VarP (IdP p) | LitP (Lit' p) | ConP (IdP p) [Pat' p] +deriving instance (PhaseShow p) => Show (Pat p) + type Pat' p = XRec p Pat data Lit p = IntL Int | CharL Char | ListL [RlpExpr' p] +deriving instance (PhaseShow p) => Show (Lit p) + type Lit' p = XRec p Lit -- instance HasLHS Alt Alt Pat Pat where