initHEADmaster

1 files changed, 114 insertions, 0 deletions

diff --git a/src/Hint/Parser.hs b/src/Hint/Parser.hs
new file mode 100644
index 0000000..28301e5
--- /dev/null
+++ b/src/Hint/Parser.hs
@@ -0,0 +1,114 @@
+module Hint.Parser where
+
+import           Control.Applicative (Alternative (..), many)
+import           Data.Either         (fromRight)
+import           Hint.Lexer          (Input, Token (..), TokenKind (..),
+                                      runProd)
+
+data ParseError
+  = UnexpectedToken [TokenKind]
+  | NoParse
+  deriving (Show, Eq)
+
+data Value
+  = VInt Int
+  | VString String
+  | VList Value
+  deriving (Show, Eq)
+
+data Expr
+  = EVar String
+  | EValue Value
+  | EBinding String Expr
+  | EFunc String [String] Expr
+  deriving (Show, Eq)
+
+newtype Parser a = Parser
+  { unParser :: [Token] -> Either ParseError (a, [Token]) }
+
+instance Functor Parser where
+  fmap f (Parser p) = Parser $ \ts -> do
+    (a, rest) <- p ts
+    pure (f a, rest)
+
+instance Applicative Parser where
+  pure a = Parser $ \ts -> Right (a, ts)
+
+  (<*>) (Parser pf) (Parser px) = Parser $ \ts -> do
+    (f, ts') <- pf ts
+    (x, ts'') <- px ts'
+    pure (f x, ts'')
+
+instance Monad Parser where
+  return = pure
+
+  (>>=) (Parser p) f = Parser $ \ts -> do
+    (x, ts') <- p ts
+    unParser (f x) ts'
+
+instance Alternative Parser where
+  empty = Parser $ const $ Left NoParse
+  (<|>) (Parser p) (Parser q) = Parser $ \ts ->
+    case p ts of
+      Right a -> Right a
+      Left _  -> q ts
+
+runParser :: Parser a -> Input -> Either ParseError (a, [Token])
+runParser p = unParser p . fromRight [] . runProd
+
+parseWord :: String -> Parser Token
+parseWord name = Parser parse
+  where
+    parse [] = Left NoParse
+    parse (t@(Token (TIdent n) _) : ts)
+      | name == n = Right (t, ts)
+    parse _  = Left NoParse
+
+parseValue :: Parser Expr
+parseValue = EValue <$> Parser parse
+  where
+    parse ((Token (TInt n) _) : ts)    = pure (VInt n, ts)
+    parse ((Token (TString s) _) : ts) = pure (VString s, ts)
+    parse _                            = Left $ UnexpectedToken []
+
+parseBinding :: Parser Expr
+parseBinding = EBinding
+  <$> phrase
+  <*> expr <* sat (== KeywordIn)
+  where
+    phrase = sat (== KeywordLet) *> ident <* sat (== TEquals)
+    ident = Parser $ \((Token (TIdent name) _) : ts) -> pure (name, ts)
+
+parseFunc :: Parser Expr
+parseFunc = EFunc
+  <$> ident
+  <*> many ident <* sat (== TEquals)
+  <*> parseValue
+  where
+    parse ((Token (TIdent name) _) : ts) = pure (name, ts)
+    parse _                              = Left NoParse
+    ident = Parser parse
+
+expr :: Parser Expr
+expr = parseValue <|> parseBinding
+
+sat :: (TokenKind -> Bool) -> Parser Token
+sat p = Parser parse
+  where
+    parse [] = Left $ UnexpectedToken [TEof]
+    parse (t@(Token kind _) : ts)
+      | p kind = Right (t, ts)
+      | otherwise = Left $ UnexpectedToken [kind]
+
+-- parseBind :: Parser Expr
+-- parseBind = EBinding <$> name <*> result
+--   where
+--     name = Parser $ \(t : ts) ->
+--       case t of
+--         (Token (TIdent s) _) -> pure (s, ts)
+--         _                    -> Left $ UnexpectedToken $ [TIdent ""]
+
+--     result = Parser $ \(t : ts) ->
+--       case t of
+--         (Token (TInt n) _) -> pure (ELit n, ts)
+--         _                  -> Left $ UnexpectedToken $ [TIdent ""]