i want to fucking die
This commit is contained in:
crumbtoo
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user