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