diff --git a/LICENSE.txt b/LICENSE.txt --- a/LICENSE.txt +++ b/LICENSE.txt @@ -1,4 +1,4 @@ -Copyright (c) 2009, Lyle Kopnicky +Copyright (c) 2009-2017, Lyle Kopnicky All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.txt b/README.txt --- a/README.txt +++ b/README.txt @@ -1,15 +1,27 @@ To compile: -runhaskell Setup.hs configure -runhaskell Setup.hs build +cabal configure +cabal build +...or with stack: + +stack build + To run unit tests: -runhaskell Setup.hs test +cabal test +..or with stack: + +stack test + To install: -runhaskell Setup.hs install +cabal install + +...or with stack: + +stack install You can then run the resulting program as diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,16 +0,0 @@ -#!/usr/local/bin/runhaskell - -import Distribution.Simple -import Distribution.PackageDescription (PackageDescription) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) -import System.Cmd (system) -import Distribution.Simple.LocalBuildInfo -import System.Directory (removeFile) - -main = defaultMainWithHooks (simpleUserHooks {runTests = runAllTests}) - -runAllTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () -runAllTests a b pd lb = do - system "runhaskell run_tests.hs" - removeFile "test_driver.hs" - return () diff --git a/doc/Vintage_BASIC_Developer_Notes.html b/doc/Vintage_BASIC_Developer_Notes.html --- a/doc/Vintage_BASIC_Developer_Notes.html +++ b/doc/Vintage_BASIC_Developer_Notes.html @@ -1,6 +1,6 @@ Vintage BASIC Developer Notes -

Vintage BASIC Developer Notes 1.0.1

© 2009, Lyle Kopnicky

I began Vintage BASIC as a class project at the Oregon Graduate +

Vintage BASIC Developer Notes 1.0.3

© 2009—2017, Lyle Kopnicky

I began Vintage BASIC as a class project at the Oregon Graduate Institute. My aim was to demonstrate advanced knowledge of monads in Haskell. It occurred to me that BASIC's dynamic control structures would be @@ -37,4 +37,4 @@ tests rather than unit tests. They test the interpretation of the BASIC language straight from the textual source. However they are still unit tests in the sense that they are focused on exercising the behavior of -the interpreter proper.

The tests are arranged in a hierarchical directory structure parallel to the implementation: in the test directory rather than src. They are executed by a harness called run_tests.hs in the root directory. This custom-written script finds all of the modules named ending in _test, and the functions within those modules starting with test_. It builds a driver program that calls all the tests, and executes it.

The tests can be run by calling runhaskell run_tests.hs, or preferably via runhaskell Setup.hs test.

+the interpreter proper.

The tests are arranged in a hierarchical directory structure parallel to the implementation: in the test directory rather than src. They are executed by a harness called run_tests.hs in the root directory. This custom-written script finds all of the modules named ending in _test, and the functions within those modules starting with test_. It builds a driver program that calls all the tests, and executes it.

The tests can be run by calling cabal test, or if you have stack installed, then via stack test.

diff --git a/doc/Vintage_BASIC_Users_Guide.html b/doc/Vintage_BASIC_Users_Guide.html --- a/doc/Vintage_BASIC_Users_Guide.html +++ b/doc/Vintage_BASIC_Users_Guide.html @@ -1,11 +1,11 @@ - + Vintage BASIC User's Guide -

Vintage BASIC User's Guide 1.0.1

-

© 2009, Lyle +

Vintage BASIC User's Guide 1.0.3

+

© 2009–2017, Lyle Kopnicky

Congratulations on installing Vintage BASIC! You are now the proud owner of a copy of a versatile tool for BASIC development.

@@ -59,39 +59,23 @@

System Requirements and Installation

-

Vintage BASIC requires minimal resources, and will run on any -platform with available Haskell compiler. The recommended compiler is GHC. You can -also download some pre-compiled binaries on the web site, vintage-basic.net.

-

Installation of binary version

-For Windows, you can simply download vintbas.exe, -and put it it somewhere in your path. For other systems, consult the download page.
-

Installation from source

-

You can download the source code tarball,  vintage-basic-1.0.1.tar.gz, from -either vintage-basic.net -or Hackage.

-

You should first unpack the tarball using -a tool such as tar, 7-Zip or WinZip. Then open a -shell/console in -the vintage-basic-1.0.1 directory, and type: -http://hackage.haskell.org/packages/archive/armada/0.1/armada-0.1.tar.gz
-
-  runhaskell Setup.hs configure
-  runhaskell Setup.hs build

-

The executable will be generated in dist/build/vintbas/vintbas -on Mac/Linux, or dist\build\vintbas\vintbas.exe -on Windows. You can then move this executable anywhere in your path to -run it. Or, use

