1 {-# LANGUAGE DeriveLift #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE Rank2Types #-}
4 {-# LANGUAGE StandaloneDeriving #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE UnboxedTuples #-}
7 module Parser.Nandlang where
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)
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
33 import Symantic.Univariant.Trans
34 import qualified Symantic.Parser as P
35 import qualified Symantic.Parser.Haskell as H
37 type Parser a = P.Parser Text.Text a
39 nandIdentStart :: Char -> Bool
40 nandIdentStart c = isAlpha c || c == '_'
42 nandIdentLetter :: Char -> Bool
43 nandIdentLetter c = isAlphaNum c || c == '_'
45 nandUnreservedName :: String -> Bool
46 nandUnreservedName = \s -> not (Set.member s keys)
48 keys = Set.fromList ["if", "else", "while", "function", "var"]
50 nandStringLetter :: Char -> Bool
51 nandStringLetter c = (c /= '"') && (c /= '\\') && (c > '\026')
53 nandlang :: forall repr.
54 P.Grammar Char repr =>
56 nandlang = whitespace P.*> P.skipMany funcdef P.<* P.eof
61 identifier = P.try (identStart P.*> P.skipMany identLetter) P.*> whitespace
63 variable = identifier P.*> P.optional index
66 literal = bit P.<|> charLit
68 keyword :: String -> repr ()
69 keyword s = P.try (P.string s P.*> notIdentLetter) P.*> whitespace
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
80 bit = (P.char '0' P.<|> P.char '1') P.*> whitespace
86 charLit = P.between (P.char '\'') (symbol '\'') charChar
89 charChar = P.void (P.satisfy
90 [P.ErrorItemLabel "Char"]
91 (trans (H.ValueCode nandStringLetter [||nandStringLetter||]))) P.<|> esc
94 esc = P.char '\\' P.*> P.void (P.oneOf "0tnvfr")
97 expr = nandexpr P.*> P.skipMany (symbol '!' P.*> nandexpr)
100 nandexpr = literal P.<|> funccallOrVar
102 funccallOrVar :: repr ()
103 funccallOrVar = identifier P.*> P.optional (parens exprlist P.<|> index)
105 exprlist = commaSep expr
106 exprlist1 = commaSep1 expr
107 varlist = commaSep variable
108 varlist1 = commaSep1 variable
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
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
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 '}')
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)
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)
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')||]))))