diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 106c5cc..aeb5eef 100644 --- a/src/Compiler/Types.hs +++ b/src/Compiler/Types.hs @@ -1,12 +1,16 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-} module Compiler.Types ( SrcSpan(..) , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen , Located(..) + , HasLocation(location) , _Located - , located , nolo + , (<~>), (~>) + -- * Re-exports , Comonad , Apply @@ -14,19 +18,38 @@ module Compiler.Types ) where -------------------------------------------------------------------------------- +import Language.Haskell.TH.Syntax (Lift) + import Control.Comonad +import Control.Comonad.Cofree import Data.Functor.Apply import Data.Functor.Bind +import Data.Semigroup.Foldable +import Data.Kind import Control.Lens hiding ((<<~)) -import Language.Haskell.TH.Syntax (Lift) + +import Data.List.NonEmpty (NonEmpty) -------------------------------------------------------------------------------- -- | Token wrapped with a span (line, column, absolute, length) data Located a = Located SrcSpan a deriving (Show, Lift, Functor) -located :: Lens (Located a) (Located b) a b -located = lens extract ($>) +class GetLocation s where + srcspan :: s -> SrcSpan + +class HasLocation s where + location :: Lens' s SrcSpan + +(<~>) :: a -> b -> SrcSpan +(<~>) = undefined + +infixl 5 <~> + +(~>) :: a -> b -> b +(~>) = undefined + +infixl 4 ~> instance Apply Located where liftF2 f (Located sa p) (Located sb q) @@ -78,3 +101,22 @@ instance Semigroup SrcSpan where 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/Parse.y b/src/Rlp/Parse.y index 1f28755..ec61798 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -72,32 +72,21 @@ import Compiler.Types %% StandaloneProgram :: { Program RlpcPs } -StandaloneProgram : '{' Decls '}' { undefined } - | VL DeclsV VR { undefined } +StandaloneProgram : layout0(Decl) { Program $1 } StandaloneExpr :: { Expr RlpcPs } - : VL Expr VR { undefined } + : VL Expr VR { $2 } VL :: { () } -VL : vlbrace { undefined } +VL : vlbrace { () } VR :: { () } -VR : vrbrace { undefined } - | error { undefined } +VR : vrbrace { () } + | error { () } -Decls :: { [Decl RlpcPs] } -Decls : Decl ';' Decls { undefined } - | Decl ';' { undefined } - | Decl { undefined } - -DeclsV :: { [Decl RlpcPs] } -DeclsV : Decl VS DeclsV { undefined } - | Decl VS { undefined } - | Decl { undefined } - -VS :: { Located RlpToken } -VS : ';' { undefined } - | vsemi { undefined } +VS :: { () } +VS : ';' { () } + | vsemi { () } Decl :: { Decl RlpcPs } : FunDecl { undefined } @@ -148,7 +137,7 @@ TypeApp :: { Ty RlpcPs } | TypeApp Type1 { undefined } FunDecl :: { Decl RlpcPs } -FunDecl : Var Params '=' Expr { undefined } +FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing } Params :: { [Pat RlpcPs] } Params : {- epsilon -} { undefined } @@ -199,21 +188,21 @@ Alt :: { Alt RlpcPs } : Pat '->' Expr { undefined } -- layout0(p : β) :: [β] -layout0(p) : '{' layout_list0(';',p) '}' { undefined } - | VL layout_list0(VS,p) VR { undefined } +layout0(p) : '{' layout_list0(';',p) '}' { $2 } + | VL layout_list0(VS,p) VR { $2 } -- layout_list0(sep : α, p : β) :: [β] -layout_list0(sep,p) : p { undefined } - | layout_list1(sep,p) sep p { undefined } - | {- epsilon -} { undefined } +layout_list0(sep,p) : p { [$1] } + | layout_list1(sep,p) sep p { $1 `snoc` $3 } + | {- epsilon -} { [] } -- layout1(p : β) :: [β] -layout1(p) : '{' layout_list1(';',p) '}' { undefined } - | VL layout_list1(VS,p) VR { undefined } +layout1(p) : '{' layout_list1(';',p) '}' { $2 } + | VL layout_list1(VS,p) VR { $2 } -- layout_list1(sep : α, p : β) :: [β] -layout_list1(sep,p) : p { undefined } - | layout_list1(sep,p) sep p { undefined } +layout_list1(sep,p) : p { [$1] } + | layout_list1(sep,p) sep p { $1 `snoc` $3 } Binding :: { Binding RlpcPs } : Pat '=' Expr { undefined } @@ -230,17 +219,17 @@ InfixOp :: { Located PsName } -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms) Lit :: { Lit RlpcPs } - : litint { undefined } + : litint { $1 ^. to extract + . singular _TokenLitInt + . to IntL } -Var :: { Located PsName } +Var :: { PsName } Var : varname { undefined } | varsym { undefined } -Con :: { Located PsName } +Con :: { PsName } : conname { undefined } ---} - { parseRlpProgR = undefined diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index c449aea..10a5fd9 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -17,7 +17,7 @@ module Rlp.Parse.Types , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction , Located(..), PsName -- ** Lenses - , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn + , _TokenLitInt, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn -- * Error handling , MsgEnvelope(..), RlpcError(..), RlpParseError(..) @@ -53,7 +53,7 @@ data RlpcPs type instance NameP RlpcPs = PsName -type PsName = Text +type PsName = Located Text -------------------------------------------------------------------------------- @@ -125,6 +125,11 @@ data RlpToken | TokenEOF deriving (Show) +_TokenLitInt :: Prism' RlpToken Int +_TokenLitInt = prism TokenLitInt $ \case + TokenLitInt n -> Right n + x -> Left x + newtype P a = P { runP :: ParseState -> (ParseState, [MsgEnvelope RlpParseError], Maybe a) diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index fb9f2c0..9a4676b 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -40,12 +40,11 @@ import Control.Comonad.Cofree import Data.Functor.Foldable import Data.Functor.Foldable.TH (makeBaseFunctor) -import Compiler.Types (SrcSpan(..)) +import Compiler.Types (SrcSpan(..), Located(..)) import Core.Syntax qualified as Core import Core (Rec(..), HasRHS(..), HasLHS(..)) ---------------------------------------------------------------------------------- -type PsName = Text type family NameP p data Program p = Program