msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

HasLocation

Browse Source 
HasLocation
This commit is contained in:
crumbtoo
2024-02-16 17:22:24 -07:00
parent da81a5a98e
commit 910cf66468
4 changed files with 77 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files

50
src/Compiler/Types.hs
View File

@@ -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

57
src/Rlp/Parse.y
View File

@@ -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

9
src/Rlp/Parse/Types.hs
View File

@@ -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)

3
src/Rlp/Syntax.hs
View File

@@ -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