{-|
Module: Parser
Description: Parsing utilities.
Author: gatlin@niltag.net

For now all "surface syntax" - eg, text that a human would be expected to type -
is modeled as /s-expressions/, which you can read about in the "Syntax" module.

After text is parsed into s-expressions it is then transformed into whatever
intermediate language representation it needs to be in.
-}

{-# LANGUAGE OverloadedStrings #-}

module Parser
  ( numParser
  , symParser
  , boolParser
  , listParser
  , parens
  , sexprParser
  , parseSexpr
  , IResult(..)
  , Result )
where

import Control.Monad (join)
import Control.Applicative ((<|>), many)

import Control.Monad.Free (Free(..), liftF)
import Data.Text (Text)
import Data.Attoparsec.Text
  ( Parser
  , parse
  , feed
  , Result
  , IResult(..)
  , char
  , digit
  , letter
  , many'
  , many1
  , peekChar
  , satisfy
  , sepBy
  , skipSpace
  , space )

import Data.Scientific (Scientific(..), floatingOrInteger)
import Syntax ( SExpr(..)
              , boolS
              , intS
              , floatS
              , symS
              , listS
              )

-- * The parser

numParser :: Parser (Free SExpr ())
numParser :: Parser (Free SExpr ())
numParser = do
  [Char]
whole_part <- Parser Text Char -> Parser Text [Char]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 Parser Text Char
digit
  Maybe Char
mDot <- Parser (Maybe Char)
peekChar
  case Maybe Char
mDot of
    Just Char
'.' -> do
      Char -> Parser Text Char
char Char
'.'
      [Char]
mantissa <- Parser Text Char -> Parser Text [Char]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 Parser Text Char
digit
      Free SExpr () -> Parser (Free SExpr ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Free SExpr () -> Parser (Free SExpr ()))
-> Free SExpr () -> Parser (Free SExpr ())
forall a b. (a -> b) -> a -> b
$ Double -> Free SExpr ()
floatS ([Char] -> Double
forall a. Read a => [Char] -> a
read ([Char] -> Double) -> [Char] -> Double
forall a b. (a -> b) -> a -> b
$ [Char]
whole_part [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
'.'] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
mantissa)
    Maybe Char
_ -> Free SExpr () -> Parser (Free SExpr ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Free SExpr () -> Parser (Free SExpr ()))
-> Free SExpr () -> Parser (Free SExpr ())
forall a b. (a -> b) -> a -> b
$ Integer -> Free SExpr ()
intS (Integer -> Free SExpr ()) -> Integer -> Free SExpr ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Integer
forall a. Read a => [Char] -> a
read [Char]
whole_part

symchars :: String
symchars :: [Char]
symchars = [Char]
":=<>.!@#%^&*+-/\\_'?"

symchar :: Parser Char
symchar :: Parser Text Char
symchar = (Char -> Bool) -> Parser Text Char
satisfy ((Char -> Bool) -> Parser Text Char)
-> (Char -> Bool) -> Parser Text Char
forall a b. (a -> b) -> a -> b
$ \Char
c -> Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
symchars

sym :: Parser String
sym :: Parser Text [Char]
sym = do
  Char
firstChar <- Parser Text Char
letter Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Char
symchar
  [Char]
otherChars <- Parser Text Char -> Parser Text [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser Text Char -> Parser Text [Char])
-> Parser Text Char -> Parser Text [Char]
forall a b. (a -> b) -> a -> b
$ Parser Text Char
letter Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Char
digit Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Char
symchar
  [Char] -> Parser Text [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Parser Text [Char]) -> [Char] -> Parser Text [Char]
forall a b. (a -> b) -> a -> b
$ Char
firstChar Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
otherChars

symParser :: Parser (Free SExpr ())
symParser :: Parser (Free SExpr ())
symParser = do [Char] -> Free SExpr ()
symS ([Char] -> Free SExpr ())
-> Parser Text [Char] -> Parser (Free SExpr ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text [Char]
sym

boolParser :: Parser (Free SExpr ())
boolParser :: Parser (Free SExpr ())
boolParser = do
  Char -> Parser Text Char
char Char
'#'
  Char
bv <- Char -> Parser Text Char
char Char
't' Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
char Char
'f'
  case Char
bv of
    Char
't' -> Free SExpr () -> Parser (Free SExpr ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Free SExpr () -> Parser (Free SExpr ()))
-> Free SExpr () -> Parser (Free SExpr ())
forall a b. (a -> b) -> a -> b
$ Bool -> Free SExpr ()
boolS Bool
True
    Char
'f' -> Free SExpr () -> Parser (Free SExpr ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Free SExpr () -> Parser (Free SExpr ()))
-> Free SExpr () -> Parser (Free SExpr ())
forall a b. (a -> b) -> a -> b
$ Bool -> Free SExpr ()
boolS Bool
False

listParser :: Parser (Free SExpr ())
listParser :: Parser (Free SExpr ())
listParser = do
  [Free SExpr ()]
els <- Parser (Free SExpr ())
sexprParser Parser (Free SExpr ())
-> Parser Text [Char] -> Parser Text [Free SExpr ()]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Parser Text Char -> Parser Text [Char]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text Char
space
  Free SExpr () -> Parser (Free SExpr ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Free SExpr () -> Parser (Free SExpr ()))
-> Free SExpr () -> Parser (Free SExpr ())
forall a b. (a -> b) -> a -> b
$ [Free SExpr ()] -> Free SExpr ()
forall a. [Free SExpr a] -> Free SExpr a
listS [Free SExpr ()]
els

parens :: Parser a -> Parser a
parens :: forall a. Parser a -> Parser a
parens Parser a
p = do
  Char -> Parser Text Char
char Char
'('
  Parser ()
skipSpace
  a
wrapped_expr <- Parser a
p
  Parser ()
skipSpace
  Char -> Parser Text Char
char Char
')'
  a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
wrapped_expr

sexprParser :: Parser (Free SExpr ())
sexprParser :: Parser (Free SExpr ())
sexprParser = Parser (Free SExpr ())
boolParser Parser (Free SExpr ())
-> Parser (Free SExpr ()) -> Parser (Free SExpr ())
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Free SExpr ())
numParser Parser (Free SExpr ())
-> Parser (Free SExpr ()) -> Parser (Free SExpr ())
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Free SExpr ())
symParser Parser (Free SExpr ())
-> Parser (Free SExpr ()) -> Parser (Free SExpr ())
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>  Parser (Free SExpr ()) -> Parser (Free SExpr ())
forall a. Parser a -> Parser a
parens Parser (Free SExpr ())
listParser

parseSexpr
  :: Maybe (Result (Free SExpr ()))
  -> Text
  -> Result (Free SExpr ())
parseSexpr :: Maybe (Result (Free SExpr ())) -> Text -> Result (Free SExpr ())
parseSexpr Maybe (Result (Free SExpr ()))
Nothing Text
t = Parser (Free SExpr ()) -> Text -> Result (Free SExpr ())
forall a. Parser a -> Text -> Result a
parse Parser (Free SExpr ())
sexprParser Text
t
parseSexpr (Just Result (Free SExpr ())
p) Text
t = Result (Free SExpr ()) -> Text -> Result (Free SExpr ())
forall i r. Monoid i => IResult i r -> i -> IResult i r
feed Result (Free SExpr ())
p Text
t