initHEADmaster

2 files changed, 281 insertions, 0 deletions

diff --git a/src/Hint/Lexer.hs b/src/Hint/Lexer.hs
new file mode 100644
index 0000000..7aad9a4
--- /dev/null
+++ b/src/Hint/Lexer.hs
@@ -0,0 +1,167 @@
+module Hint.Lexer where
+
+import           Control.Applicative (Alternative (..), asum)
+import           Data.Char           (isAlpha, isDigit, isSpace)
+
+type Input = String
+
+data SourcePos = SourcePos
+  { line   :: Int
+  , column :: Int}
+  deriving (Show, Eq)
+
+data LexerState = LexerState
+  { sourcepos :: SourcePos
+  , input     :: String
+  } deriving (Show, Eq)
+
+data LexError
+  = UnexpectedEof
+  | IllegalChar Char
+  | UnexpectedChar SourcePos [Char]
+  | NoMatch
+  -- ^ Used for Alternative implementation
+  deriving (Show, Eq)
+
+data TokenKind
+  = TIdent String
+  | TInt Int
+  | TString String
+  | TOpenParen
+  | TCloseParen
+  | TOpenCurly
+  | TCloseCurly
+  | TOpenSquare
+  | TCloseSquare
+  | TComma
+  | TEof
+  | TPlus
+  | TMinus
+  | TEquals
+  | KeywordLet
+  | KeywordIn
+  deriving (Show, Eq)
+
+data Span = Span SourcePos SourcePos
+  deriving (Show, Eq)
+
+data Token = Token TokenKind Span
+  deriving (Show, Eq)
+
+getKind :: Token -> TokenKind
+getKind (Token kind _) = kind
+
+newtype Lexer a = Lexer
+  { unLexer :: LexerState -> Either LexError (a, LexerState) }
+
+instance Functor Lexer where
+  fmap f (Lexer lf) = Lexer $ \s -> do
+    (c, s') <- lf s
+    pure (f c, s')
+
+instance Applicative Lexer where
+  pure a = Lexer $ \s -> Right (a, s)
+
+  Lexer lf <*> Lexer lx = Lexer $ \s -> do
+    (f, s') <- lf s
+    (x, s'') <- lx s'
+    pure (f x, s'')
+
+instance Alternative Lexer where
+  empty = Lexer $ \_ -> Left NoMatch
+
+  Lexer p <|> Lexer q = Lexer $ \s ->
+    case p s of
+      Right n -> Right n
+      Left _  -> q s
+
+instance Monad Lexer where
+  return = pure
+
+  Lexer lx >>= f = Lexer $ \s -> do
+    (x, s') <- lx s
+    unLexer (f x) s'
+
+-- | Toplevel interface to lexer
+runLexer :: Lexer a -> Input -> Either LexError (a, LexerState)
+runLexer lx = unLexer lx . LexerState (SourcePos 1 1)
+
+runProd :: Input -> Either LexError [Token]
+runProd = fmap fst . runLexer gram
+
+-- | Lifts `TokenKind` lexers into Token by tracking span information behind the
+-- scenes.
+token :: Lexer TokenKind -> Lexer Token
+token (Lexer p) = Lexer $ \st -> do
+  let start = sourcepos st
+  (kind, st') <- p st
+  let end = sourcepos st'
+
+  pure $ (Token kind (Span start end), st')
+
+lexChar :: Lexer Char
+lexChar = Lexer $ \st ->
+  case input st of
+    []            -> Left UnexpectedEof
+    ('\n' : rest) -> Right ('\n', st {sourcepos = withNewLine st, input = rest})
+    (c : rest)    -> Right (c, st { sourcepos = withNewCol st, input = rest })
+  where
+    withNewLine, withNewCol :: LexerState -> SourcePos
+
+    withNewLine = liftA2 SourcePos ((+ 1) . line . sourcepos) (pure 1)
+    withNewCol = liftA2 SourcePos (line . sourcepos) ((+ 1) . column . sourcepos)
+
+-- lexEof :: Lexer TokenKind
+-- lexEof = Lexer $ \st ->
+--   case input st of
+--     [] -> pure (TEof, st)
+--     _ -> Left $ UnexpectedChar $ sourcepos st
+
+sat :: (Char -> Bool) -> Lexer Char
+sat p = do
+  c <- lexChar
+  if p c then pure c else Lexer $ \s -> Left (UnexpectedChar (sourcepos s) [c])
+
+string :: String -> Lexer String
+string = traverse (\c -> sat (== c))
+
+lexKeyword :: Lexer TokenKind
+lexKeyword = asum $
+  [ KeywordLet <$ string "let"
+  , KeywordIn <$ string "in"
+  ]
+
+lexIdent :: Lexer TokenKind
+lexIdent = TIdent <$> liftA2 (:) (sat isAlpha) (many rest)
+  where
+    -- characters allowed ofter the initial a-z
+    rest = asum $ sat <$> [isAlpha, isDigit, (== '\'')]
+
+lexNumber :: Lexer TokenKind
+lexNumber = TInt . read <$> some (sat isDigit)
+
+lexString :: Lexer TokenKind
+lexString = TString <$> (sat (== '\"') *> many (sat (/= '\"')) <* sat (== '\"'))
+
+spaces :: Lexer [()]
+spaces = many $ () <$ sat isSpace
+
+gram :: Lexer [Token]
+gram = some $ spaces *> asum lexers
+  where
+    lexers = map token $
+      [ TOpenParen <$ sat (== '(')
+      , TCloseParen <$ sat (== ')')
+      , TOpenCurly <$ sat (== '{')
+      , TCloseCurly <$ sat (== '}')
+      , TOpenSquare <$ sat (== '[')
+      , TCloseSquare <$ sat (== ']')
+      , TComma <$ sat (== ',')
+      , TPlus <$ sat (== '+')
+      , TMinus <$ sat (== '-')
+      , TEquals <$ sat (== '=')
+      , lexKeyword
+      , lexIdent
+      , lexNumber
+      , lexString
+      ]
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 ""]