diff --git a/src/Control/Parser.hs b/src/Control/Parser.hs index 56860bb..332aeaf 100644 --- a/src/Control/Parser.hs +++ b/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 - diff --git a/src/Core/Lex.hs b/src/Core/Lex.hs index eb82be3..2dca505 100644 --- a/src/Core/Lex.hs +++ b/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 diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index f67c513..b9f4576 100644 --- a/src/Core/Parse.hs +++ b/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 diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 901ab25..46c9c8e 100644 --- a/src/Core/Syntax.hs +++ b/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 diff --git a/src/Data/Pretty.hs b/src/Data/Pretty.hs index 3f30e11..83958a9 100644 --- a/src/Data/Pretty.hs +++ b/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