From 66c3d878c2b13cd2093361bd2cd76acce24cf71f Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 20 Feb 2024 11:10:33 -0700 Subject: [PATCH] i want to fucking die --- src/Compiler/Types.hs | 169 +++++++++++++++++++++++++++++------- src/Rlp/Lex.x | 13 +-- src/Rlp/Parse.y | 91 ++++++++++--------- src/Rlp/Parse/Types.hs | 32 +++++-- src/Rlp/Syntax/Backstage.hs | 10 ++- src/Rlp/Syntax/Types.hs | 23 +++-- 6 files changed, 248 insertions(+), 90 deletions(-) diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 4d66da1..58be658 100644 --- a/src/Compiler/Types.hs +++ b/src/Compiler/Types.hs @@ -1,19 +1,23 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-} +{-# LANGUAGE PatternSynonyms #-} module Compiler.Types ( SrcSpan(..) , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen + , pattern (:<$) , Located(..) - , GetLocation(srcspan) - , HasLocation(location) + , HasLocation(..) , _Located - , nolo + , nolo, nolo' - , (<~>), (~>) + , (<~>), (~>), (~~>), (<~~) + + , comb2, comb3, comb4 + , lochead -- * Re-exports - , Comonad + , Comonad(extract) , Apply , Bind ) @@ -23,35 +27,56 @@ import Language.Haskell.TH.Syntax (Lift) import Control.Comonad import Control.Comonad.Cofree +import Control.Comonad.Trans.Cofree qualified as Trans.Cofree +import Control.Comonad.Trans.Cofree (CofreeF) import Data.Functor.Apply import Data.Functor.Bind +import Data.Functor.Compose +import Data.Functor.Foldable import Data.Semigroup.Foldable +import Data.Fix hiding (cata, ana) import Data.Kind -import Control.Lens hiding ((<<~)) +import Control.Lens hiding ((<<~), (:<)) import Data.List.NonEmpty (NonEmpty) +import Data.Function (on) -------------------------------------------------------------------------------- -- | Token wrapped with a span (line, column, absolute, length) data Located a = Located SrcSpan a deriving (Show, Lift, Functor) -class GetLocation s where - srcspan :: s -> SrcSpan +data Floc f = Floc SrcSpan (f (Floc f)) -class HasLocation s where - location :: Lens' s SrcSpan +pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b +pattern a :<$ b = a Trans.Cofree.:< b (<~>) :: a -> b -> SrcSpan (<~>) = undefined infixl 5 <~> -(~>) :: a -> b -> b +-- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b) +-- => a -> b -> b +-- a ~> b = (~>) = undefined infixl 4 ~> +-- (~~>) :: (CanGet k, HasLocation k a, CanSet k', HasLocation k' b) +-- => (a -> b) -> a -> b +-- (~~>) :: (f SrcSpan -> b) -> Cofree f SrcSpan -> Cofree f SrcSpan +-- f ~~> (ss :< as) = ss :< f as +(~~>) = undefined + +infixl 3 ~~> + +-- (<~~) :: (GetLocation a, HasLocation b) => (a -> b) -> a -> b +-- a <~~ b = a b & location <>~ srcspan b +(<~~) = undefined + +infixr 2 <~~ + instance Apply Located where liftF2 f (Located sa p) (Located sb q) = Located (sa <> sb) (p `f` q) @@ -86,6 +111,9 @@ srcSpanLen = tupling . _4 nolo :: a -> Located a nolo = Located (SrcSpan 0 0 0 0) +nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan +nolo' as = SrcSpan 0 0 0 0 :< as + instance Semigroup SrcSpan where -- multiple identities? what are the consequences of this...? SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s @@ -100,24 +128,103 @@ instance Semigroup SrcSpan where LT -> max sa (ab + sb - aa) GT -> max sb (aa + sa - ab) +-------------------------------------------------------------------------------- + +data GetOrSet = Get | Set | GetSet + +class CanGet (k :: GetOrSet) +class CanSet (k :: GetOrSet) where + +instance CanGet Get +instance CanGet GetSet +instance CanSet Set +instance CanSet GetSet + +data GetSetLens (k :: GetOrSet) s t a b :: Type where + Getter_ :: (s -> a) -> GetSetLens Get s t a b + Setter_ :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b + GetterSetter :: (CanGet k', CanSet k') + => (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b + +type GetSetLens' k s a = GetSetLens k s s a a + +class HasLocation k s | s -> k where + -- location :: (Access k f, Functor f) => LensLike' f s SrcSpan + getSetLocation :: GetSetLens' k s SrcSpan + +type family Access (k :: GetOrSet) f where + Access GetSet f = Functor f + Access Set f = Settable f + Access Get f = (Functor f, Contravariant f) + +instance HasLocation GetSet SrcSpan where + getSetLocation = GetterSetter id (flip const) + -- location = fromGetSetLens getSetLocation + +instance (CanSet k, HasLocation k a) => HasLocation Set (r -> a) where + getSetLocation = Setter_ $ \ss ra r -> ra r & fromSet getSetLocation %~ ss + -- location = fromSet getSetLocation + +instance (HasLocation k a) => HasLocation k (Cofree f a) where + getSetLocation = case getSetLocation @_ @a of + Getter_ sa -> Getter_ $ \ (s :< _) -> sa s + Setter_ abst -> Setter_ $ \ss (s :< as) -> abst ss s :< as + GetterSetter sa sbt -> GetterSetter sa' sbt' where + sa' (s :< _) = sa s + sbt' (s :< as) b = sbt s b :< as + +location :: (Access k f, Functor f, HasLocation k s) + => LensLike' f s SrcSpan +location = fromGetSetLens getSetLocation + +fromGetSetLens :: (Access k f, Functor f) => GetSetLens' k s a -> LensLike' f s a +fromGetSetLens gsl = case gsl of + Getter_ sa -> to sa + Setter_ abst -> setting abst + GetterSetter sa sbt -> lens sa sbt + +fromGet :: (CanGet k) => GetSetLens k s t a b -> Getter s a +fromGet (Getter_ sa) = to sa +fromGet (GetterSetter sa _) = to sa + +fromSet :: (CanSet k) => GetSetLens k s t a b -> Setter s t a b +fromSet (Setter_ abst) = setting abst +fromSet (GetterSetter sa sbt) = lens sa sbt + +fromGetSet :: (CanGet k, CanSet k) => GetSetLens k s t a b -> Lens s t a b +fromGetSet (GetterSetter sa sbt) = lens sa sbt + +-------------------------------------------------------------------------------- + +comb2 :: (Functor f, Semigroup m) + => (Cofree f m -> Cofree f m -> f (Cofree f m)) + -> Cofree f m -> Cofree f m -> Cofree f m +comb2 f a b = ss :< f a b + where ss = a `mextract` b + +comb3 :: (Functor f, Semigroup m) + => (Cofree f m -> Cofree f m -> Cofree f m -> f (Cofree f m)) + -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m +comb3 f a b c = ss :< f a b c + where ss = a `mapply` b `mextract` c + +comb4 :: (Functor f, Semigroup m) + => (Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m + -> f (Cofree f m)) + -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m +comb4 f a b c d = ss :< f a b c d + where ss = a `mapply` b `mapply` c `mextract` d + +mextract :: (Comonad w, Semigroup m) => w m -> w m -> m +mextract = (<>) `on` extract + +mapply :: (Comonad w, Semigroup m) => w m -> w m -> w m +mapply a b = b <&> (<> extract a) + +lochead :: Functor f + => (f SrcSpan -> f SrcSpan) -> Located (f SrcSpan) -> Cofree f SrcSpan +lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss) + +-------------------------------------------------------------------------------- + makePrisms ''Located - --------------------------------------------------------------------------------- - -instance (GetLocation a) => GetLocation (NonEmpty a) where - srcspan = foldMap1 srcspan - -instance GetLocation SrcSpan where - srcspan = id - -instance (Functor f) => GetLocation (Cofree f SrcSpan) where - srcspan = extract - --------------------------------------------------------------------------------- - -instance HasLocation SrcSpan where - location = id - -instance (Functor f) => HasLocation (Cofree f SrcSpan) where - location = _extract - diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index ed12fcc..93cac61 100644 --- a/src/Rlp/Lex.x +++ b/src/Rlp/Lex.x @@ -8,6 +8,7 @@ module Rlp.Lex , Located(..) , lexToken , lexStream + , lexStream' , lexDebug , lexCont , popLexState @@ -29,6 +30,7 @@ import Data.Word import Data.Default import Control.Lens +import Compiler.Types import Debug.Trace import Rlp.Parse.Types } @@ -274,11 +276,12 @@ lexCont :: (Located RlpToken -> P a) -> P a lexCont = (lexToken >>=) lexStream :: P [RlpToken] -lexStream = do - t <- lexToken - case t of - Located _ TokenEOF -> pure [TokenEOF] - Located _ t -> (t:) <$> lexStream +lexStream = fmap extract <$> lexStream' + +lexStream' :: P [Located RlpToken] +lexStream' = lexToken >>= \case + t@(Located _ TokenEOF) -> pure [t] + t -> (t:) <$> lexStream' lexDebug :: (Located RlpToken -> P a) -> P a lexDebug k = do diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 6546667..b14763c 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -5,15 +5,17 @@ module Rlp.Parse , parseRlpProgR , parseRlpExpr , parseRlpExprR + , runP' ) where import Compiler.RlpcError import Compiler.RLPC +import Control.Comonad.Cofree import Rlp.Lex import Rlp.Syntax import Rlp.Parse.Types import Rlp.Parse.Associate -import Control.Lens hiding (snoc, (.>), (<.), (<<~)) +import Control.Lens hiding (snoc, (.>), (<.), (<<~), (:<)) import Data.List.Extra import Data.Fix import Data.Functor.Const @@ -74,8 +76,8 @@ import Compiler.Types StandaloneProgram :: { Program RlpcPs SrcSpan } StandaloneProgram : layout0(Decl) { Program $1 } -StandaloneExpr :: { Expr RlpcPs } - : VL Expr VR { undefined } +StandaloneExpr :: { Expr' RlpcPs SrcSpan } + : VL Expr VR { $2 } VL :: { () } VL : vlbrace { () } @@ -106,45 +108,45 @@ InfixWord :: { Assoc } | infix { Infix } DataDecl :: { Decl RlpcPs SrcSpan } - : data Con TyParams '=' DataCons { undefined } + : data Con TyParams '=' DataCons { DataD $2 $3 $5 } TyParams :: { [PsName] } - : {- epsilon -} { undefined } - | TyParams varname { undefined } + : {- epsilon -} { [] } + | TyParams varname { $1 `snoc` extractName $2 } DataCons :: { [ConAlt RlpcPs] } - : DataCons '|' DataCon { undefined } - | DataCon { undefined } + : DataCons '|' DataCon { $1 `snoc` $3 } + | DataCon { [$1] } DataCon :: { ConAlt RlpcPs } - : Con Type1s { undefined } + : Con Type1s { ConAlt $1 $2 } Type1s :: { [Ty RlpcPs] } - : {- epsilon -} { undefined } - | Type1s Type1 { undefined } + : {- epsilon -} { [] } + | Type1s Type1 { $1 `snoc` $2 } Type1 :: { Ty RlpcPs } - : '(' Type ')' { undefined } - | conname { undefined } - | varname { undefined } + : '(' Type ')' { $2 } + | conname { ConT (extractName $1) } + | varname { VarT (extractName $1) } Type :: { Ty RlpcPs } - : Type '->' Type { undefined } - | TypeApp { undefined } + : Type '->' Type { FunT $1 $3 } + | TypeApp { $1 } TypeApp :: { Ty RlpcPs } - : Type1 { undefined } - | TypeApp Type1 { undefined } + : Type1 { $1 } + | TypeApp Type1 { AppT $1 $2 } FunDecl :: { Decl RlpcPs SrcSpan } FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing } Params :: { [Pat RlpcPs] } -Params : {- epsilon -} { undefined } - | Params Pat1 { undefined } +Params : {- epsilon -} { [] } + | Params Pat1 { $1 `snoc` $2 } Pat :: { Pat RlpcPs } - : Con Pat1s { undefined } + : Con Pat1s { $1 } | Pat1 { undefined } Pat1s :: { [Pat RlpcPs] } @@ -160,18 +162,18 @@ Pat1 :: { Pat RlpcPs } Expr :: { Expr' RlpcPs SrcSpan } -- infixities delayed till next release :( -- : Expr1 InfixOp Expr { undefined } - : TempInfixExpr { undefined } - | LetExpr { undefined } - | CaseExpr { undefined } - | AppExpr { undefined } + : AppExpr { $1 } + -- | TempInfixExpr { undefined } + -- | LetExpr { undefined } + -- | CaseExpr { undefined } -TempInfixExpr :: { Expr RlpcPs } +TempInfixExpr :: { Expr' RlpcPs SrcSpan } TempInfixExpr : Expr1 InfixOp TempInfixExpr { undefined } - | Expr1 InfixOp Expr1 { undefined } + | Expr1 InfixOp Expr1 { undefined } -AppExpr :: { Expr RlpcPs } - : Expr1 { undefined } - | AppExpr Expr1 { undefined } +AppExpr :: { Expr' RlpcPs SrcSpan } + : Expr1 { $1 } + | AppExpr Expr1 { comb2 AppEF $1 $2 } LetExpr :: { Expr RlpcPs } : let layout1(Binding) in Expr { undefined } @@ -205,17 +207,17 @@ layout_list1(sep,p) : p { [$1] } | layout_list1(sep,p) sep p { $1 `snoc` $3 } Binding :: { Binding RlpcPs } - : Pat '=' Expr { undefined } + : Pat '=' Expr { PatB $1 (collapse . strip $ $3) } -Expr1 :: { Expr RlpcPs } - : '(' Expr ')' { undefined } - | Lit { undefined } - | Var { undefined } - | Con { undefined } +Expr1 :: { Expr' RlpcPs SrcSpan } + : '(' Expr ')' { $2 } + | Lit { nolo' $ LitEF $1 } + | Var { case $1 of Located ss _ -> ss :< VarEF $1 } + | Con { case $1 of Located ss _ -> ss :< VarEF $1 } InfixOp :: { PsName } - : consym { undefined } - | varsym { undefined } + : consym { extractName $1 } + | varsym { extractName $1 } -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms) Lit :: { Lit RlpcPs } @@ -224,11 +226,11 @@ Lit :: { Lit RlpcPs } . to IntL } Var :: { PsName } -Var : varname { undefined } - | varsym { undefined } +Var : varname { $1 <&> view (singular _TokenVarName) } + | varsym { $1 <&> view (singular _TokenVarSym) } Con :: { PsName } - : conname { undefined } + : conname { $1 <&> view (singular _TokenConName) } { @@ -301,10 +303,15 @@ _litint = to extract mkPsName = undefined tempInfixExprErr = undefined -extractName = undefined extractInt = undefined mkProgram = undefined +extractName :: Located RlpToken -> PsName +extractName (Located ss (TokenVarSym n)) = Located ss n +extractName (Located ss (TokenVarName n)) = Located ss n +extractName (Located ss (TokenConName n)) = Located ss n +extractName (Located ss (TokenConSym n)) = Located ss n + parseError :: (Located RlpToken, [String]) -> P a parseError ((Located ss t), exp) = addFatal $ errorMsg ss (RlpParErrUnexpectedToken t exp) diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 76a5440..20c9c99 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -18,7 +18,8 @@ module Rlp.Parse.Types , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction , Located(..), PsName -- ** Lenses - , _TokenLitInt, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn + , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym + , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn -- * Error handling , MsgEnvelope(..), RlpcError(..), RlpParseError(..) @@ -93,10 +94,10 @@ data RlpToken -- literals = TokenLitInt Int -- identifiers - | TokenVarName Name - | TokenConName Name - | TokenVarSym Name - | TokenConSym Name + | TokenVarName Text + | TokenConName Text + | TokenVarSym Text + | TokenConSym Text -- reserved words | TokenData | TokenCase @@ -132,6 +133,26 @@ _TokenLitInt = prism TokenLitInt $ \case TokenLitInt n -> Right n x -> Left x +_TokenVarName :: Prism' RlpToken Text +_TokenVarName = prism TokenVarName $ \case + TokenVarName n -> Right n + x -> Left x + +_TokenVarSym :: Prism' RlpToken Text +_TokenVarSym = prism TokenVarSym $ \case + TokenVarSym n -> Right n + x -> Left x + +_TokenConName :: Prism' RlpToken Text +_TokenConName = prism TokenConName $ \case + TokenConName n -> Right n + x -> Left x + +_TokenConSym :: Prism' RlpToken Text +_TokenConSym = prism TokenConSym $ \case + TokenConSym n -> Right n + x -> Left x + newtype P a = P { runP :: ParseState -> (ParseState, [MsgEnvelope RlpParseError], Maybe a) @@ -261,6 +282,7 @@ initAlexInput s = AlexInput -------------------------------------------------------------------------------- + -- deriving instance Lift (Program RlpcPs) -- deriving instance Lift (Decl RlpcPs) -- deriving instance Lift (Pat RlpcPs) diff --git a/src/Rlp/Syntax/Backstage.hs b/src/Rlp/Syntax/Backstage.hs index ee7fc51..ee0b477 100644 --- a/src/Rlp/Syntax/Backstage.hs +++ b/src/Rlp/Syntax/Backstage.hs @@ -1,11 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Rlp.Syntax.Backstage - ( + ( strip, collapse ) where -------------------------------------------------------------------------------- +import Data.Fix hiding (cata) import Data.Functor.Classes +import Data.Functor.Foldable import Rlp.Syntax.Types import Text.Show.Deriving import Language.Haskell.TH.Syntax (Lift) @@ -22,3 +24,9 @@ deriving instance (Show (NameP p), Show a) => Show (Decl p a) deriving instance (Show (NameP p), Show a) => Show (Program p a) +strip :: Functor f => Cofree f a -> Fix f +strip (_ :< as) = Fix $ strip <$> as + +collapse :: Fix (ExprF b) -> Expr b +collapse = cata embed + diff --git a/src/Rlp/Syntax/Types.hs b/src/Rlp/Syntax/Types.hs index ae908c4..603c25b 100644 --- a/src/Rlp/Syntax/Types.hs +++ b/src/Rlp/Syntax/Types.hs @@ -5,6 +5,7 @@ module Rlp.Syntax.Types ( NameP + , SimpleP , Assoc(..) , ConAlt(..) , Alt(..) @@ -20,7 +21,6 @@ module Rlp.Syntax.Types -- * Re-exports , Cofree(..) , Trans.Cofree.CofreeF - , pattern (:<$) , SrcSpan(..) ) where @@ -35,7 +35,7 @@ import Data.Fix import Data.Kind (Type) import GHC.Generics import Language.Haskell.TH.Syntax (Lift) -import Control.Lens +import Control.Lens hiding ((:<)) import Control.Comonad.Trans.Cofree qualified as Trans.Cofree import Control.Comonad.Cofree @@ -47,6 +47,10 @@ import Core.Syntax qualified as Core import Core (Rec(..), HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- +data SimpleP + +type instance NameP SimpleP = String + type family NameP p data Expr p = LetE Rec [Binding p] (Expr p) @@ -68,7 +72,10 @@ 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) +data Ty p = ConT (NameP p) + | VarT (NameP p) + | FunT (Ty p) (Ty p) + | AppT (Ty p) (Ty p) deriving instance (Show (NameP p)) => Show (Ty p) deriving instance (Lift (NameP p)) => Lift (Ty p) @@ -100,9 +107,6 @@ 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) @@ -123,4 +127,11 @@ type Expr' p = Cofree (ExprF p) makeLenses ''Program +loccof :: Iso' (Cofree f SrcSpan) (Located (f (Cofree f SrcSpan))) +loccof = iso sa bt where + sa :: Cofree f SrcSpan -> Located (f (Cofree f SrcSpan)) + sa (ss :< as) = Located ss as + + bt :: Located (f (Cofree f SrcSpan)) -> Cofree f SrcSpan + bt (Located ss as) = ss :< as