make some progress on the parsing

Author: Enayaaa

Main.hs

@@ -0,0 +1,194 @@
+module Main where
+
+import System.Environment
+import Debug.Trace
+import Parser
+import Control.Monad
+import Data.List
+import System.Exit
+import Data.Char
+import Data.Word
+import Data.Maybe
+
+{-
+NOOP
+ADD ACC, Mem[Addr]
+SUB ACC, Mem[Addr]
+NOT ACC
+AND ACC, Mem[Addr]
+CMP ACC, Mem[Addr]
+LB ACC, Mem[Addr]
+LBI ACC, Mem[Mem[Addr]]
+SB Mem[Addr], ACC
+SBI Mem[Mem[Addr]], ACC
+IN Mem[Addr], IO_BUS
+JA Addr
+J Offset
+JEQ Offset
+JNE Offset
+DS
+-}
+
+data Reg         = ACC               deriving Show
+data IOBus       = IOBus             deriving Show
+newtype Addr     = Addr     Word8
+newtype AddrAddr = AddrAddr Word8
+newtype Offset   = Offset   Word8
+
+instance Show Addr where
+    show (Addr x) = "M["++show x++"]"
+
+instance Show AddrAddr where
+    show (AddrAddr x) = "M[M["++show x++"]]"
+
+instance Show Offset where
+    show (Offset x) = "±"++show x
+
+data Opcode = NOOP
+            | ADD Reg Addr
+            | SUB Reg Addr
+            | NOT Reg
+            | AND Reg Addr
+            | CMP Reg Addr
+            | LB Reg Addr
+            | LBI Reg AddrAddr
+            | SB Addr Reg
+            | SBI AddrAddr Reg
+            | IN Addr IOBus
+            | JA Addr
+            | J Offset
+            | JEQ Offset
+            | JNE Offset
+            | DS
+        deriving Show
+
+ -- ordered after opcode in binary
+opcodes = [
+    "NOOP",
+    "ADD",
+    "SUB",
+    "NOT",
+    "AND",
+    "CMP",
+    "LB",
+    "LBI",
+    "SB",
+    "SBI",
+    "IN",
+    "JA",
+    "J",
+    "JEQ",
+    "JNE",
+    "DS"
+    ]
+
+upperLowerToken :: Parser String
+upperLowerToken = do xs <- some alphanum
+                     guard (all isUpper xs || all isLower xs)
+                     space
+                     return xs
+
+opcode :: Parser String
+opcode = do xs <- upperLowerToken
+            guard (map toUpper xs `elem` opcodes)
+            return xs
+
+reg :: Parser Reg
+reg = do r <- upperLowerToken
+         if map toUpper r == "ACC"
+            then return ACC
+            else error "unknown reg"
+
+readHex :: String -> Int
+readHex = sum . zipWith (*) [1,16..] . reverse . ys
+    where
+        ys = map (\x -> if x `elem` ['0'..'9'] then
+                            ord x - ord '0'
+                        else
+                            ord x - ord 'a' + 10)
+
+--hex = do { string "0x"; xs <- some (sat (`elem` (['0'..'9']++['a'..'f']) . toLower)); return (readHex xs)}
+--bin = do { string "0b"; nat }
+
+addr :: Parser Addr
+addr = (Addr . fromIntegral <$> do { char 'M'; space; char '['; space; n <- nat; space; char ']'; space; return n })
+       <|> Addr . fromIntegral <$> nat
+       -- <|> Addr . fromIntegral <$> hex
+
+addraddr :: Parser AddrAddr
+addraddr = AddrAddr . fromIntegral <$> nat
+
+offset :: Parser Offset
+offset = Offset . fromIntegral <$> nat
+
+ioBus :: Parser IOBus
+ioBus = do b <- upperLowerToken
+           if map toUpper b == "IO_BUS"
+              then return IOBus
+              else error "unknown IO_Bus"
+
+newline :: Parser Char
+newline = do { space; char '\n' }
+
+noop = return NOOP
+add  = do { r <- reg; space; char ','; space; ADD r <$> addr; }
+sub  = do { r <- reg; space; char ','; space; SUB r <$> addr; }
+nott  = NOT <$> reg
+andd  = do { r <- reg; space; char ','; space; AND r <$> addr; }
+cmp  = do { r <- reg; space; char ','; space; CMP r <$> addr; }
+lb   = do { r <- reg; space; char ','; space; LB r <$> addr; }
+lbi  = do { r <- reg; space; char ','; space; LBI r <$> addraddr; }
+sb   = do { a <- addr; space; char ','; space; SB a <$> reg; }
+sbi  = do { a <- addraddr; space; char ','; SBI a <$> reg; }
+inn   = do { a <- addr; space; char ','; IN a <$> ioBus; }
+ja   = JA <$> addr
+j    = J <$> offset
+jeq  = JEQ <$> offset
+jne  = JNE <$> offset
+ds   = return DS
+
+lineComment :: Parser String
+lineComment = do space
+                 c <- string "//"
+                 xs <- many (sat (/= '\n'))
+                 return (c++xs)
+
+lineWithComment = do x <- line
+                     some newline <|> (do {lineComment; newline; return " "})
+                     return (Just x)
+                  <|> do {lineComment; newline; return Nothing}
+                  <|> do {space; newline; return Nothing}
+
+
+line :: Parser Opcode
+line = do op <- opcode
+          case map toUpper op of
+            "NOOP" -> noop
+            "ADD"  -> add
+            "SUB"  -> sub
+            "NOT"  -> nott
+            "AND"  -> andd
+            "CMP"  -> cmp
+            "LB"   -> lb
+            "LBI"  -> lbi
+            "SB"   -> sb
+            "SBI"  -> sbi
+            "IN"   -> inn
+            "JA"   -> ja
+            "J"    -> j
+            "JEQ"  -> jeq
+            "JNE"  -> jne
+            "DS"   -> ds
+            op -> error "hello"
+
+main = do
+    args <- getArgs
+    when (null args) (die "No input file provided.")
+
+    contents <- readFile (head args)
+    --let line = head (lines contents)
+    print contents
+    print . catMaybes . fst . head $ parse (many lineWithComment) contents
+    print $ parse (many lineWithComment) contents
+
+

