ewe (empty) → 0.1.0.12
raw patch · 8 files changed
+1468/−0 lines, 8 filesdep +basedep +mtldep +parsecsetup-changed
Dependencies added: base, mtl, parsec, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- ewe.cabal +31/−0
- src/Language/EWE/AbsSyn.hs +56/−0
- src/Language/EWE/Parser.hs +316/−0
- src/Language/EWE/Token.hs +725/−0
- src/Language/EWE/VM.hs +258/−0
- src/Main.hs +50/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Juan Francisco Cardona McCormick++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Juan Francisco Cardona McCormick nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ewe.cabal view
@@ -0,0 +1,31 @@+-- Initial ewe.cabal generated by cabal init. For further documentation,+-- see http://haskell.org/cabal/users-guide/++name: ewe+version: 0.1.0.12+synopsis: An language to teach a programming+description: Another implementions of the EWE programming language originally developed by Kent D. Lee. EWE was an extension of the RAM programming language created by Sethi.+homepage: http://github.com/jfcmacro/ewe+license: BSD3+license-file: LICENSE+author: Juan Francisco Cardona McCormick+maintainer: fcardona@eafit.edu.co+-- copyright:+category: Language+build-type: Simple+cabal-version: >=1.8+++executable ewe+ main-is: Main.hs+ -- other-modules:+ Build-depends: base >=4.5 && < 5, parsec >=3.1.3 && < 4, transformers >=0.3,+ mtl >= 2.1+ hs-source-dirs: src+ other-modules: Language.EWE.Parser, Language.EWE.AbsSyn,+ Language.EWE.VM, Language.EWE.Token++source-repository head+ type: git+ location: git://github.com/jfcmacro/ewe.git+
+ src/Language/EWE/AbsSyn.hs view
@@ -0,0 +1,56 @@+module Language.EWE.AbsSyn where++data AbsSyn = Empty++data MRef = MRefI Int+ | MRefId String+ deriving (Eq, Show)++data Cond = CLET+ | CLT+ | CGET+ | CGT+ | CE+ | CNE+ deriving (Eq,Show)++type Equ = (String,Int)++type Equates = [Equ]++type Labels = [String]++data Stmt = Stmt Labels Instr+ deriving (Eq,Show)++type Stmts = [Stmt]++data Prog = Prg {stms :: Stmts+ ,equates :: Equates}+ deriving (Eq,Show)++data Instr = IMMI MRef Int -- Move Memory Int+ | IMMS MRef String -- Move Memory String+ | IMRPC MRef Int -- Move Memory Relative PC+ | SPC MRef -- Set PC+ | IMMM MRef MRef -- Move Memory to Memory+ | IAdd MRef MRef MRef -- Add two Memory References+ | ISub MRef MRef MRef -- Sub two Memory References+ | IMul MRef MRef MRef -- Mul two Memory References+ | IDiv MRef MRef MRef -- Div two Memory References+ | IMod MRef MRef MRef -- Mod two Memory References+ | IMRI MRef MRef Int -- Move to Memory ref a Indexed Memory Pos+ | IMMR MRef Int MRef -- Move to Index Memory Ref a Memory Ref+ | IRI MRef -- Read an Int and stored into a Mem Ref+ | IWI MRef -- Write an Int from a Mem Ref+ | IRS MRef MRef -- Read a Str+ | IWS MRef -- Write a Str+ | IGI Int -- Goto to line+ | IGS String -- Goto sym+ | IFI MRef Cond MRef Int -- If Cond then Int+ | IFS MRef Cond MRef String --+ | IH -- Halt+ | IB -- Break+ | INI+ deriving (Eq,Show)+
+ src/Language/EWE/Parser.hs view
@@ -0,0 +1,316 @@+module Language.EWE.Parser where++import System.IO+import Control.Monad+import Text.Parsec+import Text.Parsec.Prim+import Text.ParserCombinators.Parsec hiding(try)+import Language.EWE.AbsSyn+import Language.EWE.EweLang(eweLangDef)+import qualified Language.EWE.Token as Tkn+ +-- Parser generates from the language+pEweLexer = Tkn.makeTokenParser eweLangDef++pIdentifier = Tkn.identifier pEweLexer+pReserved = Tkn.reserved pEweLexer+pReservedOp = Tkn.reservedOp pEweLexer+pParens = Tkn.parens pEweLexer+pBrackets = Tkn.brackets pEweLexer+pInteger = Tkn.integer pEweLexer+pComma = Tkn.comma pEweLexer+pWhiteSpace = Tkn.whiteSpace pEweLexer+pSymbol = Tkn.symbol pEweLexer+pLexeme = Tkn.lexeme pEweLexer++-- Parser of EWE Language+pEWE:: String -> String -> Either ParseError Prog+pEWE inp name = parse pEweProg name inp++pEweProg :: Parser Prog+pEweProg = pStmts++pStmts :: Parser Prog+pStmts = do res <- sepEndBy pStmtLine pEOL + let (eq',st') = foldr f ([],[]) res+ return $ Prg st' eq'+ where f (e,s) (e',s') = (e++e',s:s')++pLabel :: Parser String+pLabel = do id <- pId+ char ':'+ return $ id+ <?> "Parsing label"++pStmtLine :: Parser (Equates, Stmt)+pStmtLine = do eqs <- pEquates+ return $ (eqs, Stmt [] INI)+ <|>+ do l <- pLabels+ char '\t'+ ins <- pInstr+ return $ ([], Stmt l ins)+ <|>+ do pWhiteSpace+ return $ ([], Stmt [] INI)+ ++pLabels :: Parser [String]+pLabels = pLabel `sepBy` pWhiteSpace+++-- Instructions parsers+-- <instr> ::= ...+pInstr :: Parser Instr+pInstr = do instr <- choice [pPCInstr+ ,pReadInt+ ,pReadStr+ ,pWriteInt+ ,pWriteStr+ ,pGoto+ ,pIf+ ,pOneKw+ ,pPrefixMRef+ ]+ return instr++-- "PC" ":=" <memref>+-- AbsSyn SPC (Set PC instruction)+pPCInstr :: Parser Instr+pPCInstr = do pReserved"PC"+ pReservedOp ":="+ mr <- pMRef2+ return $ SPC mr++-- "readInt" "(" <memref> ")"+-- AbsSyn IRI Instruction Read Int+-- "readStr" "(" <memref> ")"+-- AbsSyn IRS Instruction Read String++-- pRead :: Parser Instr+-- pRead = do string "read"+-- (string "Int" >> pReadInt) <|> (string "Str" >> pReadStr)++-- pReadInt :: Parser Instr+-- pReadInt = pInstr1MRef IRI++-- pReadStr :: Parser Instr+-- pReadStr = do pSpaces+-- (mr1, mr2) <- pTokenB pReadMRefs+-- pSpaces+-- return $ IRS mr1 mr2+pReadInt :: Parser Instr+pReadInt = do pReserved "readInt"+ mr <- pParens pMRef2+ return $ IRI mr++pReadStr :: Parser Instr+pReadStr = do pReserved "readStr"+ (mr1,mr2) <- pParens p+ return $ IRS mr1 mr2+ where p = do { mr1 <- pMRef2 ; pComma; mr2 <- pMRef2 ; return $ (mr1,mr2) }++-- "writeStr" "(" <memref> ")"+-- AbsSyn IWS Instruction Write String+-- "writeInt" "(" <memref> ")"+-- AbsSyn IWI Instruction Write Int+-- pWrite :: Parser Instr+-- pWrite = do string "write"+-- (string "Int" >> pWriteInt) <|> (string "Str" >> pWriteStr)++-- pWriteInt :: Parser Instr+-- pWriteInt = pInstr1MRef IWI++-- pWriteStr :: Parser Instr+-- pWriteStr = pInstr1MRef IWS+pWriteInt :: Parser Instr+pWriteInt = do pReserved "writeInt"+ mr <- pParens pMRef2+ return $ IWI mr++pWriteStr :: Parser Instr+pWriteStr = do pReserved "writeStr"+ mr <- pParens pMRef2+ return $ IWS mr++-- "goto" Integer+-- "goto" Identifier+-- AbsSyn IGI Goto to line+-- AbsSyn IGS Goto to Symbol+pGoto:: Parser Instr+pGoto = do pReserved "goto"+ iOrId <- pTknIntOrId+ let instr = either IGI IGS iOrId+ return instr++-- "if" <mref> <condition> <memref> "then" "goto" Integer+-- "if" <mref> <condition> <memref> "then" "goto" Identifier+-- AbsSyn IFI If Cond then Int+-- AbsSyn IFS If Cont then Id+pIf :: Parser Instr+pIf = do pReserved "if"+ mr1 <- pMRef2+ cnd <- pCond+ mr2 <- pMRef2+ pReserved "then"+ pReserved "goto"+ iOrId <- pTknIntOrId+ let instr = either (IFI mr1 cnd mr2) (IFS mr1 cnd mr2) iOrId+ return instr++-- "halt"+-- "break"+-- IH Instruction Halt+-- IB Instruciton Break+listOneKw :: [(String,Instr)]+listOneKw = [("halt", IH), ("break", IB)]++pOneKw :: Parser Instr+pOneKw = choice+ $ map (\(s,r) -> (pReserved s >> return r)) listOneKw++pReadMRefs :: Parser (MRef,MRef)+pReadMRefs = do pParens (do mr1 <- pMRef2+ pComma+ mr2 <- pMRef2+ return $ (mr1, mr2))++pInstr1MRef :: (MRef -> Instr) -> Parser Instr+pInstr1MRef f =+ do mr <- pParens pMRef2+ return $ f mr++pPrefixMRef :: Parser Instr+pPrefixMRef =+ do pReserved "M"+ op <- pBrackets pMRefOrIdx'+ pReservedOp ":="+ either pIMMR pNextRHS op+ <|>+ (pLexeme pId >>= \id -> pReservedOp ":=" >> (pNextRHS (MRefId id)))++pIMMR :: (MRef,Int) -> Parser Instr+pIMMR (mr1,i) =+ do pReservedOp ":="+ mr2 <- pMRef2+ return $ IMMR mr1 i mr2++pNextRHS :: MRef -> Parser Instr+pNextRHS mr1 =+ (pLexeme pInt >>= \i -> return $ IMMI mr1 i)+ <|>+ (pLexeme pId >>= \id -> pEndRHS mr1 (MRefId id))+ <|>+ (pLexeme pStrLit >>= \str -> return $ IMMS mr1 str)+ <|>+ do pReserved "M"+ op <- pBrackets (pTokenB pMRefOrIdx')+ either (\(mr2,i) -> return $ IMRI mr1 mr2 i) (pEndRHS mr1) op+ +pEndRHS :: MRef -> MRef -> Parser Instr+pEndRHS mr1 mr2 = option (IMMM mr1 mr2) (pPartialArith mr1 mr2)++listAOps :: [(String, MRef -> MRef -> MRef -> Instr)]+listAOps = [("+",IAdd), ("-",ISub), ("*",IMul), ("/",IDiv), ("%",IMod)]++pPartialArith :: MRef -> MRef -> Parser Instr+pPartialArith mr1 mr2 =+ choice $ map g listAOps+ where g (s,f) = pReservedOp s+ >> pMRef2+ >>= \mr3 -> return $ f mr1 mr2 mr3++pMRefOrIdx' :: Parser (Either (MRef,Int) MRef)+pMRefOrIdx' = do mr <- pMRef2+ pReservedOp "+"+ i <- pInteger -- i <- pInt+ return $ Left (mr,(fromInteger i))+ <|>+ (pInteger >>= \i -> return $ Right (MRefI (fromInteger i)))++-- Helpers parser to identify an integer or identifier+pTknIntOrId :: Parser (Either Int String)+pTknIntOrId = (pLexeme pInt >>= return.Left) <|> (pLexeme pId >>= return.Right)++pInt :: Parser Int+pInt = do l <- oneOf "123456789"+ ls <- many digit+ return $ (read (l:ls))+ <|> + do l <- oneOf "0"+ notFollowedBy digit+ return $ (read (l:[]))++pId :: Parser String+pId = do l <- (letter <|> char '_')+ ls <- many (alphaNum <|> char '_')+ return $ l:ls++-- String Literal Parser+pStrLit :: Parser String+pStrLit = between (pSymbol "\"") (pSymbol "\"") (many $ p)+ <|>+ between (pSymbol "'") (pSymbol "'") (many $ p)+ where p = oneOf " :!#$%&*+./<=>?@\\^|-~()[]" <|> digit <|> letter +-- Parser candidates to delete, because are deprecated+pToken :: Parser a -> Parser a+pToken p = (p >>= \a -> many (char ' ') >> return a )++pTokenB :: Parser a -> Parser a+pTokenB p = do many (char ' ')+ a <- p+ many (char ' ')+ return a++pSpaces :: Parser ()+pSpaces = many (char ' ') >> return ()++-- MemRef+pMRef2 :: Parser MRef+pMRef2 = do pReserved "M"+ i<- pBrackets pInteger+ return $ (MRefI (fromInteger i))+ <|>+ (pIdentifier >>= (return.MRefId))+ <?>+ "pMRef2"++-- Equates+pEqu :: Parser Equ+pEqu = do pReserved "equ"+ id <- pIdentifier+ pReserved "M"+ i <- pBrackets pInteger+ return $ (id,(fromInteger i))++pEquates :: Parser Equates+pEquates = do{ equates <- sepBy pEqu (pWhiteSpace <|> pEOL); eof; return equates }+++-- Cond+listCond :: [(String,Cond)]+listCond = [(">",CLT)+ ,(">=",CLET)+ ,("<",CGT)+ ,("<=",CGET)+ ,("=",CE)+ ,("<>",CNE)]++pCond :: Parser Cond+pCond = choice $ map (\(s,r) -> (pReservedOp s >> return r)) listCond++-- End of Line parser+pEOL :: Parser ()+pEOL = (char '\n' >> return ()) <|> (string "\r\n" >> return ())++-- Basic Parsers for compiling assemble files+pOneLineComment :: Parser ()+pOneLineComment = do try (string "#")+ skipMany (satisfy (/= '\n'))+ char '\n'+ return ()++pEmptyLine :: Parser ()+pEmptyLine = do pWhiteSpace+ char '\n'+ return ()
+ src/Language/EWE/Token.hs view
@@ -0,0 +1,725 @@+-----------------------------------------------------------------------------+-- |+-- Module : Text.Parsec.Token+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : derek.a.elkins@gmail.com+-- Stability : provisional+-- Portability : non-portable (uses local universal quantification: PolymorphicComponents)+-- +-- A helper module to parse lexical elements (tokens). See 'makeTokenParser'+-- for a description of how to use it.+-- +-----------------------------------------------------------------------------++-- This was done because the original doesn't use well isSpace.++{-# LANGUAGE PolymorphicComponents, FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Language.EWE.Token+ ( LanguageDef+ , GenLanguageDef (..)+ , TokenParser+ , GenTokenParser (..)+ , makeTokenParser+ ) where++import Data.Char ( isAlpha, toLower, toUpper, isSpace, digitToInt )+import Data.List ( nub, sort )+import Control.Monad.Identity+import Text.Parsec.Prim+import Text.Parsec.Char+import Text.Parsec.Combinator++-----------------------------------------------------------+-- Language Definition+-----------------------------------------------------------++type LanguageDef st = GenLanguageDef String st Identity++-- | The @GenLanguageDef@ type is a record that contains all parameterizable+-- features of the 'Text.Parsec.Token' module. The module 'Text.Parsec.Language'+-- contains some default definitions.++data GenLanguageDef s u m+ = LanguageDef { + + -- | Describes the start of a block comment. Use the empty string if the+ -- language doesn't support block comments. For example \"\/*\". ++ commentStart :: String,++ -- | Describes the end of a block comment. Use the empty string if the+ -- language doesn't support block comments. For example \"*\/\". ++ commentEnd :: String,++ -- | Describes the start of a line comment. Use the empty string if the+ -- language doesn't support line comments. For example \"\/\/\". ++ commentLine :: String,++ -- | Set to 'True' if the language supports nested block comments. ++ nestedComments :: Bool,++ -- | This parser should accept any start characters of identifiers. For+ -- example @letter \<|> char \"_\"@. ++ identStart :: ParsecT s u m Char,++ -- | This parser should accept any legal tail characters of identifiers.+ -- For example @alphaNum \<|> char \"_\"@. ++ identLetter :: ParsecT s u m Char,++ -- | This parser should accept any start characters of operators. For+ -- example @oneOf \":!#$%&*+.\/\<=>?\@\\\\^|-~\"@ ++ opStart :: ParsecT s u m Char,++ -- | This parser should accept any legal tail characters of operators.+ -- Note that this parser should even be defined if the language doesn't+ -- support user-defined operators, or otherwise the 'reservedOp'+ -- parser won't work correctly. ++ opLetter :: ParsecT s u m Char,++ -- | The list of reserved identifiers. ++ reservedNames :: [String],++ -- | The list of reserved operators. ++ reservedOpNames:: [String],++ -- | Set to 'True' if the language is case sensitive. ++ caseSensitive :: Bool++ }++ -----------------------------------------------------------+ -- A first class module: TokenParser+ -----------------------------------------------------------++type TokenParser st = GenTokenParser String st Identity++ -- | The type of the record that holds lexical parsers that work on+ -- @s@ streams with state @u@ over a monad @m@.++data GenTokenParser s u m+ = TokenParser {++ -- | This lexeme parser parses a legal identifier. Returns the identifier+ -- string. This parser will fail on identifiers that are reserved+ -- words. Legal identifier (start) characters and reserved words are+ -- defined in the 'LanguageDef' that is passed to+ -- 'makeTokenParser'. An @identifier@ is treated as+ -- a single token using 'try'.++ identifier :: ParsecT s u m String,+ + -- | The lexeme parser @reserved name@ parses @symbol + -- name@, but it also checks that the @name@ is not a prefix of a+ -- valid identifier. A @reserved@ word is treated as a single token+ -- using 'try'. ++ reserved :: String -> ParsecT s u m (),++ -- | This lexeme parser parses a legal operator. Returns the name of the+ -- operator. This parser will fail on any operators that are reserved+ -- operators. Legal operator (start) characters and reserved operators+ -- are defined in the 'LanguageDef' that is passed to+ -- 'makeTokenParser'. An @operator@ is treated as a+ -- single token using 'try'. ++ operator :: ParsecT s u m String,++ -- |The lexeme parser @reservedOp name@ parses @symbol+ -- name@, but it also checks that the @name@ is not a prefix of a+ -- valid operator. A @reservedOp@ is treated as a single token using+ -- 'try'. ++ reservedOp :: String -> ParsecT s u m (),+++ -- | This lexeme parser parses a single literal character. Returns the+ -- literal character value. This parsers deals correctly with escape+ -- sequences. The literal character is parsed according to the grammar+ -- rules defined in the Haskell report (which matches most programming+ -- languages quite closely). ++ charLiteral :: ParsecT s u m Char,++ -- | This lexeme parser parses a literal string. Returns the literal+ -- string value. This parsers deals correctly with escape sequences and+ -- gaps. The literal string is parsed according to the grammar rules+ -- defined in the Haskell report (which matches most programming+ -- languages quite closely). ++ stringLiteral :: ParsecT s u m String,++ -- | This lexeme parser parses a natural number (a positive whole+ -- number). Returns the value of the number. The number can be+ -- specified in 'decimal', 'hexadecimal' or+ -- 'octal'. The number is parsed according to the grammar+ -- rules in the Haskell report. ++ natural :: ParsecT s u m Integer,++ -- | This lexeme parser parses an integer (a whole number). This parser+ -- is like 'natural' except that it can be prefixed with+ -- sign (i.e. \'-\' or \'+\'). Returns the value of the number. The+ -- number can be specified in 'decimal', 'hexadecimal'+ -- or 'octal'. The number is parsed according+ -- to the grammar rules in the Haskell report. + + integer :: ParsecT s u m Integer,++ -- | This lexeme parser parses a floating point value. Returns the value+ -- of the number. The number is parsed according to the grammar rules+ -- defined in the Haskell report. ++ float :: ParsecT s u m Double,++ -- | This lexeme parser parses either 'natural' or a 'float'.+ -- Returns the value of the number. This parsers deals with+ -- any overlap in the grammar rules for naturals and floats. The number+ -- is parsed according to the grammar rules defined in the Haskell report. ++ naturalOrFloat :: ParsecT s u m (Either Integer Double),++ -- | Parses a positive whole number in the decimal system. Returns the+ -- value of the number. ++ decimal :: ParsecT s u m Integer,++ -- | Parses a positive whole number in the hexadecimal system. The number+ -- should be prefixed with \"0x\" or \"0X\". Returns the value of the+ -- number. ++ hexadecimal :: ParsecT s u m Integer,++ -- | Parses a positive whole number in the octal system. The number+ -- should be prefixed with \"0o\" or \"0O\". Returns the value of the+ -- number. ++ octal :: ParsecT s u m Integer,++ -- | Lexeme parser @symbol s@ parses 'string' @s@ and skips+ -- trailing white space. ++ symbol :: String -> ParsecT s u m String,++ -- | @lexeme p@ first applies parser @p@ and than the 'whiteSpace'+ -- parser, returning the value of @p@. Every lexical+ -- token (lexeme) is defined using @lexeme@, this way every parse+ -- starts at a point without white space. Parsers that use @lexeme@ are+ -- called /lexeme/ parsers in this document.+ -- + -- The only point where the 'whiteSpace' parser should be+ -- called explicitly is the start of the main parser in order to skip+ -- any leading white space.+ --+ -- > mainParser = do{ whiteSpace+ -- > ; ds <- many (lexeme digit)+ -- > ; eof+ -- > ; return (sum ds)+ -- > }++ lexeme :: forall a. ParsecT s u m a -> ParsecT s u m a,++ -- | Parses any white space. White space consists of /zero/ or more+ -- occurrences of a 'space', a line comment or a block (multi+ -- line) comment. Block comments may be nested. How comments are+ -- started and ended is defined in the 'LanguageDef'+ -- that is passed to 'makeTokenParser'. ++ whiteSpace :: ParsecT s u m (),++ -- | Lexeme parser @parens p@ parses @p@ enclosed in parenthesis,+ -- returning the value of @p@.++ parens :: forall a. ParsecT s u m a -> ParsecT s u m a,++ -- | Lexeme parser @braces p@ parses @p@ enclosed in braces (\'{\' and+ -- \'}\'), returning the value of @p@. ++ braces :: forall a. ParsecT s u m a -> ParsecT s u m a,++ -- | Lexeme parser @angles p@ parses @p@ enclosed in angle brackets (\'\<\'+ -- and \'>\'), returning the value of @p@. ++ angles :: forall a. ParsecT s u m a -> ParsecT s u m a,++ -- | Lexeme parser @brackets p@ parses @p@ enclosed in brackets (\'[\'+ -- and \']\'), returning the value of @p@. ++ brackets :: forall a. ParsecT s u m a -> ParsecT s u m a,++ -- | DEPRECATED: Use 'brackets'.++ squares :: forall a. ParsecT s u m a -> ParsecT s u m a,++ -- | Lexeme parser |semi| parses the character \';\' and skips any+ -- trailing white space. Returns the string \";\". ++ semi :: ParsecT s u m String,++ -- | Lexeme parser @comma@ parses the character \',\' and skips any+ -- trailing white space. Returns the string \",\". ++ comma :: ParsecT s u m String,++ -- | Lexeme parser @colon@ parses the character \':\' and skips any+ -- trailing white space. Returns the string \":\". ++ colon :: ParsecT s u m String,++ -- | Lexeme parser @dot@ parses the character \'.\' and skips any+ -- trailing white space. Returns the string \".\". ++ dot :: ParsecT s u m String,++ -- | Lexeme parser @semiSep p@ parses /zero/ or more occurrences of @p@+ -- separated by 'semi'. Returns a list of values returned by+ -- @p@.++ semiSep :: forall a . ParsecT s u m a -> ParsecT s u m [a],++ -- | Lexeme parser @semiSep1 p@ parses /one/ or more occurrences of @p@+ -- separated by 'semi'. Returns a list of values returned by @p@. ++ semiSep1 :: forall a . ParsecT s u m a -> ParsecT s u m [a],++ -- | Lexeme parser @commaSep p@ parses /zero/ or more occurrences of+ -- @p@ separated by 'comma'. Returns a list of values returned+ -- by @p@. ++ commaSep :: forall a . ParsecT s u m a -> ParsecT s u m [a],++ -- | Lexeme parser @commaSep1 p@ parses /one/ or more occurrences of+ -- @p@ separated by 'comma'. Returns a list of values returned+ -- by @p@. ++ commaSep1 :: forall a . ParsecT s u m a -> ParsecT s u m [a]+ }++ -----------------------------------------------------------+ -- Given a LanguageDef, create a token parser.+ -----------------------------------------------------------++ -- | The expression @makeTokenParser language@ creates a 'GenTokenParser'+ -- record that contains lexical parsers that are+ -- defined using the definitions in the @language@ record.+ --+ -- The use of this function is quite stylized - one imports the+ -- appropiate language definition and selects the lexical parsers that+ -- are needed from the resulting 'GenTokenParser'.+ --+ -- > module Main where+ -- >+ -- > import Text.Parsec+ -- > import qualified Text.Parsec.Token as P+ -- > import Text.Parsec.Language (haskellDef)+ -- >+ -- > -- The parser+ -- > ...+ -- >+ -- > expr = parens expr+ -- > <|> identifier+ -- > <|> ...+ -- > + -- >+ -- > -- The lexer+ -- > lexer = P.makeTokenParser haskellDef + -- > + -- > parens = P.parens lexer+ -- > braces = P.braces lexer+ -- > identifier = P.identifier lexer+ -- > reserved = P.reserved lexer+ -- > ...++makeTokenParser :: (Stream s m Char)+ => GenLanguageDef s u m -> GenTokenParser s u m+makeTokenParser languageDef+ = TokenParser{ identifier = identifier+ , reserved = reserved+ , operator = operator+ , reservedOp = reservedOp++ , charLiteral = charLiteral+ , stringLiteral = stringLiteral+ , natural = natural+ , integer = integer+ , float = float+ , naturalOrFloat = naturalOrFloat+ , decimal = decimal+ , hexadecimal = hexadecimal+ , octal = octal++ , symbol = symbol+ , lexeme = lexeme+ , whiteSpace = whiteSpace++ , parens = parens+ , braces = braces+ , angles = angles+ , brackets = brackets+ , squares = brackets+ , semi = semi+ , comma = comma+ , colon = colon+ , dot = dot+ , semiSep = semiSep+ , semiSep1 = semiSep1+ , commaSep = commaSep+ , commaSep1 = commaSep1+ }+ where++ -----------------------------------------------------------+ -- Bracketing+ -----------------------------------------------------------+ parens p = between (symbol "(") (symbol ")") p+ braces p = between (symbol "{") (symbol "}") p+ angles p = between (symbol "<") (symbol ">") p+ brackets p = between (symbol "[") (symbol "]") p++ semi = symbol ";"+ comma = symbol ","+ dot = symbol "."+ colon = symbol ":"++ commaSep p = sepBy p comma+ semiSep p = sepBy p semi++ commaSep1 p = sepBy1 p comma+ semiSep1 p = sepBy1 p semi+++ -----------------------------------------------------------+ -- Chars & Strings+ -----------------------------------------------------------+ charLiteral = lexeme (between (char '\'')+ (char '\'' <?> "end of character")+ characterChar )+ <?> "character"++ characterChar = charLetter <|> charEscape+ <?> "literal character"++ charEscape = do{ char '\\'; escapeCode }+ charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))++++ stringLiteral = lexeme (+ do{ str <- between (char '"')+ (char '"' <?> "end of string")+ (many stringChar)+ ; return (foldr (maybe id (:)) "" str)+ }+ <?> "literal string")++ stringChar = do{ c <- stringLetter; return (Just c) }+ <|> stringEscape+ <?> "string character"++ stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))++ stringEscape = do{ char '\\'+ ; do{ escapeGap ; return Nothing }+ <|> do{ escapeEmpty; return Nothing }+ <|> do{ esc <- escapeCode; return (Just esc) }+ }++ escapeEmpty = char '&'+ escapeGap = do{ many1 space+ ; char '\\' <?> "end of string gap"+ }++++ -- escape codes+ escapeCode = charEsc <|> charNum <|> charAscii <|> charControl+ <?> "escape code"++ charControl = do{ char '^'+ ; code <- upper+ ; return (toEnum (fromEnum code - fromEnum 'A'))+ }++ charNum = do{ code <- decimal+ <|> do{ char 'o'; number 8 octDigit }+ <|> do{ char 'x'; number 16 hexDigit }+ ; return (toEnum (fromInteger code))+ }++ charEsc = choice (map parseEsc escMap)+ where+ parseEsc (c,code) = do{ char c; return code }++ charAscii = choice (map parseAscii asciiMap)+ where+ parseAscii (asc,code) = try (do{ string asc; return code })+++ -- escape code tables+ escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")+ asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)++ ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",+ "FS","GS","RS","US","SP"]+ ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",+ "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",+ "CAN","SUB","ESC","DEL"]++ ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',+ '\EM','\FS','\GS','\RS','\US','\SP']+ ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',+ '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',+ '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']+++ -----------------------------------------------------------+ -- Numbers+ -----------------------------------------------------------+ naturalOrFloat = lexeme (natFloat) <?> "number"++ float = lexeme floating <?> "float"+ integer = lexeme int <?> "integer"+ natural = lexeme nat <?> "natural"+++ -- floats+ floating = do{ n <- decimal+ ; fractExponent n+ }+++ natFloat = do{ char '0'+ ; zeroNumFloat+ }+ <|> decimalFloat++ zeroNumFloat = do{ n <- hexadecimal <|> octal+ ; return (Left n)+ }+ <|> decimalFloat+ <|> fractFloat 0+ <|> return (Left 0)++ decimalFloat = do{ n <- decimal+ ; option (Left n)+ (fractFloat n)+ }++ fractFloat n = do{ f <- fractExponent n+ ; return (Right f)+ }++ fractExponent n = do{ fract <- fraction+ ; expo <- option 1.0 exponent'+ ; return ((fromInteger n + fract)*expo)+ }+ <|>+ do{ expo <- exponent'+ ; return ((fromInteger n)*expo)+ }++ fraction = do{ char '.'+ ; digits <- many1 digit <?> "fraction"+ ; return (foldr op 0.0 digits)+ }+ <?> "fraction"+ where+ op d f = (f + fromIntegral (digitToInt d))/10.0++ exponent' = do{ oneOf "eE"+ ; f <- sign+ ; e <- decimal <?> "exponent"+ ; return (power (f e))+ }+ <?> "exponent"+ where+ power e | e < 0 = 1.0/power(-e)+ | otherwise = fromInteger (10^e)+++ -- integers and naturals+ int = do{ f <- lexeme sign+ ; n <- nat+ ; return (f n)+ }++ sign = (char '-' >> return negate)+ <|> (char '+' >> return id)+ <|> return id++ nat = zeroNumber <|> decimal++ zeroNumber = do{ char '0'+ ; hexadecimal <|> octal <|> decimal <|> return 0+ }+ <?> ""++ decimal = number 10 digit+ hexadecimal = do{ oneOf "xX"; number 16 hexDigit }+ octal = do{ oneOf "oO"; number 8 octDigit }++ number base baseDigit+ = do{ digits <- many1 baseDigit+ ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits+ ; seq n (return n)+ }++ -----------------------------------------------------------+ -- Operators & reserved ops+ -----------------------------------------------------------+ reservedOp name =+ lexeme $ try $+ do{ string name+ ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)+ }++ operator =+ lexeme $ try $+ do{ name <- oper+ ; if (isReservedOp name)+ then unexpected ("reserved operator " ++ show name)+ else return name+ }++ oper =+ do{ c <- (opStart languageDef)+ ; cs <- many (opLetter languageDef)+ ; return (c:cs)+ }+ <?> "operator"++ isReservedOp name =+ isReserved (sort (reservedOpNames languageDef)) name+++ -----------------------------------------------------------+ -- Identifiers & Reserved words+ -----------------------------------------------------------+ reserved name =+ lexeme $ try $+ do{ caseString name+ ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)+ }++ caseString name+ | caseSensitive languageDef = string name+ | otherwise = do{ walk name; return name }+ where+ walk [] = return ()+ walk (c:cs) = do{ caseChar c <?> msg; walk cs }++ caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c)+ | otherwise = char c++ msg = show name+++ identifier =+ lexeme $ try $+ do{ name <- ident+ ; if (isReservedName name)+ then unexpected ("reserved word " ++ show name)+ else return name+ }+++ ident+ = do{ c <- identStart languageDef+ ; cs <- many (identLetter languageDef)+ ; return (c:cs)+ }+ <?> "identifier"++ isReservedName name+ = isReserved theReservedNames caseName+ where+ caseName | caseSensitive languageDef = name+ | otherwise = map toLower name+++ isReserved names name+ = scan names+ where+ scan [] = False+ scan (r:rs) = case (compare r name) of+ LT -> scan rs+ EQ -> True+ GT -> False++ theReservedNames+ | caseSensitive languageDef = sort reserved+ | otherwise = sort . map (map toLower) $ reserved+ where+ reserved = reservedNames languageDef++++ -----------------------------------------------------------+ -- White space & symbols+ -----------------------------------------------------------+ symbol name+ = lexeme (string name)++ lexeme p+ = do{ x <- p; whiteSpace; return x }+++ --whiteSpace+ whiteSpace+ | noLine && noMulti = skipMany (simpleSpace <?> "")+ | noLine = skipMany (simpleSpace <|> multiLineComment <?> "")+ | noMulti = skipMany (simpleSpace <|> oneLineComment <?> "")+ | otherwise = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")+ where+ noLine = null (commentLine languageDef)+ noMulti = null (commentStart languageDef)+++ simpleSpace =+ skipMany1 (satisfy (== ' '))+ --skipMany1 (satisfy isSpace)++ oneLineComment =+ do{ try (string (commentLine languageDef))+ ; skipMany (satisfy (/= '\n'))+ ; return ()+ }++ multiLineComment =+ do { try (string (commentStart languageDef))+ ; inComment+ }++ inComment+ | nestedComments languageDef = inCommentMulti+ | otherwise = inCommentSingle++ inCommentMulti+ = do{ try (string (commentEnd languageDef)) ; return () }+ <|> do{ multiLineComment ; inCommentMulti }+ <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti }+ <|> do{ oneOf startEnd ; inCommentMulti }+ <?> "end of comment"+ where+ startEnd = nub (commentEnd languageDef ++ commentStart languageDef)++ inCommentSingle+ = do{ try (string (commentEnd languageDef)); return () }+ <|> do{ skipMany1 (noneOf startEnd) ; inCommentSingle }+ <|> do{ oneOf startEnd ; inCommentSingle }+ <?> "end of comment"+ where+ startEnd = nub (commentEnd languageDef ++ commentStart languageDef)
+ src/Language/EWE/VM.hs view
@@ -0,0 +1,258 @@++module Language.EWE.VM where++import Language.EWE.AbsSyn+import qualified Data.List as L+import qualified Data.Maybe as M+import Control.Monad.Trans.State.Lazy+import Control.Monad.Trans.Class(lift)+import Data.Char (ord,chr)+import System.IO(hFlush, stdout)+import System.Exit(exitWith,ExitCode(..))++type Memory = [(Int,Int)]++emptyMemory :: Memory+emptyMemory = []++type PC = Int++initPC :: PC+initPC = 0++data StateVM = StVM { mem :: Memory+ , prg :: Prog+ , pc :: PC+ }++type StateVMM = StateT StateVM IO++mRef :: MRef -> Equates -> Int+mRef (MRefI i) _ = i+mRef (MRefId s) m = M.fromMaybe (error "No found") $ L.lookup s m++outMem :: Int -> Memory -> (Memory,Int)+outMem r m = M.maybe ((r,0):m, 0) (\i -> (m,i)) (L.lookup r m)++inMem :: Int -> Int -> Memory -> Memory+inMem = updateM emptyMemory++updateM :: Memory -> Int -> Int -> Memory -> Memory+updateM m r v [] = (r,v):m+updateM m r v (d@(r',_):m') = updateM (d:m) r v m'++incrPC :: StateVM -> Int+incrPC state = (pc state) + 1++ge :: StateVM -> Equates+ge = equates.prg++evalInstr :: StateVMM ()+evalInstr = do+ st <- get+ let pc' = pc st+ prg' = prg st+ (Stmt _ ci) = stms prg' !! pc'+ st' = execInstr ci st+ if (hasSideEffects ci)+ then case (ci) of+ (IRI _) -> do+ i <- lift $ readInt "Enter an integer:"+ let st'' = execIRI i ci st+ put st''+ (IWI _) -> do+ let (st'',i) = execIWI ci st+ lift $ putStrLn (show i)+ put st''+ (IRS _ _) -> do+ s <- lift $ getLine+ let st'' = execIRS s ci st+ put st''+ (IWS _) -> do+ let (st'',s) = execIWS ci st+ lift $ putStrLn s+ put st''+ (IH) -> lift $ exitWith ExitSuccess+ (IB) -> lift $ exitWith ExitSuccess+ else put st'++execInstr :: Instr -> StateVM -> StateVM+execInstr (INI) state =+ state { pc = incrPC state }+execInstr (IMMI mr i) state =+ state { mem = inMem (mRef mr (ge state)) i (mem state)+ , pc = incrPC state+ }+execInstr (IMMS mr s) state =+ state { mem = inMem (mRef mr (ge state)) (mRef (MRefId s) (ge state)) (mem state)+ , pc = incrPC state+ }+execInstr (IMRPC mr i) state =+ state { mem = inMem (mRef mr (ge state)) ((pc state) + i) (mem state)+ , pc = incrPC state+ }+execInstr (SPC mr) state =+ state { pc = (mRef mr (ge state))+ }+execInstr (IMMM mr1 mr2) state =+ let m = mem state+ ge' = ge state+ (m', v) = outMem (mRef mr2 ge') m+ in state { mem = inMem (mRef mr1 ge') v m'+ , pc = incrPC state+ }+execInstr (IAdd mrr mra mrb) state = comp (+) mrr mra mrb state+execInstr (ISub mrr mra mrb) state = comp (-) mrr mra mrb state+execInstr (IMul mrr mra mrb) state = comp (*) mrr mra mrb state+execInstr (IDiv mrr mra mrb) state = comp (div) mrr mra mrb state+execInstr (IMod mrr mra mrb) state = comp (mod) mrr mra mrb state+execInstr (IMRI mrr mr i) state =+ let m = mem state+ ge' = ge state+ (m',v) = outMem (mRef mr ge') m+ (m'', v')= outMem (v + i) m'+ in state { mem = inMem (mRef mrr ge') v' m''+ , pc = incrPC state+ }+execInstr (IMMR mri i mr) state =+ let m = mem state+ ge' = ge state+ (m', v) = outMem (mRef mr ge') m+ (m'', v') = outMem (mRef mri ge') m'+ in state { mem = inMem (v' + i) v m''+ , pc = incrPC state+ }+execInstr (IGI i) state =+ let prg' = prg state+ stms' = stms prg'+ l' = length stms'+ in state { pc = if (i >= 0 && i < l')+ then i else error "Inst Pos not valid"+ }+execInstr (IGS s) state =+ let prg' = prg state+ stms' = stms prg'+ i = lookupLabel s stms'+ in state { pc = i }+execInstr (IFI mra cond mrb i) state =+ let m = mem state+ pc' = pc state+ ge' = ge state+ prg' = prg state+ stms' = stms prg'+ l' = length stms'+ (m',a) = outMem (mRef mra ge') m+ (m'',b) = outMem (mRef mra ge') m'+ op = fun cond+ i' = if (i >= 0 && i < l')+ then i else error "Inst Pos not valid in condition"+ npc = if a `op` b then i' else pc' + 1+ in state { mem = m''+ , pc = npc+ }+execInstr (IFS mra cond mrb s) state =+ let m = mem state+ pc' = pc state+ ge' = ge state+ prg' = prg state+ stms' = stms prg'+ l' = length stms'+ (m',a) = outMem (mRef mra ge') m+ (m'',b) = outMem (mRef mra ge') m'+ op = fun cond+ i = lookupLabel s stms'+ npc = if a `op` b then i else pc' + 1+ in state { mem = m''+ , pc = npc+ }++execIRI :: Int -> Instr -> StateVM -> StateVM+execIRI i (IRI mr) state =+ state { mem = inMem (mRef mr (ge state)) i (mem state)+ , pc = incrPC state+ }++execIWI :: Instr -> StateVM -> (StateVM, Int)+execIWI (IWI mr ) state =+ let m = mem state+ ge' = ge state+ (m', v) = outMem (mRef mr ge') m+ in (state { mem = m', pc = incrPC state}, v)++execIRS :: String -> Instr -> StateVM -> StateVM+execIRS s (IRS mr1 mr2) state =+ let ge' = ge state+ startP = mRef mr1 ge'+ endP = mRef mr1 ge'+ state' = moveStrInMem s startP endP state+ in if (startP <= endP)+ then state' { pc = incrPC state }+ else error "IRS start > end"++moveStrInMem :: String -> Int -> Int -> StateVM -> StateVM+moveStrInMem [] st en state+ | st <= en = moveStrInMem [] (st+1) en (state { mem = inMem st 0 (mem state) })+ | otherwise = state+moveStrInMem (c:cs) st en state+ | st <= en = moveStrInMem cs (st+1) en (state { mem = inMem st (ord c) (mem state) })+ | otherwise = state++execIWS :: Instr -> StateVM -> (StateVM, String)+execIWS (IWS mr) state =+ let ge' = ge state+ start = mRef mr ge'+ (state', s) = moveStrOutMem start [] state+ in (state' {pc = incrPC state }, s)++moveStrOutMem :: Int -> String -> StateVM -> (StateVM, String)+moveStrOutMem i s state =+ let ge' = ge state+ m = mem state+ (m',v) = outMem i m+ in if (v /= 0)+ then moveStrOutMem (i+1) (s++[chr(v)]) (state { mem = m'})+ else (state, s)++lookupLabel :: String -> Stmts -> Int+lookupLabel = lookupLabel' 0++lookupLabel' :: Int -> String -> Stmts -> Int+lookupLabel' n s [] = error "Label not found"+lookupLabel' n s ((Stmt [] _):stms) = lookupLabel' (n+1) s stms+lookupLabel' n s ((Stmt lbls _):stms)+ | s `elem` lbls = n+ | otherwise = lookupLabel' (n+1) s stms++fun :: Cond -> (Int -> Int -> Bool)+fun CLET = (<=)+fun CLT = (<)+fun CGET = (>=)+fun CGT = (>)+fun CE = (==)+fun CNE = (/=)++-- comp computes the functions that transform int values+comp :: (Int -> Int -> Int) -> MRef -> MRef -> MRef -> StateVM -> StateVM+comp f mrr mra mrb state =+ let m = mem state+ ge' = ge state+ (m', a) = outMem (mRef mra ge') m+ (m'', b) = outMem (mRef mrb ge') m'+ in state { mem = inMem (mRef mrr ge') (a `f` b) m''+ , pc = incrPC state+ }++hasSideEffects :: Instr -> Bool+hasSideEffects (IRI _) = True+hasSideEffects (IWI _) = True+hasSideEffects (IRS _ _) = True+hasSideEffects (IWS _) = True+hasSideEffects (IH) = True+hasSideEffects (IB) = True+hasSideEffects _ = False++readInt :: String -> IO Int+readInt msg = do+ putStr (msg ++ "> ")+ hFlush stdout+ readLn
+ src/Main.hs view
@@ -0,0 +1,50 @@+module Main where++import Paths_ewe (version)+import System.Environment(getArgs)+import System.IO(openFile, hClose, IOMode(..), hGetContents, stdin, stdout+ ,stderr, hPutStr, hPutStrLn)+import System.Exit(ExitCode(..),exitSuccess)+import Data.Version(Version(..), showVersion)+import System.Console.GetOpt+import Data.Maybe(fromMaybe)+import Language.EWE.Parser+import Language.EWE.AbsSyn+import Language.EWE.VM++data Flag = EweVersion deriving Show++options :: [OptDescr Flag]+options =+ [ Option ['V','?'] ["version"] (NoArg EweVersion) "show version number"+ ]++compilerOpts :: [String] -> IO ([Flag], [String])+compilerOpts argv =+ case getOpt Permute options argv of+ (o,n,[]) -> return (o,n)+ (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))+ where header = "Usage: ewe [OPTION...] files..."++processFile :: FilePath -> IO ()+processFile fp = do+ hPutStr stdout $ "Processing file: " ++ fp+ fh <- openFile fp ReadMode+ s <- hGetContents fh+ let pRes = pEWE s fp+ case pRes of+ Left err -> hPutStrLn stderr $ " Parsing error at " ++ (show err)+ Right prog -> hPutStrLn stdout $ " is Ok"+ hClose fh++processFlags :: [Flag] -> IO ()+processFlags = mapM_ processFlag++processFlag :: Flag -> IO ()+processFlag EweVersion = (hPutStrLn stdout $ "ewe version: " ++ (showVersion version)) >> exitSuccess+ +main :: IO ()+main = do+ (flgs, fls) <- (getArgs >>= compilerOpts)+ processFlags flgs+ mapM_ processFile fls