Add function parser

Also, we now define and use proper symbol and keyword parsers.

6 files changed, 161 insertions, 43 deletions

diff --git a/src/Language/SimpleShell/AST/Function.hs b/src/Language/SimpleShell/AST/Function.hs
index 7594c0d..db85585 100644
--- a/src/Language/SimpleShell/AST/Function.hs
+++ b/src/Language/SimpleShell/AST/Function.hs
@@ -5,8 +5,8 @@ where
 
 
 import Language.SimpleShell.AST.Expr (Expr)
-import Language.SimpleShell.AST.Name (VarName)
+import Language.SimpleShell.AST.Name (FunName, VarName)
 
 
-data Function = Function [VarName] Expr
+data Function = Function FunName [VarName] Expr
   deriving (Show)
diff --git a/src/Language/SimpleShell/Parser.hs b/src/Language/SimpleShell/Parser.hs
index dd65ffe..d75602b 100644
--- a/src/Language/SimpleShell/Parser.hs
+++ b/src/Language/SimpleShell/Parser.hs
@@ -3,8 +3,10 @@
 module Language.SimpleShell.Parser
   ( Parser
   , lexeme
+  , symbol
   , lookupVar
   , lookupFun
+  , declareVars
   , initContext
   , parseTest
   )
@@ -12,18 +14,22 @@ where
 
 
 import Language.SimpleShell.AST.Name (FunName, VarName)
-import Language.SimpleShell.AST.SimpleType (SimpleType, FunSig)
+import Language.SimpleShell.AST.SimpleType (SimpleType, FunSig, Typed)
 
-import Control.Monad.Reader (ask, ReaderT, runReaderT)
+import Control.Monad (void)
+import Control.Monad.Reader (ask, local, ReaderT, runReaderT)
+import Data.List (nub)
 import Data.Map (Map)
-import qualified Data.Map as Map (empty, lookup)
+import qualified Data.Map as Map (empty, lookup, fromList)
 import Data.Text (Text, unpack)
