say it with me girls, "good enough!"

this is so dogshit

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|
+letrecExample = [coreProg|
-pair x y f = f x y;
+    pair x y f = f x y
-fst p = p k;
+
-snd p = p k1;
+    fst p = p k
-f x y = letrec
+    snd p = p k1
-    { a = pair x b;
+
-    ; b = pair y a
+    f x y =
-    } in fst (snd (snd (snd a)));
+        letrec a = pair x b
-main = f 3 4;
+               b = pair y a
+        in fst (snd (snd (snd a)));
+
+    main = f 3 4;
+
 |]
 
--}

src/Core/Lex.x

@@ -23,9 +23,7 @@ import Lens.Micro.TH
 $whitechar = [ \t\n\r\f\v]
 $special   = [\(\)\,\;\[\]\{\}]
 
-$ascdigit  = 0-9
+$digit     = 0-9
-$unidigit  = [] -- TODO
-$digit     = [$ascdigit $unidigit]
 
 $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 }
 
+<initial>
+{
+    $white                  { skip }
+    \n                      { skip }
+    ()                      { topLevelOff `andBegin` 0 }
+}
+
 <bol>
 {
     \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)
 
 }

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 }

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)
+