diff --git a/src/Compiler/JustRun.hs b/src/Compiler/JustRun.hs index 6a0d4ca..23cdc9e 100644 --- a/src/Compiler/JustRun.hs +++ b/src/Compiler/JustRun.hs @@ -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 diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index ee1fe25..b13abe5 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -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| -- ] --} + diff --git a/src/Core/Lex.x b/src/Core/Lex.x index dba29c9..f62fb8d 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -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) } diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 467216d..3d119cf 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -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 $ "" <> ":" <> "" <> ": parse error at token `" <> show t <> "'" {-# WARNING parseError "unimpl" #-}