small core fixes
This commit is contained in:
crumbtoo
@@ -8,9 +8,9 @@ that use Prelude types such as @Either@ and @String@ rather than more complex
|
||||
types such as @RLPC@ or @Text@.
|
||||
-}
|
||||
module Compiler.JustRun
|
||||
( justLexSrc
|
||||
, justParseSrc
|
||||
, justTypeCheckSrc
|
||||
( justLexCore
|
||||
, justParseCore
|
||||
, justTypeCheckCore
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -21,24 +21,26 @@ import Core.Syntax (Program')
|
||||
import Compiler.RLPC
|
||||
import Control.Arrow ((>>>))
|
||||
import Control.Monad ((>=>))
|
||||
import Control.Comonad
|
||||
import Control.Lens
|
||||
import Data.Text qualified as T
|
||||
import Data.Function ((&))
|
||||
import GM
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
justLexSrc :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
|
||||
justLexSrc s = lexCoreR (T.pack s)
|
||||
& fmap (map $ \ (Located _ _ _ t) -> t)
|
||||
& rlpcToEither
|
||||
justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
|
||||
justLexCore s = lexCoreR (T.pack s)
|
||||
& mapped . each %~ extract
|
||||
& rlpcToEither
|
||||
|
||||
justParseSrc :: String -> Either [MsgEnvelope RlpcError] Program'
|
||||
justParseSrc s = parse (T.pack s)
|
||||
& rlpcToEither
|
||||
justParseCore :: String -> Either [MsgEnvelope RlpcError] Program'
|
||||
justParseCore s = parse (T.pack s)
|
||||
& rlpcToEither
|
||||
where parse = lexCoreR >=> parseCoreProgR
|
||||
|
||||
justTypeCheckSrc :: String -> Either [MsgEnvelope RlpcError] Program'
|
||||
justTypeCheckSrc s = typechk (T.pack s)
|
||||
& rlpcToEither
|
||||
justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
|
||||
justTypeCheckCore s = typechk (T.pack s)
|
||||
& rlpcToEither
|
||||
where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
|
||||
|
||||
rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
|
||||
|
||||
@@ -76,12 +76,12 @@ negExample3 = [coreProg|
|
||||
|
||||
arithExample1 :: Program'
|
||||
arithExample1 = [coreProg|
|
||||
main = (+#) 3 (negate# 2);
|
||||
main = +# 3 (negate# 2);
|
||||
|]
|
||||
|
||||
arithExample2 :: Program'
|
||||
arithExample2 = [coreProg|
|
||||
main = negate# ((+#) 2 ((*#) 5 3));
|
||||
main = negate# (+# 2 (*# 5 3));
|
||||
|]
|
||||
|
||||
ifExample1 :: Program'
|
||||
@@ -96,7 +96,7 @@ ifExample2 = [coreProg|
|
||||
|
||||
facExample :: Program'
|
||||
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;
|
||||
|]
|
||||
|
||||
@@ -149,14 +149,14 @@ caseBool1 = [coreProg|
|
||||
false = Pack{0 0};
|
||||
true = Pack{1 0};
|
||||
|
||||
main = _if false ((+#) 2 3) ((*#) 4 5);
|
||||
main = _if false (+# 2 3) (*# 4 5);
|
||||
|]
|
||||
|
||||
fac3 :: Program'
|
||||
fac3 = [coreProg|
|
||||
fac n = case (==#) n 0 of
|
||||
fac n = case ==# n 0 of
|
||||
{ <1> -> 1
|
||||
; <0> -> (*#) n (fac ((-#) n 1))
|
||||
; <0> -> *# n (fac (-# n 1))
|
||||
};
|
||||
|
||||
main = fac 3;
|
||||
@@ -171,7 +171,7 @@ sumList = [coreProg|
|
||||
list = cons 1 (cons 2 (cons 3 nil));
|
||||
sum l = case l of
|
||||
{ <0> -> 0
|
||||
; <1> x xs -> (+#) x (sum xs)
|
||||
; <1> x xs -> +# x (sum xs)
|
||||
};
|
||||
main = sum list;
|
||||
|]
|
||||
@@ -179,7 +179,7 @@ sumList = [coreProg|
|
||||
constDivZero :: Program'
|
||||
constDivZero = [coreProg|
|
||||
k x y = x;
|
||||
main = k 3 ((/#) 1 0);
|
||||
main = k 3 (/# 1 0);
|
||||
|]
|
||||
|
||||
idCase :: Program'
|
||||
@@ -187,7 +187,7 @@ idCase = [coreProg|
|
||||
id x = x;
|
||||
|
||||
main = id (case Pack{1 0} of
|
||||
{ <1> -> (+#) 2 3
|
||||
{ <1> -> +# 2 3
|
||||
})
|
||||
|]
|
||||
|
||||
@@ -197,7 +197,7 @@ namedBoolCase :: Program'
|
||||
namedBoolCase = [coreProg|
|
||||
{-# PackData True 1 0 #-}
|
||||
{-# PackData False 0 0 #-}
|
||||
main = case (==#) 1 1 of
|
||||
main = case ==# 1 1 of
|
||||
{ True -> 123
|
||||
; False -> 456
|
||||
}
|
||||
@@ -243,3 +243,4 @@ namedConsCase = [coreProg|
|
||||
-- ]
|
||||
|
||||
--}
|
||||
|
||||
|
||||
@@ -23,8 +23,9 @@ import Data.String (IsString(..))
|
||||
import Data.Functor.Identity
|
||||
import Core.Syntax
|
||||
import Compiler.RLPC
|
||||
import Compiler.Types
|
||||
-- TODO: unify Located definitions
|
||||
import Compiler.RlpcError hiding (Located(..))
|
||||
import Compiler.RlpcError
|
||||
import Lens.Micro
|
||||
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 (AlexPn _ y x,_,_,_) l = pure $ Located y x l t
|
||||
constTok t (AlexPn _ y x,_,_,_) l = pure $ nolo t
|
||||
|
||||
data CoreToken = TokenLet
|
||||
| TokenLetrec
|
||||
@@ -171,7 +170,7 @@ data SrcErrorType = SrcErrLexical String
|
||||
type Lexer = AlexInput -> Int -> Alex (Located CoreToken)
|
||||
|
||||
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.
|
||||
lexCore :: Text -> RLPC [Located CoreToken]
|
||||
@@ -191,14 +190,14 @@ lexCoreR = hoistRlpcT generalise . lexCore
|
||||
-- debugging
|
||||
lexCore' :: Text -> RLPC [CoreToken]
|
||||
lexCore' s = fmap f <$> lexCore s
|
||||
where f (Located _ _ _ t) = t
|
||||
where f (Located _ t) = t
|
||||
|
||||
lexStream :: Alex [Located CoreToken]
|
||||
lexStream = do
|
||||
l <- alexMonadScan
|
||||
case l of
|
||||
Located _ _ _ TokenEOF -> pure [l]
|
||||
_ -> (l:) <$> lexStream
|
||||
Located _ TokenEOF -> pure [l]
|
||||
_ -> (l:) <$> lexStream
|
||||
|
||||
data ParseError = ParErrLexical String
|
||||
| ParErrParse
|
||||
@@ -214,7 +213,7 @@ instance IsRlpcError ParseError where
|
||||
|
||||
alexEOF :: Alex (Located CoreToken)
|
||||
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
|
||||
Right (st, Located y x 0 TokenEOF)
|
||||
Right (st, nolo $ TokenEOF)
|
||||
|
||||
}
|
||||
|
||||
|
||||
@@ -40,34 +40,34 @@ import Data.HashMap.Strict qualified as H
|
||||
%monad { RLPC } { happyBind } { happyPure }
|
||||
|
||||
%token
|
||||
let { Located _ _ _ TokenLet }
|
||||
letrec { Located _ _ _ TokenLetrec }
|
||||
module { Located _ _ _ TokenModule }
|
||||
where { Located _ _ _ TokenWhere }
|
||||
case { Located _ _ _ TokenCase }
|
||||
of { Located _ _ _ TokenOf }
|
||||
pack { Located _ _ _ TokenPack } -- temp
|
||||
in { Located _ _ _ TokenIn }
|
||||
litint { Located _ _ _ (TokenLitInt $$) }
|
||||
varname { Located _ _ _ (TokenVarName $$) }
|
||||
varsym { Located _ _ _ (TokenVarSym $$) }
|
||||
conname { Located _ _ _ (TokenConName $$) }
|
||||
consym { Located _ _ _ (TokenConSym $$) }
|
||||
alttag { Located _ _ _ (TokenAltTag $$) }
|
||||
word { Located _ _ _ (TokenWord $$) }
|
||||
'λ' { Located _ _ _ TokenLambda }
|
||||
'->' { Located _ _ _ TokenArrow }
|
||||
'=' { Located _ _ _ TokenEquals }
|
||||
'@' { Located _ _ _ TokenTypeApp }
|
||||
'(' { Located _ _ _ TokenLParen }
|
||||
')' { Located _ _ _ TokenRParen }
|
||||
'{' { Located _ _ _ TokenLBrace }
|
||||
'}' { Located _ _ _ TokenRBrace }
|
||||
'{-#' { Located _ _ _ TokenLPragma }
|
||||
'#-}' { Located _ _ _ TokenRPragma }
|
||||
';' { Located _ _ _ TokenSemicolon }
|
||||
'::' { Located _ _ _ TokenHasType }
|
||||
eof { Located _ _ _ TokenEOF }
|
||||
let { Located _ TokenLet }
|
||||
letrec { Located _ TokenLetrec }
|
||||
module { Located _ TokenModule }
|
||||
where { Located _ TokenWhere }
|
||||
case { Located _ TokenCase }
|
||||
of { Located _ TokenOf }
|
||||
pack { Located _ TokenPack } -- temp
|
||||
in { Located _ TokenIn }
|
||||
litint { Located _ (TokenLitInt $$) }
|
||||
varname { Located _ (TokenVarName $$) }
|
||||
varsym { Located _ (TokenVarSym $$) }
|
||||
conname { Located _ (TokenConName $$) }
|
||||
consym { Located _ (TokenConSym $$) }
|
||||
alttag { Located _ (TokenAltTag $$) }
|
||||
word { Located _ (TokenWord $$) }
|
||||
'λ' { Located _ TokenLambda }
|
||||
'->' { Located _ TokenArrow }
|
||||
'=' { Located _ TokenEquals }
|
||||
'@' { Located _ TokenTypeApp }
|
||||
'(' { Located _ TokenLParen }
|
||||
')' { Located _ TokenRParen }
|
||||
'{' { Located _ TokenLBrace }
|
||||
'}' { Located _ TokenRBrace }
|
||||
'{-#' { Located _ TokenLPragma }
|
||||
'#-}' { Located _ TokenRPragma }
|
||||
';' { Located _ TokenSemicolon }
|
||||
'::' { Located _ TokenHasType }
|
||||
eof { Located _ TokenEOF }
|
||||
|
||||
%%
|
||||
|
||||
@@ -187,18 +187,18 @@ Id : Var { $1 }
|
||||
| Con { $1 }
|
||||
|
||||
Var :: { Name }
|
||||
Var : '(' varsym ')' { $2 }
|
||||
| varname { $1 }
|
||||
Var : varname { $1 }
|
||||
| varsym { $1 }
|
||||
|
||||
Con :: { Name }
|
||||
Con : '(' consym ')' { $2 }
|
||||
| conname { $1 }
|
||||
Con : conname { $1 }
|
||||
| consym { $1 }
|
||||
|
||||
{
|
||||
|
||||
parseError :: [Located CoreToken] -> RLPC a
|
||||
parseError (Located y x l t : _) =
|
||||
error $ show y <> ":" <> show x
|
||||
parseError (Located _ t : _) =
|
||||
error $ "<line>" <> ":" <> "<col>"
|
||||
<> ": parse error at token `" <> show t <> "'"
|
||||
|
||||
{-# WARNING parseError "unimpl" #-}
|
||||
|
||||
Reference in New Issue
Block a user