test/Parser/Nandlang.hs

   1 {-# LANGUAGE DeriveLift #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE Rank2Types #-}
   4 {-# LANGUAGE StandaloneDeriving #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# LANGUAGE UnboxedTuples #-}
   7 module Parser.Nandlang where
   8
   9 import Data.Bool
  10 import Data.Char (isSpace, isAlpha, isAlphaNum)
  11 import Data.Char (Char)
  12 import Data.Eq (Eq(..))
  13 import Data.Ord (Ord(..))
  14 import Data.String (String)
  15 import qualified Data.Set as Set
  16 import qualified Data.Text as Text
  17
  18 import Symantic.Univariant.Trans
  19 import qualified Symantic.Parser as P
  20 import qualified Symantic.Parser.Haskell as H
  21
  22 type Parser a = P.Parser Text.Text a
  23
  24 nandIdentStart :: Char -> Bool
  25 nandIdentStart c = isAlpha c || c == '_'
  26
  27 nandIdentLetter :: Char -> Bool
  28 nandIdentLetter c = isAlphaNum c || c == '_'
  29
  30 nandUnreservedName :: String -> Bool
  31 nandUnreservedName = \s -> not (Set.member s keys)
  32   where
  33   keys = Set.fromList ["if", "else", "while", "function", "var"]
  34
  35 nandStringLetter :: Char -> Bool
  36 nandStringLetter c = (c /= '"') && (c /= '\\') && (c > '\026')
  37
  38 nandlang :: forall repr.
  39   P.Grammar Char repr =>
  40   repr ()
  41 nandlang = whitespace P.*> P.skipMany funcdef P.<* P.eof
  42   where
  43   index :: repr ()
  44   index = brackets nat
  45   identifier :: repr ()
  46   identifier = P.try (identStart P.*> P.skipMany identLetter) P.*> whitespace
  47   variable :: repr ()
  48   variable = identifier P.*> P.optional index
  49
  50   literal :: repr ()
  51   literal = bit P.<|> charLit
  52
  53   keyword :: String -> repr ()
  54   keyword s = P.try (P.string s P.*> notIdentLetter) P.*> whitespace
  55
  56   identStart = P.satisfy
  57     [P.ErrorItemLabel "identStart"]
  58     (trans (H.ValueCode nandIdentStart [||nandIdentStart||]))
  59   identLetter = P.satisfy
  60     [P.ErrorItemLabel "identLetter"]
  61     (trans (H.ValueCode nandIdentLetter [||nandIdentLetter||]))
  62   notIdentLetter = P.negLook identLetter
  63
  64   bit :: repr ()
  65   bit = (P.char '0' P.<|> P.char '1') P.*> whitespace
  66
  67   nat :: repr ()
  68   nat = decimal
  69
  70   charLit :: repr ()
  71   charLit = P.between (P.char '\'') (symbol '\'') charChar
  72
  73   charChar :: repr ()
  74   charChar = P.void (P.satisfy
  75     [P.ErrorItemLabel "Char"]
  76     (trans (H.ValueCode nandStringLetter [||nandStringLetter||]))) P.<|> esc
  77
  78   esc :: repr ()
  79   esc = P.char '\\' P.*> P.void (P.oneOf "0tnvfr")
  80
  81   expr :: repr ()
  82   expr = nandexpr P.*> P.skipMany (symbol '!' P.*> nandexpr)
  83
  84   nandexpr :: repr ()
  85   nandexpr = literal P.<|> funccallOrVar
  86
  87   funccallOrVar :: repr ()
  88   funccallOrVar = identifier P.*> P.optional (parens exprlist P.<|> index)
  89
  90   exprlist = commaSep expr
  91   exprlist1 = commaSep1 expr
  92   varlist = commaSep variable
  93   varlist1 = commaSep1 variable
  94
  95   funcparam = varlist P.*> P.optional (symbol ':' P.*> varlist)
  96   varstmt = P.optional (keyword "var") P.*> varlist1 P.*> symbol '=' P.*> exprlist1 P.<* semi
  97   ifstmt = keyword "if" P.*> expr P.*> block P.*> P.optional (keyword "else" P.*> block)
  98   whilestmt = keyword "while" P.*> expr P.*> block
  99   statement = ifstmt P.<|> whilestmt P.<|> P.try varstmt P.<|> expr P.<* semi
 100   block = braces (P.skipMany statement)
 101   funcdef = keyword "function" P.*> identifier P.*> parens funcparam P.*> block
 102
 103   decimal :: repr ()
 104   decimal = number (P.oneOf ['0'..'9'])
 105   -- hexadecimal = P.oneOf "xX" P.*> number (P.oneOf (['a'..'f'] <> ['A'..'F'] <> ['0'..'9']))
 106   -- octal = P.oneOf "oO" P.*> number (P.oneOf ['0'..'7'])
 107   number :: repr a -> repr ()
 108   number digit = P.skipSome digit
 109
 110   symbol :: Char -> repr Char
 111   symbol c = P.char c P.<* whitespace
 112   parens :: repr a -> repr a
 113   parens = P.between (symbol '(') (symbol ')')
 114   brackets :: repr a -> repr a
 115   brackets = P.between (symbol '[') (symbol ']')
 116   braces :: repr a -> repr a
 117   braces = P.between (symbol '{') (symbol '}')
 118   semi :: repr Char
 119   semi = symbol ';'
 120   comma :: repr Char
 121   comma = symbol ','
 122   commaSep :: repr a -> repr ()
 123   commaSep p = P.optional (commaSep1 p)
 124   commaSep1 :: repr a -> repr ()
 125   commaSep1 p = p P.*> P.skipMany (comma P.*> p)
 126
 127   space :: repr ()
 128   space = P.void (P.satisfy
 129     [P.ErrorItemLabel "space"]
 130     (trans (H.ValueCode isSpace [||isSpace||])))
 131   whitespace :: repr ()
 132   whitespace = P.skipMany (spaces P.<|> oneLineComment)
 133   spaces :: repr ()
 134   spaces = P.skipSome space
 135   oneLineComment :: repr ()
 136   oneLineComment = P.void (P.string "//" P.*> P.skipMany (P.satisfy
 137     [P.ErrorItemLabel "oneLineComment"]
 138     (trans (H.ValueCode (/= '\n') [||(/= '\n')||]))))