Split up parser types

To be continued.

5 files changed, 81 insertions, 82 deletions

diff --git a/src/Language/SimpleShell/Parser.hs b/src/Language/SimpleShell/Parser.hs
index be16c9f..32015f7 100644
--- a/src/Language/SimpleShell/Parser.hs
+++ b/src/Language/SimpleShell/Parser.hs
@@ -1,32 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Language.SimpleShell.Parser
-  ( Parser
+  ( MainParser
   , lexeme
   , symbol
   , commentFirstChars
-  , lookupVar
-  , lookupFun
-  , declareVars
-  , initContext
-  , parseTest
   )
 where
 
 
-import Language.SimpleShell.AST.Name (FunName, VarName)
-import Language.SimpleShell.AST.SimpleType (SimpleType, FunSig, Typed)
-
 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, fromList)
-import Data.Text (Text, unpack)
-import Data.Tuple (swap)
+import Data.Text (Text)
 import Data.Void (Void)
-import Text.Megaparsec (Parsec)
-import qualified Text.Megaparsec as MP (parseTest)
+import Text.Megaparsec (MonadParsec, Parsec)
 import Text.Megaparsec.Char (space1)
 import qualified Text.Megaparsec.Char.Lexer as L
   ( lexeme
@@ -37,22 +24,11 @@ import qualified Text.Megaparsec.Char.Lexer as L
   )
 
 
-type Parser = ReaderT Context (Parsec Void Text)
-
-data Context = Context
-  { ctxVars :: Map VarName SimpleType
-  , ctxFuns :: Map FunName FunSig
-  }
-
-initContext :: Context
-initContext = Context
-  { ctxVars = Map.empty
-  , ctxFuns = Map.empty
-  }
+type MainParser = Parsec Void Text
 
 
 -- Must be kept in sync with 'commentFirstChars'.
-sc :: Parser ()
+sc :: (MonadParsec e Text m) => m ()
 sc = L.space
   space1
   (L.skipLineComment "//")
@@ -62,34 +38,8 @@ sc = L.space
 commentFirstChars :: [Char]
 commentFirstChars = "/"
 
-lexeme :: Parser a -> Parser a
+lexeme :: (MonadParsec e Text m) => m a -> m a
 lexeme = L.lexeme sc
 
-symbol :: Text -> Parser ()
+symbol :: (MonadParsec e Text m) => Text -> m ()
 symbol = void . L.symbol sc