Parser.hs

@@ -0,0 +1,169 @@
+{-# LANGUAGE LambdaCase #-}
+module Parser (module Parser, module Control.Applicative) where
+
+import Control.Monad
+import Control.Applicative
+import Data.Char
+
+-- | A parser for things is a function from strings to list of pairs of things and strings.
+-- The empty list of of results denotes failure of parsing.
+newtype Parser a = Parser (String -> [(a, String)])
+
+parse (Parser p) = p
+
+item :: Parser Char
+item = Parser (\case
+                  ""     -> []
+                  (c:cs) -> [(c,cs)])
+
+instance Functor Parser where
+    fmap = liftM
+    -- fmap g p = P (\inp -> case parse p inp of
+                            --[]        -> []
+                            --[(v,out)] -> [(g v, out)])
+
+instance Applicative Parser where
+    pure a = Parser (\cs -> [(a,cs)])
+    (<*>) = ap
+
+instance Monad Parser where
+    p >>= f  = Parser (\inp -> concat [parse (f a) out | (a,out) <- parse p inp])
+
+-- ======================= Choice combinators ======================= 
+
+instance Alternative Parser where
+  empty = Parser (const [])
+  p <|> q = Parser (\cs -> case parse p cs of 
+                             [] -> parse q cs
+                             res -> res)
+
+-- | Keep only one first parsing successfully result,
+-- throw away other ways the parsing could succeed when making a choice
+(+++) :: Parser a -> Parser a -> Parser a
+p +++ q = Parser (\cs -> case parse (p <|> q) cs of
+                           []     -> []
+                           (x:xs) -> [x])
+
+sat :: (Char -> Bool) -> Parser Char
+sat p = do c <- item
+           guard (p c) -- fail if predicate doesn't hold
+           return c
+
+char :: Char -> Parser Char
+char c = sat (c ==)
+
+-- ======================= Recursion combinators =======================
+
+-- | Parse a specific string
+string :: String -> Parser String
+string "" = return ""
+string (c:cs) = do { char c; string cs; return (c:cs); }
+
+-- | Parse repeated applications of a parser p;
+-- the many combinator permits zero or more applications of p
+-- `many`
+
+-- | Parse repeated applications of a parser p;
+-- the some combinator permits one or more applications of p
+-- `some`
+
+-- | Parse repeated applications of a parser p, separated by applications
+-- of a parser sep whose result values are thrown away. Permits zero applications
+sepBy :: Parser a -> Parser a -> Parser [a]
+p `sepBy` sep = (p `sepBy1` sep) +++ return []
+
+-- | Parse repeated applications of a parser p, separated by applications
+-- of a parser sep whose result values are thrown away. Permits one or more applications
+sepBy1 :: Parser a -> Parser a -> Parser [a]
+p `sepBy1` sep = do a <- p
+                    as <- many (do {sep; p})
+                    return (a:as)
+
+-- | Parse repeated applications of a parser p, separated by applications of a parser
+-- op whose result value is an operator that is assumed to associate to the left,
+-- and which is used to combine the results from the p parsers
+-- Can be applied zero or more times.
+chainl :: Parser a -> Parser (a->a->a) -> a -> Parser a
+chainl p op a = (p `chainl1` op) +++ return a
+
+-- | Parse repeated applications of a parser p, separated by applications of a parser
+-- op whose result value is an operator that is assumed to associate to the left,
+-- and which is used to combine the results from the p parsers.
+-- Can be applied one or more times.
+chainl1 :: Parser a -> Parser (a->a->a) -> Parser a
+p `chainl1` op = do { a <- p; rest a}
+                    where
+                        rest a = do f <- op
+                                    b <- p
+                                    rest (f a b)
+                                +++ return a
+
+-- chainr  and chainr1 can be implemented simmiliarly
+
+
+-- ======================= Lexical combinators =======================
+
+digit :: Parser Int
+digit = do x <- digitChar
+           return (ord x - ord '0')
+
+letter :: Parser Char
+letter = sat isLetter
+
+digitChar :: Parser Char
+digitChar = sat isDigit
+
+lower :: Parser Char
+lower = sat isLower
+
+upper :: Parser Char
+upper = sat isUpper
+
+alphanum :: Parser Char
+alphanum = sat isAlphaNum
+
+nat :: Parser Int
+nat = do x <- some digitChar
+         return (read x)
+
+-- | Parse a string of spaces, tabs, and newlines
+space :: Parser String
+space = many (sat (\c -> c == '\t' || isSeparator c))
+
+-- | Parse an identifier, starting with a lowercase and zero or more alphanumerics.
+identifier :: Parser String
+identifier = do x <- lower
+                xs <- many alphanum
+                return (x:xs)
+
+-- | Parse a token using a parser p, throwing away any trailing space
+token :: Parser a -> Parser a
+token p = do a <- p
+             space
+             return a
+
+-- | Parse a symbolic token
+symbol :: String -> Parser String
+symbol cs = token (string cs)
+
+-- | Apply a parser p, throwing away any leading space
+apply :: Parser a -> String -> [(a,String)]
+apply p = parse $ do { space; p }
+
+-- ======================= Example =======================
+{-
+expr :: Parser Int
+addop :: Parser (Int -> Int -> Int)
+mulop :: Parser (Int -> Int -> Int)
+
+expr = term `chainl1` addop
+term = factor `chainl1` mulop
+factor = digit +++ do { symbol "("; n <- expr; symbol ")"; return n }
+
+addop = do { symbol "+"; return (+) } +++ do { symbol "-"; return (-) }
+mulop = do { symbol "*"; return (*) } +++ do { symbol "/"; return div }
+
+res :: Int
+res = fst . head $ apply expr " (1 - 2*3)+4 " -- -1
+
+-}