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