diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index 51a1461..ec7ee38 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -5,18 +5,21 @@ import Core.Syntax import Core.TH ---------------------------------------------------------------------------------- -{- +-- TODO: my shitty lexer isn't inserting semicolons letrecExample :: Program -letrecExample = [core| -pair x y f = f x y; -fst p = p k; -snd p = p k1; -f x y = letrec - { a = pair x b; - ; b = pair y a - } in fst (snd (snd (snd a))); -main = f 3 4; +letrecExample = [coreProg| + pair x y f = f x y + + fst p = p k + snd p = p k1 + + f x y = + letrec a = pair x b + b = pair y a + in fst (snd (snd (snd a))); + + main = f 3 4; + |] --} diff --git a/src/Core/Lex.x b/src/Core/Lex.x index 0b4f683..7ca6130 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -23,9 +23,7 @@ import Lens.Micro.TH $whitechar = [ \t\n\r\f\v] $special = [\(\)\,\;\[\]\{\}] -$ascdigit = 0-9 -$unidigit = [] -- TODO -$digit = [$ascdigit $unidigit] +$digit = 0-9 $ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~] $unisymbol = [] -- TODO @@ -62,6 +60,8 @@ rlp :- -- everywhere: skip whitespace $white_no_nl+ { skip } +-- TODO: `--` could begin an operator +"--"[^$nl]* { skip } "--"\-*[^$symbol].* { skip } "{-" { nestedComment } @@ -82,7 +82,7 @@ $white_no_nl+ { skip } <0> { "let" { constTok TokenLet `andBegin` layout } - "letrec" { constTok TokenLet `andBegin` layout } + "letrec" { constTok TokenLetrec `andBegin` layout } "of" { constTok TokenOf `andBegin` layout } "case" { constTok TokenCase } "module" { constTok TokenModule } @@ -106,8 +106,21 @@ $white_no_nl+ { skip } @varsym { lexWith TokenVarSym } } +-- literals +<0> +{ + @decimal { lexWith (TokenLitInt . read @Int) } +} + <0> \n { begin bol } + +{ + $white { skip } + \n { skip } + () { topLevelOff `andBegin` 0 } +} + { \n { skip } @@ -188,7 +201,7 @@ getContext = do type Lexer = AlexInput -> Int -> Alex (Located CoreToken) alexInitUserState :: AlexUserState -alexInitUserState = AlexUserState [Layout 1] +alexInitUserState = AlexUserState [] nestedComment :: Lexer nestedComment _ _ = undefined @@ -205,13 +218,13 @@ lexCore :: String -> RLPC ParseError [Located CoreToken] lexCore s = case m of Left e -> addFatal err where err = SrcError - { _errLocation = undefined -- TODO: location + { _errLocation = (0,0) -- TODO: location , _errSeverity = Error , _errDiagnostic = ParErrLexical e } Right ts -> pure ts where - m = runAlex s (alexSetStartCode 0 *> lexStream) + m = runAlex s (alexSetStartCode initial *> lexStream) -- | @lexCore@, but the tokens are stripped of location info. Useful for -- debugging @@ -280,7 +293,7 @@ getOffside = do _ -> pure GT doBol :: Lexer -doBol (p,c,_,s) l = do +doBol (p,c,_,s) _ = do off <- getOffside case off of LT -> insRBraceV p @@ -292,7 +305,11 @@ letin (p,_,_,_) l = do popContext pure $ Located p TokenIn +topLevelOff :: Lexer +topLevelOff = noBrace + alexEOF :: Alex (Located CoreToken) -alexEOF = Alex $ \ st@(AlexState { alex_pos = p }) -> Right (st, Located p TokenEOF) +alexEOF = Alex $ \ st@(AlexState { alex_pos = p }) -> + Right (st, Located p TokenEOF) } diff --git a/src/Core/Parse.y b/src/Core/Parse.y index 336f7c5..22859b5 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -2,6 +2,7 @@ module Core.Parse ( parseCore , parseCoreExpr + , parseCoreProg , module Core.Lex -- temp convenience , parseTmp , SrcError @@ -19,6 +20,7 @@ import Compiler.RLPC %name parseCore Module %name parseCoreExpr StandaloneExpr +%name parseCoreProg StandaloneProgram %tokentype { Located CoreToken } %error { parseError } %monad { RLPC ParseError } @@ -57,6 +59,9 @@ Eof :: { () } Eof : eof { () } | error { () } +StandaloneProgram :: { Program } +StandaloneProgram : Program eof { $1 } + Program :: { Program } Program : VOpen ScDefs VClose { Program $2 } | '{' ScDefs '}' { Program $2 } diff --git a/src/Core/TH.hs b/src/Core/TH.hs index 8330867..3f70bd5 100644 --- a/src/Core/TH.hs +++ b/src/Core/TH.hs @@ -1,5 +1,6 @@ module Core.TH ( coreExpr + , coreProg , core ) where @@ -21,6 +22,14 @@ core = QuasiQuoter , quoteDec = error "core quasiquotes may only be used in expressions" } +coreProg :: QuasiQuoter +coreProg = QuasiQuoter + { quoteExp = qCoreProg + , quotePat = error "core quasiquotes may only be used in expressions" + , quoteType = error "core quasiquotes may only be used in expressions" + , quoteDec = error "core quasiquotes may only be used in expressions" + } + coreExpr :: QuasiQuoter coreExpr = QuasiQuoter { quoteExp = qCoreExpr @@ -43,3 +52,10 @@ qCoreExpr s = case parseExpr s of where parseExpr = evalRLPC RLPCOptions . (lexCore >=> parseCoreExpr) +qCoreProg :: String -> Q Exp +qCoreProg s = case parseProg s of + Left e -> error (show e) + Right (m,ts) -> lift m + where + parseProg = evalRLPC RLPCOptions . (lexCore >=> parseCoreProg) +