Nandlang.hs

{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
module Parser.Nandlang where

import Data.Bool
import Data.Char (isSpace, isAlpha, isAlphaNum)
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Ord (Ord(..))
import Data.String (String)
import qualified Data.Set as Set
import qualified Data.Text as Text

import Symantic.Univariant.Trans
import qualified Symantic.Parser as P
import qualified Symantic.Parser.Haskell as H

type Parser a = P.Parser Text.Text a

nandIdentStart :: Char -> Bool
nandIdentStart c = isAlpha c || c == '_'

nandIdentLetter :: Char -> Bool
nandIdentLetter c = isAlphaNum c || c == '_'

nandUnreservedName :: String -> Bool
nandUnreservedName = \s -> not (Set.member s keys)
  where
  keys = Set.fromList ["if", "else", "while", "function", "var"]

nandStringLetter :: Char -> Bool
nandStringLetter c = (c /= '"') && (c /= '\\') && (c > '\026')

nandlang :: forall repr.
  P.Grammar Char repr =>
  repr ()
nandlang = whitespace P.*> P.skipMany funcdef P.<* P.eof
  where
  index :: repr ()
  index = brackets nat
  identifier :: repr ()
  identifier = P.try (identStart P.*> P.skipMany identLetter) P.*> whitespace
  variable :: repr ()
  variable = identifier P.*> P.optional index

  literal :: repr ()
  literal = bit P.<|> charLit

  keyword :: String -> repr ()
  keyword s = P.try (P.string s P.*> notIdentLetter) P.*> whitespace

  identStart = P.satisfy
    [P.ErrorItemLabel "identStart"]
    (trans (H.ValueCode nandIdentStart [||nandIdentStart||]))
  identLetter = P.satisfy
    [P.ErrorItemLabel "identLetter"]
    (trans (H.ValueCode nandIdentLetter [||nandIdentLetter||]))
  notIdentLetter = P.negLook identLetter

  bit :: repr ()
  bit = (P.char '0' P.<|> P.char '1') P.*> whitespace

  nat :: repr ()
  nat = decimal

  charLit :: repr ()
  charLit = P.between (P.char '\'') (symbol '\'') charChar

  charChar :: repr ()
  charChar = P.void (P.satisfy
    [P.ErrorItemLabel "Char"]
    (trans (H.ValueCode nandStringLetter [||nandStringLetter||]))) P.<|> esc

  esc :: repr ()
  esc = P.char '\\' P.*> P.void (P.oneOf "0tnvfr")

  expr :: repr ()
  expr = nandexpr P.*> P.skipMany (symbol '!' P.*> nandexpr)

  nandexpr :: repr ()
  nandexpr = literal P.<|> funccallOrVar

  funccallOrVar :: repr ()
  funccallOrVar = identifier P.*> P.optional (parens exprlist P.<|> index)

  exprlist = commaSep expr
  exprlist1 = commaSep1 expr
  varlist = commaSep variable
  varlist1 = commaSep1 variable

  funcparam = varlist P.*> P.optional (symbol ':' P.*> varlist)
  varstmt = P.optional (keyword "var") P.*> varlist1 P.*> symbol '=' P.*> exprlist1 P.<* semi
  ifstmt = keyword "if" P.*> expr P.*> block P.*> P.optional (keyword "else" P.*> block)
  whilestmt = keyword "while" P.*> expr P.*> block
  statement = ifstmt P.<|> whilestmt P.<|> P.try varstmt P.<|> expr P.<* semi
  block = braces (P.skipMany statement)
  funcdef = keyword "function" P.*> identifier P.*> parens funcparam P.*> block

  decimal :: repr ()
  decimal = number (P.oneOf ['0'..'9'])
  -- hexadecimal = P.oneOf "xX" P.*> number (P.oneOf (['a'..'f'] <> ['A'..'F'] <> ['0'..'9']))
  -- octal = P.oneOf "oO" P.*> number (P.oneOf ['0'..'7'])
  number :: repr a -> repr ()
  number digit = P.skipSome digit

  symbol :: Char -> repr Char
  symbol c = P.char c P.<* whitespace
  parens :: repr a -> repr a
  parens = P.between (symbol '(') (symbol ')')
  brackets :: repr a -> repr a
  brackets = P.between (symbol '[') (symbol ']')
  braces :: repr a -> repr a
  braces = P.between (symbol '{') (symbol '}')
  semi :: repr Char
  semi = symbol ';'
  comma :: repr Char
  comma = symbol ','
  commaSep :: repr a -> repr ()
  commaSep p = P.optional (commaSep1 p)
  commaSep1 :: repr a -> repr ()
  commaSep1 p = p P.*> P.skipMany (comma P.*> p)

  space :: repr ()
  space = P.void (P.satisfy
    [P.ErrorItemLabel "space"]
    (trans (H.ValueCode isSpace [||isSpace||])))
  whitespace :: repr ()
  whitespace = P.skipMany (spaces P.<|> oneLineComment)
  spaces :: repr ()
  spaces = P.skipSome space
  oneLineComment :: repr ()
  oneLineComment = P.void (P.string "//" P.*> P.skipMany (P.satisfy
    [P.ErrorItemLabel "oneLineComment"]
    (trans (H.ValueCode (/= '\n') [||(/= '\n')||]))))