bad core parser just to make development easier

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

src/Control/Parser.hs

@@ -14,14 +14,17 @@ module Control.Parser
     , satisfy
     , char
     , spaces
-    , nl
     , surround
     , string
+    , match
+    , termMany
+    , sepSome
 
     -- * Control.Applicative re-exports
     , (<|>)
     , many
     , some
+    , empty
     )
     where
 ----------------------------------------------------------------------------------
@@ -56,6 +59,7 @@ instance (Monad m) => Monad (ParserT i m) where
 
 instance (MonadFail m) => MonadFail (ParserT i m) where
     fail s = ParserT $ \i -> fail s
+
 ----------------------------------------------------------------------------------
 
 -- TODO: generalise to non-lists
@@ -64,6 +68,18 @@ satisfy p = ParserT $ \case
     (x:xs) | p x -> pure (xs,x)
     _            -> empty
 
+match :: (MonadPlus m) => (a -> Maybe b) -> ParserT [a] m b
+match f = ParserT $ \case
+    (x:xs) -> case f x of
+        Just b  -> pure (xs,b)
+        Nothing -> empty
+    [] -> empty
+
+termMany :: (MonadPlus m) => ParserT i m t -> ParserT i m o -> ParserT i m [o]
+termMany t a = many (a <* t)
+
+sepSome :: (MonadPlus m) => ParserT i m t -> ParserT i m o -> ParserT i m [o]
+sepSome s a = (:) <$> a <*> many (s *> a)
 
 char :: (MonadPlus m, Eq a) => a -> ParserT [a] m a
 char c = satisfy (==c)
@@ -83,6 +99,3 @@ surround l r c = l *> c <* r
 spaces :: (MonadPlus m) => ParserT String m Int
 spaces = length <$> many (satisfy (==' '))
 
-nl :: (MonadPlus m) => ParserT String m Int
-nl = undefined
-

src/Core/Lex.hs

@@ -3,8 +3,8 @@ Module      : Core.Lex
 Description : Core language lexer
 -}
 module Core.Lex
-    ( CoreToken
+    ( CoreToken(..)
-    , Result
+    , 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
+_of    = string "of"               $> TokOf
-_let = string "let"                $> TokLet
+_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
+type CoreParser = ParserT [CoreToken] Result
-parseCore = undefined
+
+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 (IntE n)     = withPrec maxBound $ iShow n
-    prettyPrec (Con _ _)    = undefined
+    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

src/Data/Pretty.hs

@@ -5,6 +5,7 @@ module Data.Pretty
     , precPretty
     , prettyPrint
     , prettyShow
+    , iShow
     , iBracket
     , withPrec
     , bracketPrec
@@ -69,6 +70,9 @@ withPrec n s p
 bracketPrec :: Int -> Int -> ISeq -> ISeq
 bracketPrec n p s = withPrec n s p
 
+iShow :: (Show a) => a -> ISeq
+iShow = IStr . show
+
 ----------------------------------------------------------------------------------
 
 instance (Pretty a) => Pretty (Maybe a) where