-

  runhaskell Setup.hs install

-

See the Cabal -package installation instructions for more details.
-

+

Vintage BASIC requires minimal resources, and will run on Windows, Mac, and Linux. +(It can be compiled from source to run on these or other platforms, too.) +Please see the downloads page +for installation instructions.

Running Vintage BASIC

-

The interpreter consists of one command-line tool, vintbas. +

From the command line

+

The interpreter consists of one command-line tool, vintbas. It takes one filename parameter, the name of a BASIC source file. By convention (but not fiat), it should end in .bas. So, if you've written BASIC code and saved it in miracle.bas, you'd run it by typing vintbas miracle.bas.

+

On Windows

+

If you have used the Windows installer, you can open Vintage BASIC using the +Vintage BASIC Prompt item in the Vintage BASIC folder on the Start Menu. Or, you +can just open Command Prompt. If you have a BASIC program saved with a .bas +extension, you can double-click on it in Explorer to run it.

BASIC Program Lines

Each line in your BASIC source file should start with a BASIC @@ -122,7 +106,7 @@

BASIC Syntax

Each line of BASIC consists of a series of statements, separated by -semicolons. Statements are executed in order, unless an error or +colons. Statements are executed in order, unless an error or control flow statement is encountered.

BASIC keywords are not case sensitive. You may freely use @@ -748,4 +732,4 @@

