aboutsummaryrefslogtreecommitdiff
path: root/src/Language/SimpleShell
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/SimpleShell')
-rw-r--r--src/Language/SimpleShell/Parser.hs66
-rw-r--r--src/Language/SimpleShell/Parser/Expr.hs55
-rw-r--r--src/Language/SimpleShell/Parser/Function.hs24
-rw-r--r--src/Language/SimpleShell/Parser/Name.hs10
-rw-r--r--src/Language/SimpleShell/Parser/SimpleType.hs8
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