diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 7329844..28e4ab4 100644 --- a/src/Compiler/Types.hs +++ b/src/Compiler/Types.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} module Compiler.Types ( SrcSpan(..) , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen , Located(..) - , locating + , _Located , nolo , (<<~), (<~>), (<#>) @@ -58,9 +59,6 @@ srcspanLen = tupling . _4 nolo :: a -> Located a nolo = Located (SrcSpan 0 0 0 0) -locating :: Lens (Located a) (Located b) a b -locating = lens extract ($>) - instance Semigroup SrcSpan where SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where l = min la lb @@ -93,3 +91,5 @@ fab <#> a = fmap ($ a) fab infixl 4 <#> +makePrisms ''Located + diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index 51eaf4c..26363e5 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -173,15 +173,22 @@ Pat1 :: { Pat' RlpcPs } | '(' Pat ')' { $1 .> $2 <. $3 } Expr :: { RlpExpr' RlpcPs } - : Expr1 InfixOp Expr { $2 =>> \o -> - OAppE (extract o) $1 $3 } + -- infixities delayed till next release :( + -- : Expr1 InfixOp Expr { $2 =>> \o -> + -- OAppE (extract o) $1 $3 } + : TempInfixExpr { $1 } | LetExpr { $1 } | CaseExpr { $1 } - | ExprApp { $1 } + | AppExpr { $1 } -ExprApp :: { RlpExpr' RlpcPs } +TempInfixExpr :: { RlpExpr' RlpcPs } +TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 } + | Expr1 InfixOp Expr1 { $2 =>> \o -> + OAppE (extract o) $1 $3 } + +AppExpr :: { RlpExpr' RlpcPs } : Expr1 { $1 } - | ExprApp Expr1 { AppE <<~ $1 <~> $2 } + | AppExpr Expr1 { AppE <<~ $1 <~> $2 } LetExpr :: { RlpExpr' RlpcPs } : let layout1(Binding) in Expr { $1 \$> LetE $2 $4 } @@ -288,5 +295,12 @@ mkInfixD a p n = do intOfToken :: Located RlpToken -> Int intOfToken (Located _ (TokenLitInt n)) = n +tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a +tempInfixExprErr (Located a _) (Located b _) = + addFatal $ errorMsg (a <> b) $ RlpParErrOther + [ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :(" + , "In the mean time, don't mix any infix operators." + ] + } diff --git a/src/Rlp/Parse/Associate.hs b/src/Rlp/Parse/Associate.hs index fa7c33b..6757705 100644 --- a/src/Rlp/Parse/Associate.hs +++ b/src/Rlp/Parse/Associate.hs @@ -1,18 +1,25 @@ module Rlp.Parse.Associate + {-# WARNING "unimplemented" #-} ( associate ) where -------------------------------------------------------------------------------- import Data.HashMap.Strict qualified as H import Data.Functor.Foldable +import Data.Functor.Foldable.TH import Data.Functor.Const +import Data.Functor +import Data.Text qualified as T +import Text.Printf import Lens.Micro import Rlp.Parse.Types import Rlp.Syntax -------------------------------------------------------------------------------- -associate :: OpTable -> RlpExpr' RlpcPs -> RlpExpr' RlpcPs -associate pt e = undefined +associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs +associate _ p = p + +{-# WARNING associate "unimplemented" #-} examplePrecTable :: OpTable examplePrecTable = H.fromList diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index e253fdd..244b7e1 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -200,12 +200,11 @@ data Layout = Explicit type OpTable = H.HashMap Name OpInfo type OpInfo = (Assoc, Int) --- data WithLocation a = WithLocation [String] a - data RlpParseError = RlpParErrOutOfBoundsPrecedence Int | RlpParErrDuplicateInfixD Name | RlpParErrLexical | RlpParErrUnexpectedToken RlpToken [String] + | RlpParErrOther [Text] deriving (Show) instance IsRlpcError RlpParseError where @@ -224,6 +223,8 @@ instance IsRlpcError RlpParseError where Text [ "Unexpected token " <> tshow t , "Expected: " <> tshow exp ] + RlpParErrOther ts -> + Text ts where tshow :: (Show a) => a -> T.Text tshow = T.pack . show diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index 5630794..55146e0 100644 --- a/src/Rlp/Syntax.hs +++ b/src/Rlp/Syntax.hs @@ -9,7 +9,7 @@ module Rlp.Syntax -- * AST RlpProgram(..) , progDecls - , Decl(..), Decl', RlpExpr(..), RlpExpr' + , Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..) , Pat(..), Pat' , Alt(..), Where , Assoc(..)