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

oh my god guys!!! Located is a lax semimonoidal endofunctor on the category Hask!!!

Browse Source 
![abstractionjak](https://media.discordapp.net/attachments/1101767463579951154/1200248978642567168/3877820-20SoyBooru.png?ex=65c57df8&is=65b308f8&hm=67da3acb61861cab6156df014b397d78fb8815fa163f2e992474d545beb668ba&=&format=webp&quality=lossless&width=880&height=868)
This commit is contained in:
crumbtoo
2024-01-26 17:25:59 -07:00
parent 6a6076f26e
commit 8d0f324c63
6 changed files with 59 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
src/Rlp/Lex.x
View File

@@ -164,10 +164,10 @@ alexGetByte inp = case inp ^. aiBytes of
-- report the previous char
& aiPrevChar .~ c
-- update the position
& aiPos %~ \ (ln,col) ->
& aiPos %~ \ (ln,col,a) ->
if c == '\n'
then (ln+1,1)
else (ln,col+1)
then (ln+1, 1, a+1)
else (ln, col+1, a+1)
pure (b, inp')
_ -> Just (head bs, inp')
@@ -225,7 +225,7 @@ initAlexInput s = AlexInput
{ _aiPrevChar = '\0'
, _aiSource = s
, _aiBytes = []
, _aiPos = (1,1)
, _aiPos = (1,1,0)
}
runP' :: P a -> Text -> (ParseState, [MsgEnvelope RlpParseError], Maybe a)

24
src/Rlp/Parse.y
View File

@@ -117,34 +117,34 @@ Type :: { Type }
| Type1 { $1 }
FunDecl :: { Decl' RlpcPs }
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
FunDecl : Var Params '=' Expr { FunD undefined $2 $4 Nothing }
Params :: { [Pat' RlpcPs] }
Params : {- epsilon -} { [] }
| Params Pat1 { $1 `snoc` $2 }
Pat1 :: { Pat' RlpcPs }
: Var { VarP $1 }
| Lit { LitP $1 }
: Var { undefined }
| Lit { LitP <$> $1 }
Expr :: { RlpExpr' RlpcPs }
: Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
: Expr1 varsym Expr { undefined }
| Expr1 { $1 }
Expr1 :: { RlpExpr' RlpcPs }
: '(' Expr ')' { wrapFix . Par . unwrapFix $ $2 }
| Lit { Fix . E $ LitEF $1 }
| Var { Fix . E $ VarEF $1 }
: '(' Expr ')' { fmap ParE' $2 }
| Lit { fmap LitE' $1 }
| Var { fmap VarE' $1 }
-- TODO: happy prefers left-associativity. doing such would require adjusting
-- the code in Rlp.Parse.Associate to expect left-associative input rather than
-- right.
InfixExpr :: { RlpExpr' RlpcPs }
: Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
: Expr1 varsym Expr { undefined }
InfixOp :: { PsName }
: consym { $1 }
| varsym { $1 }
: consym { undefined }
| varsym { undefined }
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
Lit :: { Lit' RlpcPs }
@@ -172,8 +172,8 @@ mkProgram ds = do
pure $ RlpProgram (associate pt <$> ds)
parseError :: Located RlpToken -> P a
parseError (Located (l,c,s) t) = addFatal $
errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
parseError (Located (l,c,a,s) t) = addFatal $
errorMsg (SrcSpan l c a s) RlpParErrUnexpectedToken
mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
mkInfixD a p n = do

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

@@ -34,6 +34,7 @@ import Data.Fix
import Data.Functor.Foldable
import Data.Functor.Const
import Data.Functor.Classes
import Data.Functor.Apply
import Data.HashMap.Strict qualified as H
import Data.Void
import Data.Word (Word8)
@@ -50,6 +51,8 @@ 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 PsName = Text
@@ -66,8 +69,9 @@ data AlexInput = AlexInput
deriving Show
type Position =
( Int -- line
, Int -- column
( Int -- ^ line
, Int -- ^ column
, Int -- ^ Absolutely
)
posLine :: Lens' Position Int
@@ -76,6 +80,9 @@ posLine = _1
posColumn :: Lens' Position Int
posColumn = _2
posAbsolute :: Lens' Position Int
posAbsolute = _3
data RlpToken
-- literals
= TokenLitInt Int
@@ -154,12 +161,24 @@ data Layout = Explicit
| Implicit Int
deriving (Show, Eq)
-- | Token wrapped with a span (line, column, length)
data Located a = Located !(Int, Int, Int) a
-- | Token wrapped with a span (line, column, absolute, length)
data Located a = Located !(Int, Int, Int, Int) a
deriving (Show, Functor)
spanFromPos :: Position -> Int -> (Int, Int, Int)
spanFromPos (l,c) s = (l,c,s)
instance Apply Located where
liftF2 f (Located (la,ca,aa,sa) p) (Located (lb,cb,ab,sb) q)
= Located (l,c,a,s) (p `f` q)
where
l = min la lb
c = min ca cb
a = min aa ab
s = case aa `compare` ab of
EQ -> max sa sb
LT -> max sa (ab + sb)
GT -> max sb (aa + sa)
spanFromPos :: Position -> Int -> (Int, Int, Int, Int)
spanFromPos (l,c,a) s = (l,c,a,s)
{-# INLINE spanFromPos #-}
@@ -186,8 +205,9 @@ addWoundHere l e = P $ \st ->
let e' = MsgEnvelope
{ _msgSpan = let pos = psInput . aiPos
in SrcSpan (st ^. pos . posLine)
(st ^. pos . posColumn)
l
(st ^. pos . posColumn)
(st ^. pos . posAbsolute)
l
, _msgDiagnostic = e
, _msgSeverity = SevError
}
@@ -199,6 +219,7 @@ addFatalHere l e = P $ \st ->
{ _msgSpan = let pos = psInput . aiPos
in SrcSpan (st ^. pos . posLine)
(st ^. pos . posColumn)
(st ^. pos . posAbsolute)
l
, _msgDiagnostic = e
, _msgSeverity = SevError

12
src/Rlp/Syntax.hs
View File

@@ -15,7 +15,10 @@ module Rlp.Syntax
, ConAlt(..)
-- * Pattern synonyms for unused extensions
-- ** Decl
, pattern InfixD'
-- ** RlpExpr
, pattern ParE', pattern VarE', pattern LitE'
-- * Trees That Grow extensions
, XRec, IdP
@@ -103,6 +106,15 @@ type family XXRlpExpr p
type family IdP p
pattern ParE' :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p
pattern ParE' e = ParE () e
pattern LitE' :: (XLitE p ~ ()) => Lit p -> RlpExpr p
pattern LitE' e = LitE () e
pattern VarE' :: (XVarE p ~ ()) => IdP p -> RlpExpr p
pattern VarE' e = VarE () e
type Where p = [Bind p]
-- do we want guards?