1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
{-# LANGUAGE OverloadedStrings #-}
module Language.SimpleShell.Parser
( Parser
, 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.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
)
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
}
-- Must be kept in sync with 'commentFirstChars'.
sc :: Parser ()
sc = L.space
space1
(L.skipLineComment "//")
(L.skipBlockComment "/*" "*/")
-- | List of all characters that may start a comment.
commentFirstChars :: [Char]
commentFirstChars = "/"
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc
symbol :: Text -> Parser ()
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)
|