The wrong number of arguments were passed to the builtin or user-defined function.
- + diff --git a/run_tests.hs b/run_tests.hs --- a/run_tests.hs +++ b/run_tests.hs @@ -3,8 +3,8 @@ import Data.Array ((!)) import Data.List (intersperse) import Data.Maybe (catMaybes) -import System.Cmd (system) -import System.Directory (doesDirectoryExist,getCurrentDirectory,getDirectoryContents) +import System.Process (system) +import System.Directory (doesDirectoryExist,getCurrentDirectory,getDirectoryContents,removeFile) import System.FilePath (()) import System.Environment (getArgs) import Text.Regex.Base @@ -32,6 +32,7 @@ let testCode = genTestDriver modulesWithTests writeFile "test_driver.hs" testCode system ("runhaskell -itest -isrc test_driver.hs") + removeFile "test_driver.hs" findFilesInSubdirs :: FilePath -> IO [String] findFilesInSubdirs dir = do diff --git a/src/Control/Monad/CPST.hs b/src/Control/Monad/CPST.hs --- a/src/Control/Monad/CPST.hs +++ b/src/Control/Monad/CPST.hs @@ -10,18 +10,35 @@ import Control.Monad.Reader import Control.Monad.State -import Control.Monad.Trans -- | Definition of the CPST (continuation-passing style) monad. -newtype Monad m => CPST o m i = +newtype CPST o m i = + -- o is the type of the ultimate output + -- m is the nested monad + -- i is the type of the intermediate result of this step CPST { unCPST :: (i -> m o) -> m o } -instance (Monad m) => Functor (CPST o m) where - fmap f (CPST m') = CPST (\k -> m' (k . f)) +instance Functor (CPST o m) where + -- (a -> b) -> CPST o m a -> CPST o m b + -- mx :: (a -> m o) -> m o + -- k :: b -> m o + -- f :: a -> b + -- k . f :: a -> m o + fmap f (CPST mx) = CPST (\k -> mx (k . f)) -instance Monad m => Monad (CPST o m) where +instance Applicative (CPST o m) where + pure x = CPST (\k -> k x) + -- CPST o m (a -> b) -> CPST o m a -> CPST o m b + -- mf :: ((a -> b) -> m o) -> m o + -- mx :: (a -> m o) -> m o + -- k :: b -> m o + -- f :: a -> b + -- x :: a + (CPST mf) <*> (CPST mx) = CPST (\k -> mf (\f -> mx (\x -> k (f x)))) + +instance Monad (CPST o m) where return x = CPST (\k -> k x) - (CPST m') >>= f = CPST (\k -> m' (\x -> unCPST (f x) k)) + (CPST mx) >>= f = CPST (\k -> mx (\x -> unCPST (f x) k)) -- The basic monad utilities: runCPST, lift, liftIO diff --git a/src/Control/Monad/CPST/DurableTraps.hs b/src/Control/Monad/CPST/DurableTraps.hs --- a/src/Control/Monad/CPST/DurableTraps.hs +++ b/src/Control/Monad/CPST/DurableTraps.hs @@ -4,7 +4,6 @@ module Control.Monad.CPST.DurableTraps where -import Control.Monad import Control.Monad.CPST import Control.Monad.CPST.ExceptionHandlers(capture,install,raise) diff --git a/src/Control/Monad/CPST/ExceptionHandlers.hs b/src/Control/Monad/CPST/ExceptionHandlers.hs --- a/src/Control/Monad/CPST/ExceptionHandlers.hs +++ b/src/Control/Monad/CPST/ExceptionHandlers.hs @@ -3,7 +3,6 @@ module Control.Monad.CPST.ExceptionHandlers where -import Control.Monad import Control.Monad.CPST -- The inward (catching) exception handlers -- diff --git a/src/Language/VintageBasic/BasicMonad.hs b/src/Language/VintageBasic/BasicMonad.hs --- a/src/Language/VintageBasic/BasicMonad.hs +++ b/src/Language/VintageBasic/BasicMonad.hs @@ -9,15 +9,13 @@ import Control.Monad.CPST import Control.Monad.CPST.DurableTraps import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Trans -import Data.HashTable +import Control.Monad.State (StateT, runStateT, get, put, modify) +import Data.HashTable.IO import Data.IORef import Data.Array.IO import Data.Maybe import Data.Time import IO.IOStream -import Language.VintageBasic.Printer(printVarName) import Language.VintageBasic.Result import Language.VintageBasic.Syntax import System.Random @@ -39,11 +37,11 @@ -- | The store of BASIC variables. data BasicStore = BasicStore { - scalarTable :: HashTable VarName (IORef Val), + scalarTable :: BasicHashTable VarName (IORef Val), -- ^ scalar variable assignments - arrayTable :: HashTable VarName ([Int], IOArray Int Val), + arrayTable :: BasicHashTable VarName ([Int], IOArray Int Val), -- ^ array variable values (@[Int]@ lists the bound of each dimension) - fnTable :: HashTable VarName (IORef ([Val] -> Code Val)) + fnTable :: BasicHashTable VarName (IORef ([Val] -> Code Val)) -- ^ user-defined function (@DEF FN@) definitions } @@ -90,12 +88,12 @@ -> IO () runProgram inputHandle outputHandle prog = do vFlush outputHandle - st <- new (==) (hashString . printVarName) - at <- new (==) (hashString . printVarName) - ft <- new (==) (hashString . printVarName) + st <- new + at <- new + ft <- new let store = BasicStore st at ft let state = (BasicState inputHandle outputHandle 0 0 0 (mkStdGen 0) []) - runStateT (runReaderT (runCPST (catchC errorDumper prog)) store) state + _ <- runStateT (runReaderT (runCPST (catchC errorDumper prog)) store) state return () -- | Raises a runtime error if the assertion is False. diff --git a/src/Language/VintageBasic/FloatParser.hs b/src/Language/VintageBasic/FloatParser.hs --- a/src/Language/VintageBasic/FloatParser.hs +++ b/src/Language/VintageBasic/FloatParser.hs @@ -32,7 +32,7 @@ float2P :: GenParser tok st String float2P = do i <- many digitP - dotP + _ <- dotP f <- many digitP return ("0"++i++"."++f++"0") @@ -43,7 +43,7 @@ expP :: GenParser tok st String expP = do - charEP + _ <- charEP esgn <- option "" sgnP i <- many1 digitP return ("E"++esgn++i) diff --git a/src/Language/VintageBasic/Interpreter.hs b/src/Language/VintageBasic/Interpreter.hs --- a/src/Language/VintageBasic/Interpreter.hs +++ b/src/Language/VintageBasic/Interpreter.hs @@ -303,7 +303,7 @@ setVar var val interpS _ (PrintS xs) = do - mapM (\x -> eval x >>= printVal) xs + _ <- mapM (\x -> eval x >>= printVal) xs if null xs || not (isPrintSeparator (last xs)) then printString "\n" else return () @@ -361,7 +361,7 @@ interpS jumpTable (GosubS lab) = do let maybeCode = programLookup jumpTable lab assert (isJust maybeCode) (BadGosubTargetError lab) - catchC gosubHandler (fromJust maybeCode) + _ <- catchC gosubHandler (fromJust maybeCode) return () interpS _ ReturnS = raiseRuntimeException Return @@ -494,7 +494,7 @@ is <- checkArrInds inds -- add 1, so that range is from 0 to user-specified bound let bounds = map (1+) is - dimArray vn bounds + _ <- dimArray vn bounds return () checkArrInds :: [Val] -> Basic (BasicExcep Result ()) [Int] diff --git a/src/Language/VintageBasic/LineScanner.hs b/src/Language/VintageBasic/LineScanner.hs --- a/src/Language/VintageBasic/LineScanner.hs +++ b/src/Language/VintageBasic/LineScanner.hs @@ -10,12 +10,12 @@ eol :: Parser Char eol = do - optionally (char '\r') + _ <- optionally (char '\r') newline blankLineP :: Parser () blankLineP = do - eol "" + _ <- eol "" whiteSpace rawLineP :: Parser RawLine @@ -25,14 +25,14 @@ pos <- getPosition s <- manyTill (anyChar "CHARACTER") (eol "END OF LINE") whiteSpace - many blankLineP + _ <- many blankLineP return (Tagged (setSourceLine pos n) s) rawLinesP :: Parser [RawLine] rawLinesP = do whiteSpace - many blankLineP + _ <- many blankLineP ls <- many rawLineP - many blankLineP + _ <- many blankLineP eof "END OF FILE" return ls diff --git a/src/Language/VintageBasic/Parser.hs b/src/Language/VintageBasic/Parser.hs --- a/src/Language/VintageBasic/Parser.hs +++ b/src/Language/VintageBasic/Parser.hs @@ -62,13 +62,13 @@ intVarNameP :: TokParser VarName intVarNameP = do name <- varBaseP - tokenP (==PercentTok) + _ <- tokenP (==PercentTok) return (VarName IntType name) stringVarNameP :: TokParser VarName stringVarNameP = do name <- varBaseP - tokenP (==DollarTok) + _ <- tokenP (==DollarTok) return (VarName StringType name) -- Look for string and int vars first because of $ and % suffixes. @@ -114,23 +114,23 @@ argsP :: TokParser [Expr] argsP = - do tokenP (==LParenTok) + do _ <- tokenP (==LParenTok) xs <- sepBy exprP (tokenP (==CommaTok)) - tokenP (==RParenTok) + _ <- tokenP (==RParenTok) return xs fnXP :: TokParser Expr fnXP = do - tokenP (==FnTok) + _ <- tokenP (==FnTok) vn <- varNameP args <- argsP return (FnX vn args) parenXP :: TokParser Expr parenXP = - do tokenP (==LParenTok) + do _ <- tokenP (==LParenTok) x <- exprP - tokenP (==RParenTok) + _ <- tokenP (==RParenTok) return (ParenX x) primXP :: TokParser Expr @@ -151,10 +151,10 @@ binary :: Token -> (Expr -> Expr -> Expr) -> Assoc -> Operator (Tagged Token) () Expr binary tok fun assoc = - Infix (do tokenP (==tok); return fun) assoc + Infix (do _ <- tokenP (==tok); return fun) assoc prefix :: Token -> (Expr -> Expr) -> Operator (Tagged Token) () Expr prefix tok fun = - Prefix (do tokenP (==tok); return fun) + Prefix (do _ <- tokenP (==tok); return fun) -- | Parses a BASIC expression from tokenized source. exprP :: TokParser Expr @@ -164,52 +164,52 @@ letSP :: TokParser Statement letSP = do - optionally (tokenP (==LetTok)) + _ <- optionally (tokenP (==LetTok)) v <- varP - tokenP (==EqTok) + _ <- tokenP (==EqTok) x <- exprP return (LetS v x) gotoSP :: TokParser Statement gotoSP = do - try (tokenP (==GoTok) >> tokenP (==ToTok)) + _ <- try (tokenP (==GoTok) >> tokenP (==ToTok)) n <- lineNumP return (GotoS n) gosubSP :: TokParser Statement gosubSP = do - try (tokenP (==GoTok) >> tokenP (==SubTok)) + _ <- try (tokenP (==GoTok) >> tokenP (==SubTok)) n <- lineNumP return (GosubS n) returnSP :: TokParser Statement returnSP = - do tokenP (==ReturnTok) + do _ <- tokenP (==ReturnTok) return ReturnS onGotoSP :: TokParser Statement onGotoSP = try $ do - tokenP (==OnTok) + _ <- tokenP (==OnTok) x <- exprP - tokenP (==GoTok) - tokenP (==ToTok) + _ <- tokenP (==GoTok) + _ <- tokenP (==ToTok) ns <- sepBy1 lineNumP (tokenP (==CommaTok)) return (OnGotoS x ns) onGosubSP :: TokParser Statement onGosubSP = try $ do - tokenP (==OnTok) + _ <- tokenP (==OnTok) x <- exprP - tokenP (==GoTok) - tokenP (==SubTok) + _ <- tokenP (==GoTok) + _ <- tokenP (==SubTok) ns <- sepBy1 lineNumP (tokenP (==CommaTok)) return (OnGosubS x ns) ifSP :: TokParser Statement ifSP = - do tokenP (==IfTok) + do _ <- tokenP (==IfTok) x <- exprP - tokenP (==ThenTok) + _ <- tokenP (==ThenTok) target <- try ifSPGoto <|> statementListP return (IfS x target) @@ -221,11 +221,11 @@ forSP :: TokParser Statement forSP = do - tokenP (==ForTok) + _ <- tokenP (==ForTok) vn <- varNameP - tokenP (==EqTok) + _ <- tokenP (==EqTok) x1 <- exprP - tokenP (==ToTok) + _ <- tokenP (==ToTok) x2 <- exprP x3 <- option (LitX (FloatLit 1)) (tokenP (==StepTok) >> exprP) return (ForS vn x1 x2 x3) @@ -233,7 +233,7 @@ -- | Parses a @NEXT@ and an optional variable list. nextSP :: TokParser Statement nextSP = do - tokenP (==NextTok) + _ <- tokenP (==NextTok) vns <- sepBy varNameP (tokenP (==CommaTok)) if length vns > 0 then return (NextS (Just vns)) @@ -241,7 +241,7 @@ printSP :: TokParser Statement printSP = - do tokenP (==PrintTok) + do _ <- tokenP (==PrintTok) xs <- many printExprP return (PrintS xs) @@ -250,17 +250,17 @@ emptySeparatorP :: TokParser Expr emptySeparatorP = do - tokenP (==SemiTok) + _ <- tokenP (==SemiTok) return EmptySeparatorX nextZoneP :: TokParser Expr nextZoneP = do - tokenP (==CommaTok) + _ <- tokenP (==CommaTok) return NextZoneX inputSP :: TokParser Statement inputSP = - do tokenP (==InputTok) + do _ <- tokenP (==InputTok) ps <- option Nothing inputPrompt vs <- sepBy1 varP (tokenP (==CommaTok)) return (InputS ps vs) @@ -268,17 +268,17 @@ inputPrompt :: TokParser (Maybe String) inputPrompt = do (StringLit p) <- stringLitP - tokenP (==SemiTok) + _ <- tokenP (==SemiTok) return (Just p) endSP :: TokParser Statement endSP = - do tokenP (==EndTok) + do _ <- tokenP (==EndTok) return EndS stopSP :: TokParser Statement stopSP = - do tokenP (==StopTok) + do _ <- tokenP (==StopTok) return StopS arrDeclP :: TokParser (VarName, [Expr]) @@ -290,7 +290,7 @@ dimSP :: TokParser Statement dimSP = do - tokenP (==DimTok) + _ <- tokenP (==DimTok) arrDecls <- sepBy1 arrDeclP (tokenP (==CommaTok)) return (DimS arrDecls) @@ -301,13 +301,13 @@ readSP :: TokParser Statement readSP = do - tokenP (==ReadTok) + _ <- tokenP (==ReadTok) vs <- sepBy1 varP (tokenP (==CommaTok)) return (ReadS vs) restoreSP :: TokParser Statement restoreSP = do - tokenP (==RestoreTok) + _ <- tokenP (==RestoreTok) maybeLineNum <- optionally lineNumP return (RestoreS maybeLineNum) @@ -318,13 +318,13 @@ defFnSP :: TokParser Statement defFnSP = do - tokenP (==DefTok) - tokenP (==FnTok) + _ <- tokenP (==DefTok) + _ <- tokenP (==FnTok) name <- varNameP - tokenP (==LParenTok) + _ <- tokenP (==LParenTok) params <- sepBy1 varNameP (tokenP (==CommaTok)) - tokenP (==RParenTok) - tokenP (==EqTok) + _ <- tokenP (==RParenTok) + _ <- tokenP (==EqTok) expr <- exprP return (DefFnS name params expr) @@ -345,7 +345,7 @@ -- | Parses a list of statements from a tokenized BASIC source line. statementListP :: TokParser [Tagged Statement] statementListP = do - many (tokenP (==ColonTok)) + _ <- many (tokenP (==ColonTok)) sl <- sepEndBy1 statementP (many1 (tokenP (==ColonTok))) eol ": OR END OF LINE" return sl diff --git a/src/Language/VintageBasic/RuntimeParser.hs b/src/Language/VintageBasic/RuntimeParser.hs --- a/src/Language/VintageBasic/RuntimeParser.hs +++ b/src/Language/VintageBasic/RuntimeParser.hs @@ -17,7 +17,7 @@ stringP :: Parser String stringP = - do char '"' + do _ <- char '"' s <- manyTill anyChar (char '"') spaces return s diff --git a/src/Language/VintageBasic/Syntax.hs b/src/Language/VintageBasic/Syntax.hs --- a/src/Language/VintageBasic/Syntax.hs +++ b/src/Language/VintageBasic/Syntax.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} + -- | Describes the abstract syntax of BASIC. module Language.VintageBasic.Syntax where import Language.VintageBasic.Builtins(Builtin) import Language.VintageBasic.LexCommon(Tagged(..)) +import GHC.Generics (Generic) +import Data.Hashable -- | A BASIC line number. type Label = Int @@ -11,7 +15,7 @@ -- | BASIC value types. The IntType is used for storage or function arguments -- but is always converted to FloatType for use in expressions. data ValType = FloatType | IntType | StringType - deriving (Show,Eq) + deriving (Show,Eq,Generic,Hashable) class Typeable a where typeOf :: a -> ValType @@ -29,7 +33,7 @@ typeOf (StringLit _) = StringType data VarName = VarName ValType String - deriving (Show,Eq) + deriving (Show,Eq,Generic,Hashable) instance Typeable VarName where typeOf (VarName valType _) = valType diff --git a/src/Language/VintageBasic/Tokenizer.hs b/src/Language/VintageBasic/Tokenizer.hs --- a/src/Language/VintageBasic/Tokenizer.hs +++ b/src/Language/VintageBasic/Tokenizer.hs @@ -8,7 +8,7 @@ (Token(..),TokenizedLine,isDataTok,isRemTok,charTokTest,taggedCharToksToString,isStringTok, isBuiltinTok,taggedTokensP,tokenP,printToken) where -import Data.Char(toUpper) +import Data.Char(toLower,toUpper) import Language.VintageBasic.Builtins(Builtin,builtinToStrAssoc) import Language.VintageBasic.LexCommon import Text.ParserCombinators.Parsec @@ -34,13 +34,16 @@ | SpaceTok | DotTok | CharTok { getCharTokChar :: Char } deriving (Eq,Show) +caseInsensitiveChar :: Char -> Parser Char +caseInsensitiveChar c = char (toLower c) <|> char (toUpper c) + keyword :: String -> Parser String -keyword s = try (string s) ("keyword " ++ s) +keyword s = try (mapM caseInsensitiveChar s) ("keyword " ++ s) stringTokP :: Parser Token -- no special escape chars allowed stringTokP = - do char '"' + do _ <- char '"' s <- manyTill anyChar (char '"') whiteSpace return (StringTok s) @@ -50,7 +53,7 @@ isStringTok _ = False remTokP :: Parser Token -remTokP = do keyword "REM" +remTokP = do _ <- keyword "REM" s <- many anyChar return (RemTok s) @@ -60,7 +63,7 @@ dataTokP :: Parser Token dataTokP = - do keyword "DATA" + do _ <- keyword "DATA" s <- many anyChar return (DataTok s) @@ -132,7 +135,7 @@ anyTokP :: Parser Token anyTokP = choice ([spaceTokP, stringTokP, remTokP, dataTokP] - ++ [do keyword s; whiteSpace; return t | (s,t) <- strToTokAssoc] + ++ [do _ <- keyword s; whiteSpace; return t | (s,t) <- strToTokAssoc] ++ [charTokP]) "LEGAL BASIC CHARACTER" isBuiltinTok :: Token -> Bool diff --git a/test/Language/VintageBasic/Asserts.hs b/test/Language/VintageBasic/Asserts.hs --- a/test/Language/VintageBasic/Asserts.hs +++ b/test/Language/VintageBasic/Asserts.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Language.VintageBasic.Asserts where import Data.IORef diff --git a/test/Language/VintageBasic/FloatParser_test.hs b/test/Language/VintageBasic/FloatParser_test.hs --- a/test/Language/VintageBasic/FloatParser_test.hs +++ b/test/Language/VintageBasic/FloatParser_test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Language.VintageBasic.FloatParser_test where import Test.HUnit diff --git a/test/Language/VintageBasic/Interpreter_test.hs b/test/Language/VintageBasic/Interpreter_test.hs --- a/test/Language/VintageBasic/Interpreter_test.hs +++ b/test/Language/VintageBasic/Interpreter_test.hs @@ -270,7 +270,7 @@ test_rnd = testProgramOutput "1 ?RND(-1):?RND(1):?RND(1):?RND(0):?RND(10):?RND(-2.5)\n" - " .35925463 \n .3306234 \n .13648525 \n .13648525 \n .53864 \n .10321328 \n" + " .72774446 \n .6806801 \n .2628854 \n .2628854 \n .8841321 \n .2695619 \n" test_rnd_errors = testExpressions [ ("RND()", "!WRONG NUMBER OF ARGUMENTS IN LINE 1"), diff --git a/test/Language/VintageBasic/Tokenizer_test.hs b/test/Language/VintageBasic/Tokenizer_test.hs --- a/test/Language/VintageBasic/Tokenizer_test.hs +++ b/test/Language/VintageBasic/Tokenizer_test.hs @@ -1,5 +1,6 @@ module Language.VintageBasic.Tokenizer_test where +import Data.Char(toLower) import Test.HUnit import Language.VintageBasic.Asserts import Language.VintageBasic.Builtins(Builtin(..)) @@ -10,41 +11,63 @@ assertTokenizerResult = assertParseResult withCol SyntaxError taggedTokensP assertTokenizerError = assertParseError withCol SyntaxError taggedTokensP -test_taggedTokensP = TestCase $ do - let source = [ - ",:;()$%=<><=>=><+-*/^.?", - "ABSASCCHR$COSEXPINTLEFT$LENLOGMID$RIGHT$RNDSGNSINSPCSQRSTR$TABTANVAL", - "ANDORNOTLETDIMONGOSUBRETURNIFTHENFORTOSTEPNEXTPRINTINPUT", - "RANDOMIZEREADRESTOREDEFFNENDSTOP", - "\"hello\"REMGOFORTH\"ANDREAD\"", - "XDATATODATA" - ] - let expectedLenAndTokss = [ - [(1,CommaTok), (1,ColonTok), (1,SemiTok), (1,LParenTok), (1,RParenTok), - (1,DollarTok), (1,PercentTok), (1,EqTok), (2,NETok), (2,LETok), (2,GETok), - (1,GTTok), (1,LTTok), (1,PlusTok), (1,MinusTok), (1,MulTok), (1,DivTok), - (1,PowTok), (1,DotTok), (1,PrintTok)], - [(3,BuiltinTok AbsBI), (3,BuiltinTok AscBI), (4,BuiltinTok ChrBI), - (3,BuiltinTok CosBI), (3,BuiltinTok ExpBI), (3,BuiltinTok IntBI), - (5,BuiltinTok LeftBI), (3,BuiltinTok LenBI), (3,BuiltinTok LogBI), - (4,BuiltinTok MidBI), (6,BuiltinTok RightBI), (3,BuiltinTok RndBI), - (3,BuiltinTok SgnBI), (3,BuiltinTok SinBI), (3,BuiltinTok SpcBI), - (3,BuiltinTok SqrBI), (4,BuiltinTok StrBI), (3,BuiltinTok TabBI), - (3,BuiltinTok TanBI), (3,BuiltinTok ValBI)], - [(3,AndTok), (2,OrTok), (3,NotTok), (3,LetTok), (3,DimTok), (2,OnTok), - (2,GoTok), (3,SubTok), (6,ReturnTok), (2,IfTok), (4,ThenTok), (3,ForTok), - (2,ToTok), (4,StepTok), (4,NextTok), (5,PrintTok), (5,InputTok)], - [(9,RandomizeTok), (4,ReadTok), (7,RestoreTok), (3,DefTok), (2,FnTok), - (3,EndTok), (4,StopTok)], - [(7,StringTok "hello"), (19,RemTok "GOFORTH\"ANDREAD\"")], - [(1,CharTok 'X'), (10,DataTok "TODATA")] - ] - let accumLensWToks lenAndToks = - let (lens, toks) = unzip lenAndToks - cols = scanl (+) 1 lens - in zip cols toks - let expectedColAndTokss = map accumLensWToks expectedLenAndTokss - sequence_ $ zipWith assertTokenizerResult source expectedColAndTokss +tokenLengthsToPositions :: [(Int, Token)] -> [(Int, Token)] +tokenLengthsToPositions lenAndToks = + let (lens, toks) = unzip lenAndToks + cols = scanl (+) 1 lens + in zip cols toks + +test_tokenizes_punctuation = TestCase $ do + let source = ",:;()$%=<><=>=><+-*/^.?" + let expected = tokenLengthsToPositions + [(1,CommaTok), (1,ColonTok), (1,SemiTok), (1,LParenTok), (1,RParenTok), + (1,DollarTok), (1,PercentTok), (1,EqTok), (2,NETok), (2,LETok), (2,GETok), + (1,GTTok), (1,LTTok), (1,PlusTok), (1,MinusTok), (1,MulTok), (1,DivTok), + (1,PowTok), (1,DotTok), (1,PrintTok)] + assertTokenizerResult source expected + +test_tokenizes_builtins = TestCase $ do + let ucSource = "ABSASCCHR$COSEXPINTLEFT$LENLOGMID$RIGHT$RNDSGNSINSPCSQRSTR$TABTANVAL" + let lcSource = map toLower ucSource + let expected = tokenLengthsToPositions + [(3,BuiltinTok AbsBI), (3,BuiltinTok AscBI), (4,BuiltinTok ChrBI), + (3,BuiltinTok CosBI), (3,BuiltinTok ExpBI), (3,BuiltinTok IntBI), + (5,BuiltinTok LeftBI), (3,BuiltinTok LenBI), (3,BuiltinTok LogBI), + (4,BuiltinTok MidBI), (6,BuiltinTok RightBI), (3,BuiltinTok RndBI), + (3,BuiltinTok SgnBI), (3,BuiltinTok SinBI), (3,BuiltinTok SpcBI), + (3,BuiltinTok SqrBI), (4,BuiltinTok StrBI), (3,BuiltinTok TabBI), + (3,BuiltinTok TanBI), (3,BuiltinTok ValBI)] + assertTokenizerResult ucSource expected + assertTokenizerResult lcSource expected + +test_tokenizes_other = TestCase $ do + let ucSource = "ANDORNOTLETDIMONGOSUBRETURNIFTHENFORTOSTEPNEXTPRINTINPUT" + ++ "RANDOMIZEREADRESTOREDEFFNENDSTOP" + let lcSource = map toLower ucSource + let expected = tokenLengthsToPositions + [(3,AndTok), (2,OrTok), (3,NotTok), (3,LetTok), (3,DimTok), (2,OnTok), + (2,GoTok), (3,SubTok), (6,ReturnTok), (2,IfTok), (4,ThenTok), (3,ForTok), + (2,ToTok), (4,StepTok), (4,NextTok), (5,PrintTok), (5,InputTok), + (9,RandomizeTok), (4,ReadTok), (7,RestoreTok), (3,DefTok), (2,FnTok), + (3,EndTok), (4,StopTok)] + assertTokenizerResult ucSource expected + assertTokenizerResult lcSource expected + +test_tokenizes_string_and_rem = TestCase $ do + let ucSource = "\"HELLO\"REMGOFORTH\"ANDREAD\"" + let lcSource = map toLower ucSource + let ucExpected = tokenLengthsToPositions [(7,StringTok "HELLO"), (19,RemTok "GOFORTH\"ANDREAD\"")] + let lcExpected = tokenLengthsToPositions [(7,StringTok "hello"), (19,RemTok "goforth\"andread\"")] + assertTokenizerResult ucSource ucExpected + assertTokenizerResult lcSource lcExpected + +test_tokenizes_plain_char_and_data = TestCase $ do + let ucSource = "XDATATODATA" + let lcSource = map toLower ucSource + let ucExpected = tokenLengthsToPositions [(1,CharTok 'X'), (10,DataTok "TODATA")] + let lcExpected = tokenLengthsToPositions [(1,CharTok 'X'), (10,DataTok "todata")] + assertTokenizerResult ucSource ucExpected + assertTokenizerResult lcSource lcExpected test_capitalizes_lowercase_chars = TestCase $ do let source = "azAZ" diff --git a/vintage-basic.cabal b/vintage-basic.cabal --- a/vintage-basic.cabal +++ b/vintage-basic.cabal @@ -1,6 +1,6 @@ Name: vintage-basic -Version: 1.0.1 -Cabal-Version: >= 1.6 +Version: 1.0.3 +Cabal-Version: >= 1.10 Stability: experimental Synopsis: Interpreter for microcomputer-era BASIC Description: @@ -19,13 +19,15 @@ Maintainer: lyle@vintage-basic.net Homepage: http://www.vintage-basic.net Build-Type: Simple -Tested-With: GHC==6.10.1 +Tested-With: GHC==8.0.2 Extra-Source-Files: test/Language/VintageBasic/*.hs run_tests.hs examples/*.bas README.txt doc/*.html Executable vintbas Main-is: Basic.hs - Build-Depends: base >=3, + Build-Depends: base >=4.9 && <5, array >=0.1, + hashable >=1.2, + hashtables >=1.2, mtl >=1.1, parsec >=2.1, random >=1, @@ -38,3 +40,27 @@ filepath >=1.1 HS-Source-Dirs: src GHC-Options: -Wall + Default-Language: Haskell2010 + Other-Modules: Control.Monad.CPST, + Control.Monad.CPST.DurableTraps, + Control.Monad.CPST.ExceptionHandlers, + IO.IOStream, + Language.VintageBasic.BasicMonad, + Language.VintageBasic.Builtins, + Language.VintageBasic.Executer, + Language.VintageBasic.FloatParser, + Language.VintageBasic.Interpreter, + Language.VintageBasic.LexCommon, + Language.VintageBasic.LineScanner, + Language.VintageBasic.Parser, + Language.VintageBasic.Printer, + Language.VintageBasic.Result, + Language.VintageBasic.RuntimeParser, + Language.VintageBasic.Syntax, + Language.VintageBasic.Tokenizer + +Test-Suite test-vintbas + type: exitcode-stdio-1.0 + main-is: run_tests.hs + build-depends: base + default-language: Haskell2010