test/Grammar/Nandlang.hs

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