baseline parsing/evalHEADmaster

4 files changed, 112 insertions, 67 deletions

diff --git a/src/Hint/Data.hs b/src/Hint/Data.hs
new file mode 100644
index 0000000..a5faa44
--- /dev/null
+++ b/src/Hint/Data.hs
@@ -0,0 +1,25 @@
+module Hint.Data where
+
+import Data.Text (Text)
+import Data.String
+import qualified Data.Text as T
+
+newtype Identifier = Identifier Text
+  deriving (Show, Ord, Eq)
+
+instance IsString Identifier where
+  fromString = Identifier . T.pack
+
+data Literal
+  = Int Int
+  | Float Double
+  | Boolean Bool
+  | String Text
+  deriving (Show, Eq)
+
+data Expr
+  = Literal Literal
+  | If Expr Expr Expr
+  | Bind Identifier Expr Expr
+  | Ident Identifier
+  deriving (Show, Eq)
diff --git a/src/Hint/Eval.hs b/src/Hint/Eval.hs
index 48f7b46..36628dc 100644
--- a/src/Hint/Eval.hs
+++ b/src/Hint/Eval.hs
@@ -2,31 +2,34 @@ module Hint.Eval where
 
 import           Control.Applicative ((<|>))
 import qualified Data.Map            as M
-import           Hint.Parser         (Value (..))
+import           Data.Maybe          (fromJust)
+import           Hint.Data
 
-type Ident = String
-type Env = M.Map Ident Value
+type Env = M.Map Identifier Expr
 
 data Scope = Scope
   { env   :: [Env] }
   deriving (Show, Eq)
 
-defaultEnv :: Env
-defaultEnv = M.fromList [("pi", VInt 3), ("version", VString "0.1")]
-
 basic :: Scope
-basic = Scope (pure defaultEnv)
-
-next :: Env
-next = M.fromList [("ident", VInt 12), ("pi", VInt 4)]
+basic = Scope mempty
 
-enter :: Scope -> Env -> Scope
-enter (Scope es) e = Scope (e : es)
+enter :: Env -> Scope -> Scope
+enter e (Scope es) = Scope (e : es)
 
 leave :: Scope -> Scope
 leave (Scope [] )      = error "bad"
 leave (Scope (_ : es)) = Scope es
 
-scopeLookup :: Ident -> Scope -> Maybe Value
+scopeLookup :: Identifier -> Scope -> Maybe Expr
 scopeLookup _ (Scope [])       = Nothing
 scopeLookup i (Scope (e : es)) = M.lookup i e <|> scopeLookup i (Scope es)
+
+eval :: Scope -> Expr -> Maybe Expr
+eval _ (Literal l) = Literal <$> pure l
+eval s (Ident i) = scopeLookup i s
+eval scope (Bind name val rest) =
+  eval (enter (M.fromList [(name, fromJust $ eval scope val)]) scope) rest
+eval s (If cond a b) = do
+  Literal (Boolean c) <- eval s cond
+  if c then eval s a else eval s b
diff --git a/src/Hint/Lexer.hs b/src/Hint/Lexer.hs
index 7aad9a4..19d1266 100644
--- a/src/Hint/Lexer.hs
+++ b/src/Hint/Lexer.hs
@@ -40,6 +40,11 @@ data TokenKind
   | TEquals
   | KeywordLet
   | KeywordIn
+  | KeywordTrue
+  | KeywordFalse
+  | KeywordIf
+  | KeywordThen
+  | KeywordElse
   deriving (Show, Eq)
 
 data Span = Span SourcePos SourcePos
@@ -129,6 +134,11 @@ lexKeyword :: Lexer TokenKind
 lexKeyword = asum $
   [ KeywordLet <$ string "let"
   , KeywordIn <$ string "in"
+  , KeywordTrue <$ string "true"
+  , KeywordFalse <$ string "false"
+  , KeywordIf <$ string "if"
+  , KeywordThen <$ string "then"
+  , KeywordElse <$ string "else"
   ]
 
 lexIdent :: Lexer TokenKind
diff --git a/src/Hint/Parser.hs b/src/Hint/Parser.hs
index 28301e5..c5d23a2 100644
--- a/src/Hint/Parser.hs
+++ b/src/Hint/Parser.hs
@@ -1,7 +1,10 @@
 module Hint.Parser where
 
-import           Control.Applicative (Alternative (..), many)
+import           Control.Applicative (Alternative (..))
+import           Control.Monad       (void)
 import           Data.Either         (fromRight)
+import qualified Data.Text           as T
+import           Hint.Data
 import           Hint.Lexer          (Input, Token (..), TokenKind (..),
                                       runProd)
 
@@ -10,17 +13,9 @@ data ParseError
   | 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
+data BinOp
+  = Add
+  | Mult
   deriving (Show, Eq)
 
 newtype Parser a = Parser
@@ -56,6 +51,32 @@ instance Alternative Parser where
 runParser :: Parser a -> Input -> Either ParseError (a, [Token])
 runParser p = unParser p . fromRight [] . runProd
 
+token :: TokenKind -> Parser Token
+token t = sat (== t)
+
+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]
+
+pStr :: Parser Literal
+pStr = String . T.pack <$> Parser parseString
+  where
+    parseString (Token (TString s) _ : ts) = pure (s, ts)
+    parseString _                          = Left NoParse
+
+pBool :: Parser Literal
+pBool = (Boolean False <$ sat (== KeywordFalse)) <|> (Boolean True <$ sat (== KeywordTrue))
+
+pNumeric :: Parser Literal
+pNumeric = Int <$> Parser p
+  where
+    p (Token (TInt i) _ : ts) = pure (i, ts)
+    p _                       = Left NoParse
+
 parseWord :: String -> Parser Token
 parseWord name = Parser parse
   where
@@ -64,51 +85,37 @@ parseWord name = Parser parse
       | name == n = Right (t, ts)
     parse _  = Left NoParse
 
-parseValue :: Parser Expr
-parseValue = EValue <$> Parser parse
+parseLiteral :: Parser Expr
+parseLiteral = Literal <$> (pStr <|> pBool <|> pNumeric)
+
+parseIdentifier :: Parser Identifier
+parseIdentifier = Parser p
   where
-    parse ((Token (TInt n) _) : ts)    = pure (VInt n, ts)
-    parse ((Token (TString s) _) : ts) = pure (VString s, ts)
-    parse _                            = Left $ UnexpectedToken []
+    p (Token (TIdent s) _ : ts) = pure (Identifier $ T.pack s, ts)
+    p _                         = Left NoParse
 
 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)
+parseBinding = do
+  void $ token KeywordLet
+  name <- parseIdentifier
+  void $ token TEquals
+  value <- expr
+  void $ token KeywordIn
+  body <- expr
+  pure $ Bind name value body
 
-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
+parseIf :: Parser Expr
+parseIf = do
+  void $ token KeywordIf
+  cond <- expr
+  void $ token KeywordThen
+  a <- expr
+  void $ token KeywordElse
+  b <- expr
+  pure $ If cond a b
 
 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 ""]
+expr = parseLiteral
+  <|> parseIf
+  <|> parseBinding
+  <|> Ident <$> parseIdentifier