+import Data.Tuple (swap)
 import Data.Void (Void)
 import Text.Megaparsec (Parsec)
 import qualified Text.Megaparsec as MP (parseTest)
 import Text.Megaparsec.Char (space1)
 import qualified Text.Megaparsec.Char.Lexer as L
   ( lexeme
+  , symbol
   , space
   , skipLineComment
   , skipBlockComment
@@ -53,6 +59,9 @@ sc = L.space
 lexeme :: Parser a -> Parser a
 lexeme = L.lexeme sc
 
+symbol :: Text -> Parser ()
+symbol = void . L.symbol sc
+
 
 lookupVar :: VarName -> Parser SimpleType
 lookupVar varname = do
@@ -68,6 +77,13 @@ lookupFun fname = do
     Just sig -> return sig
     Nothing  -> fail $ "Undefined function " ++ unpack fname
 
+declareVars :: [Typed VarName] -> Parser a -> Parser a
+declareVars decls p = do
+  let names = map snd decls
+  if length (nub names) == length names   -- TODO: inefficient
+  then local (\ctx -> ctx { ctxVars = Map.fromList $ map swap decls }) p
+  else fail "Duplicate variable name."
+
 
 parseTest :: Show a => Parser a -> Text -> IO ()
 parseTest p = MP.parseTest (runReaderT p initContext)
diff --git a/src/Language/SimpleShell/Parser/Expr.hs b/src/Language/SimpleShell/Parser/Expr.hs
index ac6c340..05120ce 100644
--- a/src/Language/SimpleShell/Parser/Expr.hs
+++ b/src/Language/SimpleShell/Parser/Expr.hs
@@ -3,14 +3,22 @@
 
 module Language.SimpleShell.Parser.Expr
   ( exprP
+  , strongTermP
   )
 where
 
 
-import Language.SimpleShell.Parser (Parser, lexeme, lookupVar, lookupFun)
 import Language.SimpleShell.AST.Expr (Expr(..), TypedExpr)
-import Language.SimpleShell.AST.Name (FunName, VarName)
 import Language.SimpleShell.AST.SimpleType (SimpleType(..))
+import Language.SimpleShell.Parser
+  ( Parser
+  , lexeme
+  , symbol
+  , lookupVar
+  , lookupFun
+  )
+import Language.SimpleShell.Parser.Name (funNameP, varNameP, keyword)
+import Language.SimpleShell.Parser.SimpleType (forceType)
 import Control.Monad.Combinators.FailExpr
   ( Associativity(..)
   , makeExprParser
@@ -19,11 +27,9 @@ import Control.Monad.Combinators.FailExpr
 
 import Control.Applicative ((<|>))
 import Control.Monad.Combinators (manyTill)
-import Data.Char (isAlpha)
 import Data.Foldable (asum)
 import Data.Text (Text)
-import Text.Megaparsec (takeWhile1P)
-import Text.Megaparsec.Char (string, char)
+import Text.Megaparsec.Char (char)
 import qualified Text.Megaparsec.Char.Lexer as L (charLiteral, decimal)
 
 
@@ -42,31 +48,27 @@ strongTermP :: Parser TypedExpr
 strongTermP
    =  literalP
   <|> varP
-  <|> lexeme (char '(') *> exprP <* lexeme (char ')')
+  <|> symbol "(" *> exprP <* symbol ")"
 
 
 -- | Parse "strong" term with fixed type.
 strongTermP' :: String -> SimpleType -> Parser Expr
-strongTermP' errMsg t = do
-  (t', e) <- strongTermP
-  if t == t'
-  then return e
-  else fail errMsg
+strongTermP' errMsg t = forceType t strongTermP <|> fail errMsg
 
 
 literalP :: Parser TypedExpr
 literalP
    =  (IntType,)  . IntLiteral  <$> lexeme L.decimal
-  <|> (StrType,)  . StrLiteral  <$> lexeme strLitP
-  <|> (BoolType,) . BoolLiteral <$> lexeme boolLitP
+  <|> (StrType,)  . StrLiteral  <$> strLitP
+  <|> (BoolType,) . BoolLiteral <$> boolLitP
   where
-    strLitP = char '"' *> manyTill L.charLiteral (char '"')
+    strLitP = lexeme $ char '"' *> manyTill L.charLiteral (char '"')
     boolLitP
-       =  True  <$ string "true"
-      <|> False <$ string "false"
+       =  True  <$ keyword "true"
+      <|> False <$ keyword "false"
 
 varP :: Parser TypedExpr
-varP = lexeme $ do
+varP = do
   _ <- char '$'
   x <- varNameP
   t <- lookupVar x
@@ -74,21 +76,12 @@ varP = lexeme $ do
 
 funP :: Parser TypedExpr
 funP = do
-  fname <- lexeme funNameP
+  fname <- funNameP
   (t', ts) <- lookupFun fname
   args <- mapM (strongTermP' "Type mismatch with function signature.") ts
   return (t', FunCall fname args)
 
 
--- TODO
-varNameP :: Parser VarName
-varNameP = takeWhile1P Nothing isAlpha
-
--- TODO
-funNameP :: Parser FunName
-funNameP = takeWhile1P Nothing isAlpha
-
-
 -- Binary operators.
 
 type BinaryFun = Expr -> Expr -> Expr
@@ -127,7 +120,7 @@ binaryOperatorTable =
 
     addP :: Parser (TypedExpr -> TypedExpr -> Maybe TypedExpr)
     addP = do
-      _ <- lexeme $ char '+'
+      symbol "+"
       return $ \(t1, x1) (t2, x2) ->
         if t1 == t2
         then
@@ -140,8 +133,8 @@ binaryOperatorTable =
     binary
       :: Associativity -> Text -> BinaryFun -> BinarySig
       -> Operator Parser TypedExpr
-    binary assoc symbol op sig = Binary assoc $ do
-      _ <- lexeme $ string symbol
+    binary assoc symb op sig = Binary assoc $ do
+      symbol symb
       return $ \(t1, e1) (t2, e2) -> fmap (, op e1 e2) $ sig t1 t2
 
 
@@ -153,12 +146,12 @@ type UnaryParser = Parser (TypedExpr -> Maybe TypedExpr)
 
 unaryOperators, builtinUnaryFuns :: [UnaryParser]
 (unaryOperators, builtinUnaryFuns) =
-  ( [ unary "!"      Not     $ uniqueSig BoolType BoolType
-    , unary "-"      UMinus  $ uniqueSig IntType  IntType
+  ( [ unaryOp  "!"      Not     $ uniqueSig BoolType BoolType
+    , unaryOp  "-"      UMinus  $ uniqueSig IntType  IntType
     ]
-  , [ unary "length" Length  $ uniqueSig StrType  IntType
-    , unary "int"    IntCast $ uniqueSig StrType  IntType
-    , unary "str"    StrCast $ uniqueSig IntType  StrType
+  , [ unaryFun "length" Length  $ uniqueSig StrType  IntType
+    , unaryFun "int"    IntCast $ uniqueSig StrType  IntType
+    , unaryFun "str"    StrCast $ uniqueSig IntType  StrType
     ]
   )
   where
@@ -167,9 +160,15 @@ unaryOperators, builtinUnaryFuns :: [UnaryParser]
       | t1 == t1' = Just t2
       | otherwise = Nothing
 
-    unary :: Text -> UnaryFun -> UnarySig -> UnaryParser
-    unary symbol op sig = do
-      _ <- lexeme $ string symbol
+    unaryOp :: Text -> UnaryFun -> UnarySig -> UnaryParser
+    unaryOp = unary symbol
+
+    unaryFun :: Text -> UnaryFun -> UnarySig -> UnaryParser
+    unaryFun = unary keyword
+
+    unary :: (Text -> Parser ()) -> Text -> UnaryFun -> UnarySig -> UnaryParser
+    unary symbPF symb op sig = do
+      symbPF symb
       return $ \(t, e) -> fmap (, op e) $ sig t
 
 unaryOpP, builtinUnaryFunP :: Parser TypedExpr
diff --git a/src/Language/SimpleShell/Parser/Function.hs b/src/Language/SimpleShell/Parser/Function.hs
new file mode 100644
index 0000000..29ebbaa
--- /dev/null
+++ b/src/Language/SimpleShell/Parser/Function.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.SimpleShell.Parser.Function
+  ( functionP
+  )
+where
+
+
+import Language.SimpleShell.AST.Expr (Expr)
+import Language.SimpleShell.AST.Function (Function(..))
+import Language.SimpleShell.AST.Name (VarName)
+import Language.SimpleShell.AST.SimpleType (FunSig, Typed)
+import Language.SimpleShell.Parser (Parser, symbol, declareVars)
+import Language.SimpleShell.Parser.Expr (strongTermP)
+import Language.SimpleShell.Parser.Name (funNameP, varNameP, keyword)
+import Language.SimpleShell.Parser.SimpleType (simpleTypeP, forceType)
+
+import Control.Applicative ((<|>))
+import Text.Megaparsec (sepBy)
+
+
+functionP :: Parser (FunSig, Function)
+functionP = do
+  keyword "function"
+  t' <- simpleTypeP
+  fname <- funNameP
+  params <- symbol "(" *> paramP `sepBy` symbol "," <* symbol ")"
+  let (ts, vars) = unzip params
+  body <- forceType t' (bodyP params) <|> fail "Function return type mismatch."
+  return ((t', ts), Function fname vars body)
+
+paramP :: Parser (Typed VarName)
+paramP = (,) <$> simpleTypeP <*> varNameP
+
+bodyP :: [Typed VarName] -> Parser (Typed Expr)
+bodyP params = declareVars params strongTermP
diff --git a/src/Language/SimpleShell/Parser/Name.hs b/src/Language/SimpleShell/Parser/Name.hs
new file mode 100644
index 0000000..635d987
--- /dev/null
+++ b/src/Language/SimpleShell/Parser/Name.hs
@@ -0,0 +1,40 @@
+module Language.SimpleShell.Parser.Name
+  ( varNameP
+  , funNameP
+  , keyword
+  )
+where
+
+
+import Language.SimpleShell.AST.Name (FunName, VarName)
+import Language.SimpleShell.Parser (Parser, lexeme)
+
+import Control.Monad (void)
+import Data.Text (Text, cons)
+import Data.Char (isAlpha, isAlphaNum)
+import Text.Megaparsec (takeWhileP, satisfy, notFollowedBy, try)
+import Text.Megaparsec.Char (string)
+
+
+isNameStartChar :: Char -> Bool
+isNameStartChar c = isAlpha c || c == '_'
+
+isNameChar :: Char -> Bool
+isNameChar c = isAlphaNum c || c == '_'
+
+
+nameP :: Parser Text
+nameP =
+  lexeme $ cons <$> satisfy isNameStartChar <*> takeWhileP Nothing isNameChar
+
+
+keyword :: Text -> Parser ()
+keyword kw =
+  void $ lexeme $ try $ string kw <* notFollowedBy (satisfy isNameChar)
+
+
+varNameP :: Parser VarName
+varNameP = nameP
+
+funNameP :: Parser FunName
+funNameP = nameP
diff --git a/src/Language/SimpleShell/Parser/SimpleType.hs b/src/Language/SimpleShell/Parser/SimpleType.hs
new file mode 100644
index 0000000..b32c99a
--- /dev/null
+++ b/src/Language/SimpleShell/Parser/SimpleType.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.SimpleShell.Parser.SimpleType
+  ( simpleTypeP
+  , forceType
+  )
+where
+
+
+import Language.SimpleShell.AST.SimpleType (SimpleType(..), Typed)
+import Language.SimpleShell.Parser (Parser)
+import Language.SimpleShell.Parser.Name (keyword)
+
+import Control.Applicative ((<|>))
+import Control.Monad (guard)
+
+
+simpleTypeP :: Parser SimpleType
+simpleTypeP
+   =  IntType  <$ keyword "int"
+  <|> StrType  <$ keyword "str"
+  <|> BoolType <$ keyword "bool"
+
+forceType :: SimpleType -> Parser (Typed a) -> Parser a
+forceType t p = do
+  (t', x) <- p
+  guard (t == t') >> return x