bad core parser just to make development easier

REPLACE WITH A REAL PARSER EVENTUALLY!!!!!!!!!!!!!!

src/Core/Lex.hs

@@ -3,8 +3,8 @@ Module      : Core.Lex
 Description : Core language lexer
 -}
 module Core.Lex
-    ( CoreToken
-    , Result
+    ( CoreToken(..)
+    , Result(..)
     , lexCore
     )
     where
@@ -40,7 +40,7 @@ data CoreToken = TokLitInt Int
                | TokIn
                | TokCName Name
                | TokName Name
-               deriving (Show)
+               deriving (Show, Eq)
 
 instance Functor Result where
     fmap f (Success a)   = Success (f a)
@@ -62,7 +62,7 @@ instance Applicative Result where
     liftA2 _ _             (Error s l c) = Error s l c
 
 instance Alternative Result where
-    empty = Error "unknown failure" 0 0
+    empty = Error "some error! this is a temporary system lol" 0 0
 
     (Success a) <|> _ = Success a
     _           <|> b = b
@@ -93,8 +93,8 @@ token = litInt
     <|> arrow
     <|> _case
     <|> _of
-    <|> _let
     <|> letrec
+    <|> _let
     <|> _in
     <|> cName
     <|> name
@@ -120,16 +120,16 @@ rparen = char ')'                  $> TokRParen
 lambda = (char '\\' <|> char 'λ')  $> TokLambda
 arrow  = string "->"               $> TokArrow
 _case  = string "case"             $> TokCase
-_of = string "of"                  $> TokOf
-_let = string "let"                $> TokLet
+_of    = string "of"               $> TokOf
+_let   = string "let"              $> TokLet
 letrec = string "letrec"           $> TokLetRec
-_in = string "in"                  $> TokIn
+_in    = string "in"               $> TokIn
 
 cName = TokCName <$> ((:) <$> cNameHead <*> properNameTail)
     where cNameHead = satisfy isUpper
 
 name = some (satisfy p) <&> TokName
-    where p c = not (isSpace c) && c `notElem` ";{}"
+    where p c = not (isSpace c) && c `notElem` ";{}()"
 
 properName :: CoreLexer Name
 properName = (:) <$> nameHead <*> properNameTail

src/Core/Parse.hs

@@ -1,13 +1,95 @@
+{-# LANGUAGE LambdaCase, BlockArguments #-}
 module Core.Parse
-    (
+    ( parseCore
     )
     where
 ----------------------------------------------------------------------------------
 import Control.Parser
+import Data.Functor         ((<&>), ($>))
 import Core.Lex
 import Core.Syntax
 ----------------------------------------------------------------------------------
 
-parseCore :: [CoreToken] -> Result Program
-parseCore = undefined
+type CoreParser = ParserT [CoreToken] Result
+
+parseCore :: [CoreToken] -> Result Program
+parseCore = fmap snd . runParserT program
+
+program :: CoreParser Program
+program = Program <$> termMany (char TokSemicolon) scdef
+
+scdef :: CoreParser ScDef
+scdef = ScDef <$> f <*> (xs <* eq) <*> body
+    where
+        f = name
+        xs = many name
+        eq = char TokEquals
+        body = expr
+
+expr :: CoreParser Expr
+expr = letE
+   <|> app
+   <|> lam
+   <|> atom
+
+atom :: CoreParser Expr
+atom  = var
+    <|> con
+    <|> parenE
+    <|> lit
+    where
+        var = Var <$> name
+        parenE = surround (char TokLParen) (char TokRParen) expr
+        lit = IntE <$> litInt
+
+lam :: CoreParser Expr
+lam = Lam <$> (l *> bs) <*> (arrow *> expr)
+    where
+        l = char TokLambda
+        arrow = char TokArrow
+        bs = some name
+
+app :: CoreParser Expr
+app = foldl App <$> atom <*> some atom
+
+con :: CoreParser Expr
+con = pack *> (Con <$> (l *> tag) <*> (arity <* r))
+    where
+        l = char TokLBrace
+        r = char TokRBrace
+        tag = litInt
+        arity = litInt
+        pack = match \case
+            TokCName "Pack" -> Just ()
+            _               -> Nothing
+
+letE :: CoreParser Expr
+letE = Let <$> word <*> defs <*> (char TokIn *> expr)
+    where
+        word = char TokLet    $> NonRec
+           <|> char TokLetRec $> Rec
+        defs = surround (char TokLBrace) (char TokRBrace) bindings
+
+bindings :: CoreParser [Binding]
+bindings = sepSome (char TokSemicolon) binding
+
+binding :: CoreParser Binding
+binding = Binding <$> name <*> (char TokEquals *> expr)
+
+----------------------------------------------------------------------------------
+
+name :: CoreParser Name
+name = match \case
+    TokName n -> Just n
+    _         -> Nothing
+
+cName :: CoreParser Name
+cName = match \case
+    TokCName n -> Just n
+    _          -> Nothing
+
+litInt :: CoreParser Int
+litInt = match \case
+    TokLitInt n -> Just n
+    _           -> Nothing
 

src/Core/Syntax.hs

@@ -53,8 +53,10 @@ data Alter = Alter Int [Name] Expr
 type Name = String
 
 data ScDef = ScDef Name [Name] Expr
+    deriving (Show)
 
 newtype Program = Program [ScDef]
+    deriving (Show)
 
 instance IsString Expr where
     fromString = Var
@@ -63,8 +65,9 @@ instance IsString Expr where
 
 instance Pretty Expr where
     prettyPrec (Var k)      = withPrec maxBound $ IStr k
-    prettyPrec (IntE n)     = withPrec maxBound $ IStr (show n)
-    prettyPrec (Con _ _)    = undefined
+    prettyPrec (IntE n)     = withPrec maxBound $ iShow n
+    prettyPrec (Con t a)    = withPrec maxBound $
+        "Pack{" <> iShow t <> " " <> iShow a <> "}"
     prettyPrec (Let r bs e) = withPrec 0 $
         IStr (if r == Rec then "letrec " else "let ")
         <> binds <> IBreak