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   literal :: repr ()
  46   literal = bit P.<|> charLit
  47   bit :: repr ()
  48   bit = (P.char '0' P.<|> P.char '1') P.*> whitespace
  49   charLit :: repr ()
  50   charLit = P.between (P.char '\'') (symbol '\'') charChar
  51   charChar :: repr ()
  52   charChar = P.void (P.satisfy
  53     [P.ErrorItemLabel "Char"]
  54     (trans (H.ValueCode nandStringLetter [||nandStringLetter||]))) P.<|> esc
  55   esc :: repr ()
  56   esc = P.char '\\' P.*> P.void (P.oneOf "0tnvfr")
  57   expr :: repr ()
  58   expr = nandexpr P.*> P.skipMany (symbol '!' P.*> nandexpr)
  59   nandexpr :: repr ()
  60   nandexpr = literal P.<|> funccallOrVar
  61   funccallOrVar :: repr ()
  62   funccallOrVar = identifier P.*> P.optional (parens exprlist P.<|> index)
  63   identifier :: repr ()
  64   identifier = P.try (identStart P.*> P.skipMany identLetter) P.*> whitespace
  65   identStart = P.satisfy
  66     [P.ErrorItemLabel "identStart"]
  67     (trans (H.ValueCode nandIdentStart [||nandIdentStart||]))
  68
  69   exprlist  = commaSep expr
  70   exprlist1 = commaSep1 expr
  71   varlist   = commaSep variable
  72   varlist1  = commaSep1 variable
  73   variable :: repr ()
  74   variable = identifier P.*> P.optional index
  75   index :: repr ()
  76   index = brackets nat
  77   nat :: repr ()
  78   nat = decimal
  79   decimal :: repr ()
  80   decimal = number (P.oneOf ['0'..'9'])
  81   number :: repr a -> repr ()
  82   number digit = P.skipSome digit
  83
  84   funcdef = keyword "function" P.*> identifier P.*> parens funcparam P.*> block
  85   funcparam = varlist P.*> P.optional (symbol ':' P.*> varlist)
  86   block = braces (P.skipMany statement)
  87   statement =
  88     ifstmt P.<|> whilestmt P.<|> P.try varstmt P.<|> expr P.<* semi
  89     -- P.pure H.unit
  90   ifstmt = keyword "if" -- P.*> expr P.*> block P.*> P.optional (keyword "else" P.*> block)
  91   whilestmt = keyword "while" P.*> expr P.*> block
  92   varstmt = P.optional (keyword "var") P.*> varlist1 P.*> symbol '=' P.*> exprlist1 P.<* semi
  93   keyword :: String -> repr ()
  94   keyword k = P.string k P.*> P.pure H.unit
  95   -- keyword s = P.try (P.string s P.*> notIdentLetter) P.*> whitespace
  96   notIdentLetter = P.negLook identLetter
  97   identLetter = P.satisfy
  98     [P.ErrorItemLabel "identLetter"]
  99     (trans (H.ValueCode nandIdentLetter [||nandIdentLetter||]))
 100
 101   -- hexadecimal = P.oneOf "xX" P.*> number (P.oneOf (['a'..'f'] <> ['A'..'F'] <> ['0'..'9']))
 102   -- octal = P.oneOf "oO" P.*> number (P.oneOf ['0'..'7'])
 103
 104   symbol :: Char -> repr Char
 105   symbol c = P.char c P.<* whitespace
 106   parens :: repr a -> repr a
 107   parens = P.between (symbol '(') (symbol ')')
 108   brackets :: repr a -> repr a
 109   brackets = P.between (symbol '[') (symbol ']')
 110   braces :: repr a -> repr a
 111   braces = P.between (symbol '{') (symbol '}')
 112   semi :: repr Char
 113   semi = symbol ';'
 114   comma :: repr Char
 115   comma = symbol ','
 116   commaSep :: repr a -> repr ()
 117   commaSep p = P.optional (commaSep1 p)
 118   commaSep1 :: repr a -> repr ()
 119   commaSep1 p = p P.*> P.skipMany (comma P.*> p)
 120
 121   space :: repr ()
 122   space = P.void (P.satisfy
 123     [P.ErrorItemLabel "space"]
 124     (trans (H.ValueCode isSpace [||isSpace||])))
 125   whitespace :: repr ()
 126   whitespace = spaces
 127   -- whitespace = P.skipMany (spaces P.<|> oneLineComment)
 128   spaces :: repr ()
 129   spaces = P.skipSome space
 130   oneLineComment :: repr ()
 131   oneLineComment = P.void (P.string "//" P.*> P.skipMany (P.satisfy
 132     [P.ErrorItemLabel "oneLineComment"]
 133     (trans (H.ValueCode (/= '\n') [||(/= '\n')||]))))