AST.hs

module AST where

import Data.Fix

type AST name = Fix (AST_ name)

data AST_ name self
  = Var name
  | IfMatch (Match name self)
  | App self self
  | Let [Decl name self] self
  | Constant (Constant name self)

data Constant name ast
  = Number Double
  | String String
  | Lambda (Function name ast)
  | Object [Decl name ast]

data Decl name ast
  = Ctor name [name]
  | Val (Function name ast)
  | Capture name

data Function name ast = Function
  { fName :: name
  , fBody :: ast
  }

data Match name ast = Match
  { mCtor   :: name
  , mSubj   :: ast
  , mFields :: [name]
  , yes     :: ast
  , no      :: ast
  }

SExpr.hs

module SExpr where

import Control.Applicative (some)

import Data.List (intercalate)

import Text.ParserCombinators.Parsec hiding (token)

data SExpr atom
  = Atom atom
  | List [SExpr atom]
  deriving Show

sexprs :: Parser atom -> Parser [SExpr atom]
sexprs atom = do
  spaces
  sexpr atom `sepBy` spaces

sexpr :: Parser atom -> Parser (SExpr atom)
sexpr atom = list atom <|> single atom

single :: Parser atom -> Parser (SExpr atom)
single atom = do
  res <- atom
  return (Atom res)

list :: Parser atom -> Parser (SExpr atom)
list atom = do
  token "(" <?> "opening paren '('"
  res <- sexprs atom
  token ")" <?> "closing paren ')'"
  return (List res)

token :: String -> Parser ()
token s = do
  try $ string s
  spaces

stringLiteral :: Parser String
stringLiteral = do
  blocks <- some block
  return $ intercalate "'" blocks
 <?> "string literal"
  where
    block = do
      char '\''
      content <- anyChar `manyTill` char '\''
      return content

numberLiteral :: Parser Double
numberLiteral = try (do
  sign   <- optionMaybe $ string "-" <|> string "+"
  before <- some digit <?> "digits"
  after  <- optionMaybe $ pure (<>) <*> string "." <*> some digit
  let text = z sign <> before <> z after
  return $ read text)
 <?> "number literal"
  where
    z = maybe mempty id

orP :: Parser a -> Parser b -> Parser (Either a b)
orP l r = Left <$> l <|> Right <$> r

data ParsedName name
  = PlainName name
  | Reserved  name

name :: Parser String
name = try $ do
  h <- noneOf $ "01234567890()\'"
  t <- anyChar `manyTill` (space <|> oneOf "\'()")
  return (h : t)