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

rc #13

Merged
crumbtoo merged 196 commits from dev into main 2024-02-13 13:22:23 -07:00
Conversation 0 Commits 196 Files Changed 55 +68 -66
4 changed files with 68 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit 50a4d0010c - Show all commits

28
src/Compiler/JustRun.hs
View File

@@ -8,9 +8,9 @@ that use Prelude types such as @Either@ and @String@ rather than more complex
types such as @RLPC@ or @Text@. types such as @RLPC@ or @Text@.
-} -}
module Compiler.JustRun module Compiler.JustRun
( justLexSrc ( justLexCore
, justParseSrc , justParseCore
, justTypeCheckSrc , justTypeCheckCore
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -21,24 +21,26 @@ import Core.Syntax (Program')
import Compiler.RLPC import Compiler.RLPC
import Control.Arrow ((>>>)) import Control.Arrow ((>>>))
import Control.Monad ((>=>)) import Control.Monad ((>=>))
import Control.Comonad
import Control.Lens
import Data.Text qualified as T import Data.Text qualified as T
import Data.Function ((&)) import Data.Function ((&))
import GM import GM
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
justLexSrc :: String -> Either [MsgEnvelope RlpcError] [CoreToken] justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
justLexSrc s = lexCoreR (T.pack s) justLexCore s = lexCoreR (T.pack s)
& fmap (map $ \ (Located _ _ _ t) -> t) & mapped . each %~ extract
& rlpcToEither & rlpcToEither
justParseSrc :: String -> Either [MsgEnvelope RlpcError] Program' justParseCore :: String -> Either [MsgEnvelope RlpcError] Program'
justParseSrc s = parse (T.pack s) justParseCore s = parse (T.pack s)
& rlpcToEither & rlpcToEither
where parse = lexCoreR >=> parseCoreProgR where parse = lexCoreR >=> parseCoreProgR
justTypeCheckSrc :: String -> Either [MsgEnvelope RlpcError] Program' justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
justTypeCheckSrc s = typechk (T.pack s) justTypeCheckCore s = typechk (T.pack s)
& rlpcToEither & rlpcToEither
where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a

21
src/Core/Examples.hs
View File

@@ -76,12 +76,12 @@ negExample3 = [coreProg|
arithExample1 :: Program' arithExample1 :: Program'
arithExample1 = [coreProg| arithExample1 = [coreProg|
main = (+#) 3 (negate# 2); main = +# 3 (negate# 2);
|] |]
arithExample2 :: Program' arithExample2 :: Program'
arithExample2 = [coreProg| arithExample2 = [coreProg|
main = negate# ((+#) 2 ((*#) 5 3)); main = negate# (+# 2 (*# 5 3));
|] |]
ifExample1 :: Program' ifExample1 :: Program'
@@ -96,7 +96,7 @@ ifExample2 = [coreProg|
facExample :: Program' facExample :: Program'
facExample = [coreProg| facExample = [coreProg|
fac n = if# ((==#) n 0) 1 ((*#) n (fac ((-#) n 1))); fac n = if# (==# n 0) 1 (*# n (fac (-# n 1)));
main = fac 3; main = fac 3;
|] |]
@@ -149,14 +149,14 @@ caseBool1 = [coreProg|
false = Pack{0 0}; false = Pack{0 0};
true = Pack{1 0}; true = Pack{1 0};
main = _if false ((+#) 2 3) ((*#) 4 5); main = _if false (+# 2 3) (*# 4 5);
|] |]
fac3 :: Program' fac3 :: Program'
fac3 = [coreProg| fac3 = [coreProg|
fac n = case (==#) n 0 of fac n = case ==# n 0 of
{ <1> -> 1 { <1> -> 1
; <0> -> (*#) n (fac ((-#) n 1)) ; <0> -> *# n (fac (-# n 1))
}; };
main = fac 3; main = fac 3;
@@ -171,7 +171,7 @@ sumList = [coreProg|
list = cons 1 (cons 2 (cons 3 nil)); list = cons 1 (cons 2 (cons 3 nil));
sum l = case l of sum l = case l of
{ <0> -> 0 { <0> -> 0
; <1> x xs -> (+#) x (sum xs) ; <1> x xs -> +# x (sum xs)
}; };
main = sum list; main = sum list;
|] |]
@@ -179,7 +179,7 @@ sumList = [coreProg|
constDivZero :: Program' constDivZero :: Program'
constDivZero = [coreProg| constDivZero = [coreProg|
k x y = x; k x y = x;
main = k 3 ((/#) 1 0); main = k 3 (/# 1 0);
|] |]
idCase :: Program' idCase :: Program'
@@ -187,7 +187,7 @@ idCase = [coreProg|
id x = x; id x = x;
main = id (case Pack{1 0} of main = id (case Pack{1 0} of
{ <1> -> (+#) 2 3 { <1> -> +# 2 3
}) })
|] |]
@@ -197,7 +197,7 @@ namedBoolCase :: Program'
namedBoolCase = [coreProg| namedBoolCase = [coreProg|
{-# PackData True 1 0 #-} {-# PackData True 1 0 #-}
{-# PackData False 0 0 #-} {-# PackData False 0 0 #-}
main = case (==#) 1 1 of main = case ==# 1 1 of
{ True -> 123 { True -> 123
; False -> 456 ; False -> 456
} }
@@ -243,3 +243,4 @@ namedConsCase = [coreProg|
-- ] -- ]
--} --}

17
src/Core/Lex.x
View File

@@ -23,8 +23,9 @@ import Data.String (IsString(..))
import Data.Functor.Identity import Data.Functor.Identity
import Core.Syntax import Core.Syntax
import Compiler.RLPC import Compiler.RLPC
import Compiler.Types
-- TODO: unify Located definitions -- TODO: unify Located definitions
import Compiler.RlpcError hiding (Located(..)) import Compiler.RlpcError
import Lens.Micro import Lens.Micro
import Lens.Micro.TH import Lens.Micro.TH
} }
@@ -120,11 +121,9 @@ rlp :-
} }
{ {
data Located a = Located Int Int Int a
deriving Show
constTok :: t -> AlexInput -> Int -> Alex (Located t) constTok :: t -> AlexInput -> Int -> Alex (Located t)
constTok t (AlexPn _ y x,_,_,_) l = pure $ Located y x l t constTok t (AlexPn _ y x,_,_,_) l = pure $ nolo t
data CoreToken = TokenLet data CoreToken = TokenLet
| TokenLetrec | TokenLetrec
@@ -171,7 +170,7 @@ data SrcErrorType = SrcErrLexical String
type Lexer = AlexInput -> Int -> Alex (Located CoreToken) type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
lexWith :: (Text -> CoreToken) -> Lexer lexWith :: (Text -> CoreToken) -> Lexer
lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s) lexWith f (AlexPn _ y x,_,_,s) l = pure . nolo . f . T.take l $ s
-- | The main lexer driver. -- | The main lexer driver.
lexCore :: Text -> RLPC [Located CoreToken] lexCore :: Text -> RLPC [Located CoreToken]
@@ -191,14 +190,14 @@ lexCoreR = hoistRlpcT generalise . lexCore
-- debugging -- debugging
lexCore' :: Text -> RLPC [CoreToken] lexCore' :: Text -> RLPC [CoreToken]
lexCore' s = fmap f <$> lexCore s lexCore' s = fmap f <$> lexCore s
where f (Located _ _ _ t) = t where f (Located _ t) = t
lexStream :: Alex [Located CoreToken] lexStream :: Alex [Located CoreToken]
lexStream = do lexStream = do
l <- alexMonadScan l <- alexMonadScan
case l of case l of
Located _ _ _ TokenEOF -> pure [l] Located _ TokenEOF -> pure [l]
_ -> (l:) <$> lexStream _ -> (l:) <$> lexStream
data ParseError = ParErrLexical String data ParseError = ParErrLexical String
| ParErrParse | ParErrParse
@@ -214,7 +213,7 @@ instance IsRlpcError ParseError where
alexEOF :: Alex (Located CoreToken) alexEOF :: Alex (Located CoreToken)
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) -> alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
Right (st, Located y x 0 TokenEOF) Right (st, nolo $ TokenEOF)
} }

68
src/Core/Parse.y
View File

@@ -40,34 +40,34 @@ import Data.HashMap.Strict qualified as H
%monad { RLPC } { happyBind } { happyPure } %monad { RLPC } { happyBind } { happyPure }
%token %token
let { Located _ _ _ TokenLet } let { Located _ TokenLet }
letrec { Located _ _ _ TokenLetrec } letrec { Located _ TokenLetrec }
module { Located _ _ _ TokenModule } module { Located _ TokenModule }
where { Located _ _ _ TokenWhere } where { Located _ TokenWhere }
case { Located _ _ _ TokenCase } case { Located _ TokenCase }
of { Located _ _ _ TokenOf } of { Located _ TokenOf }
pack { Located _ _ _ TokenPack } -- temp pack { Located _ TokenPack } -- temp
in { Located _ _ _ TokenIn } in { Located _ TokenIn }
litint { Located _ _ _ (TokenLitInt $$) } litint { Located _ (TokenLitInt $$) }
varname { Located _ _ _ (TokenVarName $$) } varname { Located _ (TokenVarName $$) }
varsym { Located _ _ _ (TokenVarSym $$) } varsym { Located _ (TokenVarSym $$) }
conname { Located _ _ _ (TokenConName $$) } conname { Located _ (TokenConName $$) }
consym { Located _ _ _ (TokenConSym $$) } consym { Located _ (TokenConSym $$) }
alttag { Located _ _ _ (TokenAltTag $$) } alttag { Located _ (TokenAltTag $$) }
word { Located _ _ _ (TokenWord $$) } word { Located _ (TokenWord $$) }
'λ' { Located _ _ _ TokenLambda } 'λ' { Located _ TokenLambda }
'->' { Located _ _ _ TokenArrow } '->' { Located _ TokenArrow }
'=' { Located _ _ _ TokenEquals } '=' { Located _ TokenEquals }
'@' { Located _ _ _ TokenTypeApp } '@' { Located _ TokenTypeApp }
'(' { Located _ _ _ TokenLParen } '(' { Located _ TokenLParen }
')' { Located _ _ _ TokenRParen } ')' { Located _ TokenRParen }
'{' { Located _ _ _ TokenLBrace } '{' { Located _ TokenLBrace }
'}' { Located _ _ _ TokenRBrace } '}' { Located _ TokenRBrace }
'{-#' { Located _ _ _ TokenLPragma } '{-#' { Located _ TokenLPragma }
'#-}' { Located _ _ _ TokenRPragma } '#-}' { Located _ TokenRPragma }
';' { Located _ _ _ TokenSemicolon } ';' { Located _ TokenSemicolon }
'::' { Located _ _ _ TokenHasType } '::' { Located _ TokenHasType }
eof { Located _ _ _ TokenEOF } eof { Located _ TokenEOF }
%% %%
@@ -187,18 +187,18 @@ Id : Var { $1 }
| Con { $1 } | Con { $1 }
Var :: { Name } Var :: { Name }
Var : '(' varsym ')' { $2 } Var : varname { $1 }
| varname { $1 } | varsym { $1 }
Con :: { Name } Con :: { Name }
Con : '(' consym ')' { $2 } Con : conname { $1 }
| conname { $1 } | consym { $1 }
{ {
parseError :: [Located CoreToken] -> RLPC a parseError :: [Located CoreToken] -> RLPC a
parseError (Located y x l t : _) = parseError (Located _ t : _) =
error $ show y <> ":" <> show x error $ "<line>" <> ":" <> "<col>"
<> ": parse error at token `" <> show t <> "'" <> ": parse error at token `" <> show t <> "'"
{-# WARNING parseError "unimpl" #-} {-# WARNING parseError "unimpl" #-}