-
-
-lookupVar :: VarName -> Parser SimpleType
-lookupVar varname = do
-  mt <- Map.lookup varname . ctxVars <$> ask
-  case mt of
-    Just t  -> return t
-    Nothing -> fail $ "Undeclared variable $" ++ unpack varname
-
-lookupFun :: FunName -> Parser FunSig
-lookupFun fname = do
-  msig <- Map.lookup fname . ctxFuns <$> ask
-  case msig of
-    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 06d6624..db8a493 100644
--- a/src/Language/SimpleShell/Parser/Expr.hs
+++ b/src/Language/SimpleShell/Parser/Expr.hs
@@ -2,22 +2,23 @@
 {-# LANGUAGE TupleSections #-}
 
 module Language.SimpleShell.Parser.Expr
-  ( exprP
+  ( ExprParser
+  , runExprParser
+  , exprP
   , strongTermP
-  , strongTermP_  -- TODO: Unused.
+  , strongTermP_
   )
 where
 
 
 import Language.SimpleShell.AST.Expr (Expr(..), TypedExpr)
-import Language.SimpleShell.AST.SimpleType (SimpleType(..))
+import Language.SimpleShell.AST.Name (FunName, VarName)
+import Language.SimpleShell.AST.SimpleType (SimpleType(..), Typed, FunSig)
 import Language.SimpleShell.Parser
-  ( Parser
+  ( MainParser
   , lexeme
   , symbol
   , commentFirstChars
-  , lookupVar
-  , lookupFun
   )
 import Language.SimpleShell.Parser.Name (nameP, keyword)
 import Language.SimpleShell.Parser.SimpleType (forceType)
@@ -29,14 +30,54 @@ import Control.Monad.Combinators.FailExpr
 
 import Control.Applicative ((<|>))
 import Control.Monad (void)
+import Control.Monad.Reader (ask, ReaderT, runReaderT)
 import Control.Monad.Combinators (manyTill)
 import Data.Foldable (asum)
-import Data.Text (Text)
+import Data.List (nub)
+import Data.Map (Map)
+import qualified Data.Map as Map (empty, lookup, fromList)
+import Data.Text (Text, unpack)
+import Data.Tuple (swap)
 import Text.Megaparsec (takeWhile1P, oneOf, many)
 import Text.Megaparsec.Char (char)
 import qualified Text.Megaparsec.Char.Lexer as L (charLiteral, decimal)
 
 
+type ExprParser = ReaderT ExprContext MainParser
+type Parser = ExprParser
+
+
+data ExprContext = ExprContext
+  { ctxVars :: Map VarName SimpleType
+  , ctxFuns :: Map FunName FunSig
+  }
+
+
+runExprParser :: [Typed VarName] -> ExprParser a -> MainParser a
+runExprParser decls p =
+  if length (nub names) == length names   -- TODO: inefficient
+  then runReaderT p (ExprContext vars Map.empty)
+  else fail "Duplicate variable name."
+  where
+    names = map snd decls
+    vars = Map.fromList $ map swap decls
+
+
+lookupVar :: VarName -> Parser SimpleType
+lookupVar varname = do
+  mt <- Map.lookup varname . ctxVars <$> ask
+  case mt of
+    Just t  -> return t
+    Nothing -> fail $ "Undeclared variable $" ++ unpack varname
+
+lookupFun :: FunName -> Parser FunSig
+lookupFun fname = do
+  msig <- Map.lookup fname . ctxFuns <$> ask
+  case msig of
+    Just sig -> return sig
+    Nothing  -> fail $ "Undefined function " ++ unpack fname
+
+
 exprP :: Parser TypedExpr
 exprP
    =  makeExprParser weakTermP binaryOperatorTable
diff --git a/src/Language/SimpleShell/Parser/Function.hs b/src/Language/SimpleShell/Parser/Function.hs
index f7a63f8..667a601 100644
--- a/src/Language/SimpleShell/Parser/Function.hs
+++ b/src/Language/SimpleShell/Parser/Function.hs
@@ -11,8 +11,12 @@ import Language.SimpleShell.AST.Expr (Expr)
 import Language.SimpleShell.AST.Function (Function(..))
 import Language.SimpleShell.AST.Name (FunName, VarName)
 import Language.SimpleShell.AST.SimpleType (SimpleType, FunSig, Typed)
-import Language.SimpleShell.Parser (Parser, symbol, declareVars)
-import Language.SimpleShell.Parser.Expr (strongTermP, strongTermP_)
+import Language.SimpleShell.Parser (MainParser, symbol)
+import Language.SimpleShell.Parser.Expr
+  ( runExprParser
+  , strongTermP
+  , strongTermP_
+  )
 import Language.SimpleShell.Parser.Name (nameP, keyword)
 import Language.SimpleShell.Parser.SimpleType (simpleTypeP, forceType)
 
@@ -20,7 +24,7 @@ import Control.Applicative ((<|>))
 import Text.Megaparsec (sepBy)
 
 
-functionPrefixP :: Parser (SimpleType, FunName, [Typed VarName])
+functionPrefixP :: MainParser (SimpleType, FunName, [Typed VarName])
 functionPrefixP = do
   keyword "function"
   t' <- simpleTypeP
@@ -29,7 +33,7 @@ functionPrefixP = do
   symbol "="
   return (t', fname, params)
 
-functionP :: Parser Function
+functionP :: MainParser Function
 functionP = do
   (t', fname, params) <- functionPrefixP
   let vars = map snd params
@@ -37,7 +41,7 @@ functionP = do
   return $ Function fname vars body
 
 -- | First-pass function parser.
-functionP0 :: Parser (FunName, FunSig)
+functionP0 :: MainParser (FunName, FunSig)
 functionP0 = do
   (t', fname, params) <- functionPrefixP
   let ts = map fst params
@@ -45,11 +49,11 @@ functionP0 = do
   return (fname, (t', ts))
 
 
-paramP :: Parser (Typed VarName)
+paramP :: MainParser (Typed VarName)
 paramP = (,) <$> simpleTypeP <*> nameP
 
-bodyP :: [Typed VarName] -> Parser (Typed Expr)
-bodyP params = declareVars params strongTermP
+bodyP :: [Typed VarName] -> MainParser (Typed Expr)
+bodyP params = runExprParser params strongTermP
 
-bodyP_ :: Parser ()
-bodyP_ = strongTermP_
+bodyP_ :: MainParser ()
+bodyP_ = runExprParser [] strongTermP_
diff --git a/src/Language/SimpleShell/Parser/Name.hs b/src/Language/SimpleShell/Parser/Name.hs
index 14f4d2e..2691a36 100644
--- a/src/Language/SimpleShell/Parser/Name.hs
+++ b/src/Language/SimpleShell/Parser/Name.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Language.SimpleShell.Parser.Name
   ( nameP
   , keyword
@@ -5,12 +7,12 @@ module Language.SimpleShell.Parser.Name
 where
 
 
-import Language.SimpleShell.Parser (Parser, lexeme)
+import Language.SimpleShell.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 (MonadParsec, takeWhileP, satisfy, notFollowedBy, try)
 import Text.Megaparsec.Char (string)
 
 
@@ -21,11 +23,11 @@ isNameChar :: Char -> Bool
 isNameChar c = isAlphaNum c || c == '_'
 
 
-nameP :: Parser Text
+nameP :: (MonadParsec e Text m) => m Text
 nameP =
   lexeme $ cons <$> satisfy isNameStartChar <*> takeWhileP Nothing isNameChar
 
 
-keyword :: Text -> Parser ()
+keyword :: (MonadParsec e Text m) => Text -> m ()
 keyword kw =
   void $ lexeme $ try $ string kw <* notFollowedBy (satisfy isNameChar)
diff --git a/src/Language/SimpleShell/Parser/SimpleType.hs b/src/Language/SimpleShell/Parser/SimpleType.hs
index b32c99a..df74085 100644
--- a/src/Language/SimpleShell/Parser/SimpleType.hs
+++ b/src/Language/SimpleShell/Parser/SimpleType.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Language.SimpleShell.Parser.SimpleType
   ( simpleTypeP
@@ -8,20 +9,21 @@ 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)
+import Data.Text (Text)
+import Text.Megaparsec (MonadParsec)
 
 
-simpleTypeP :: Parser SimpleType
+simpleTypeP :: (MonadParsec e Text m) => m SimpleType
 simpleTypeP
    =  IntType  <$ keyword "int"
   <|> StrType  <$ keyword "str"
   <|> BoolType <$ keyword "bool"
 
-forceType :: SimpleType -> Parser (Typed a) -> Parser a
+forceType :: (MonadParsec e Text m) => SimpleType -> m (Typed a) -> m a
 forceType t p = do
   (t', x) <- p
   guard (t == t') >> return x