hmumps (empty) → 0.1
raw patch · 15 files changed
+3036/−0 lines, 15 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, haskeline, haskell98, mtl, parsec, regex-compat, syb, text
Files
- Data/MArray.hs +101/−0
- Data/MValue.hs +378/−0
- HMumps/Parsers.hs +559/−0
- HMumps/Routine.hs +63/−0
- HMumps/Runtime.hs +806/−0
- HMumps/SyntaxTree.hs +37/−0
- HMumps/Types.hs +229/−0
- LICENSE +674/−0
- Main.hs +56/−0
- SPLASH +5/−0
- Setup.hs +2/−0
- System/Console/Haskeline/Class.hs +63/−0
- Templates.hs +10/−0
- WARRANTY +8/−0
- hmumps.cabal +45/−0
+ Data/MArray.hs view
@@ -0,0 +1,101 @@+{-# OPTIONS -Wall #-}++module Data.MArray (+ MArray,+ mEmpty,+ mIndex,+ mSubArray,+ arrayUpdate,+ killSub,+ order+ ) where++-- Copyright 2007, 2010 Antoine Latter+-- aslatter@gmail.com++import Data.Map+import Data.MValue hiding (split)+import Prelude hiding (lookup,null)+import Test.QuickCheck++data MArray = MArray (Maybe MValue) (Map MValue MArray)++-- |Returns an empty MArray+mEmpty :: MArray+mEmpty = MArray Nothing empty+++lookup' :: (Monad m, Ord k) => k -> Map k v -> m v+lookup' k m = case lookup k m of+ Just a -> return a+ Nothing -> fail "Data.Map.lookup: failed!"++-- |Given an MArray and a list of subscripts, maybe+-- return the value associated with those subs.+mIndex :: Monad m => MArray -> [MValue] -> m MValue+mIndex (MArray v _map) [] = case v of+ Nothing -> fail "mIndex: value not set at specified index"+ Just mv -> return mv+mIndex (MArray _ map') (x:xs) = do+ vc <- lookup' x map'+ mIndex vc xs++mSubArray :: Monad m => MArray -> [MValue] -> m MArray+mSubArray m [] = return m+mSubArray (MArray _ map') (x:xs) = do+ vc <- lookup' x map'+ mSubArray vc xs++-- |Takes an array, subscripts and a value and returns the+-- updated array.+arrayUpdate :: MArray -> [MValue] -> MValue -> MArray+arrayUpdate (MArray _ map') [] v' = MArray (Just v') map'+arrayUpdate ma@(MArray n map') (sub:subs) v' = MArray n map'' where+ + map'' :: Map MValue MArray+ map'' = insert sub ma' map'++ ma' :: MArray+ ma' = arrayUpdate (nextArray sub ma) subs v'++killSub :: MArray -> [MValue] -> MArray+killSub MArray{} [] = error "fatal error in MArray.killSub"+killSub (MArray v m) [x] = MArray v $ x `delete` m+killSub a@(MArray v m) (x:xs)+ = case x `lookup` m of+ Nothing -> a+ Just a' -> MArray v $ insert x (killSub a' xs) m+++-- Given an Array and a Subscript reurns either the next+-- array or an 'empty' array.+nextArray :: MValue -> MArray -> MArray+nextArray v (MArray _v map') = case lookup v map' of+ Nothing -> MArray Nothing empty+ Just ma' -> ma'+++-- |Returns the next highest subscript for the last+-- subscript provided. Passing false for the bool+-- gives the next lowest, instead.+order :: MArray -> Bool -> MValue -> Maybe MValue+order (MArray _ map') forward mv =+ let (mapBack, mapForward) = split mv map'++ map'' | forward = mapForward+ | otherwise = mapBack++ findElem | forward = findMin+ | otherwise = findMax++ in if null map'' then Nothing+ else let (k, _) = findElem map'' in Just k ++{-+instance Arbitrary MArray where+ arbitrary = do+ n <- arbitrary+ xs <- arbitrary+ return $ MArray n (fromList xs)+ coarbitrary (MArray n xs) = variant 0 . coarbitrary (n,toList xs)+-}
+ Data/MValue.hs view
@@ -0,0 +1,378 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE Rank2Types, DeriveDataTypeable #-}++-- |This module defines the basic MUMPS type: the MValue+module Data.MValue+ ( MValue+ , fromText+ , fromDouble+ , asString+ , asText+ , asInt+ , follows+ , contains+ , isNum+ , mToBool+ , boolToM+ , mConcat+ , mNot+ , mAnd+ , mOr+ , mGT+ , mLT+ , mQuot+ , mRem+ , mPow+ , split+ , join+ ) where++-- Copyright 2007 Antoine Latter+-- aslatter@gmail.com++import Data.Char+import Data.Ratio+import Test.QuickCheck+import Data.Generics+import Data.String+import qualified Data.Text as T+import Data.Text (Text)+import Data.Monoid (mappend)++-- The MUMPS value type - is transparently a string or int+-- or float.++-- |Implementation-wise, the MValue is a wrapper around three+-- different Haskell types: a String, an Integer, or a Double.+-- However the integer and double representation are purely+-- for convinience, as far as the standard is concerned the number+-- type is a strict subtype of the string type.+data MValue = String Text+ | Number Integer+ | Float Double+ deriving (Show,Data,Typeable)++-- |I think this is proper MUMPS equality.+-- The key thing to watch out for is that+-- 1.0 <> "1.0", in fact 1.0 == "1". That+-- is, numeric literals should be striped down+-- to the "canonical" numeric form before being+-- represented as a string.+instance Eq MValue where+ (==) = meq+ where+ meq :: MValue -> MValue -> Bool+ -- Easy cases+ meq (String s1) (String s2) = s1 == s2+ meq (Number n1) (Number n2) = n1 == n2+ meq (Float f1) (Float f2) = f1 == f2+ -- Simple numeric cases+ meq (Number n) (Float f) = f == (fromInteger n)+ meq (Float f) (Number n) = f == (fromInteger n)+ -- Last, conversion to strings+ meq ms@(String _) mv = ms == mString mv+ meq mv ms@(String _) = ms == mString mv++-- |This instance of Ord gives proper sorting in an+-- MArray, but does NOT give proper results for the+-- MUMPS ">" an "<" operators.+instance Ord MValue where+ compare (Number i1) (Number i2) = compare i1 i2+ compare (Float f1) (Float f2) = compare f1 f2+ --+ compare (Number i1) (Float f2) = compare (fromIntegral i1) f2+ compare (Float f1) (Number i2) = compare f1 (fromIntegral i2)+ --+ compare mv1 mv2 | (isNum mv1) && (isNum mv2) = compare (mNum mv1) (mNum mv2)+ -- + compare (String s1) (String s2) = compare s1 s2+ compare (String s1) mv = let (String s2) = mString mv in compare s1 s2+ compare mv (String s2) = let (String s1) = mString mv in compare s1 s2++instance IsString MValue where+ fromString = String . fromString++fromText :: Text -> MValue+fromText = String++asText :: MValue -> Text+asText v+ = let String str = mString v+ in str++asString :: MValue -> String+asString+ = T.unpack . asText++asInt :: MValue -> Int+asInt v = let (Number i) = mNum v in fromInteger i++fromDouble :: Double -> MValue+fromDouble = Float++split :: MValue -> MValue -> [MValue]+split needle haystack+ = map fromText $ T.split (asText needle) (asText haystack)++join :: MValue -> [MValue] -> MValue+join delim pieces+ = fromText $ T.intercalate (asText delim) (map asText pieces)++follows :: MValue -> MValue -> MValue+follows a b = boolToM $ follows' a b+ where follows' :: MValue -> MValue -> Bool+ follows' (String l) (String r) = l > r+ follows' (String l) r = let String r' = mString r+ in l > r'+ follows' l (String r) = let String l' = mString l+ in l' > r+ follows' l r = let String l' = mString l+ String r' = mString r+ in l' > r'++contains :: MValue -> MValue -> MValue+contains a b = boolToM $ contains' a b+ where contains' :: MValue -> MValue -> Bool+ contains' (String s1) (String s2) = s2 `T.isInfixOf` s1+ contains' (String s1) mv = let String s2 = mString mv+ in s2 `T.isInfixOf` s1+ contains' mv (String s2) = let String s1 = mString mv+ in s2 `T.isInfixOf` s1+ contains' mv1 mv2 = contains' (mString mv1) (mString mv2)++-- |Cast to String - the returned MValue is always built with the String+-- constructor.+mString :: MValue -> MValue+mString (Number n) = fromString $ show n+mString (Float f) = fromString $ if f == fromIntegral (truncate f :: Integer)+ then show (truncate f :: Integer)+ else show f+mString x@(String s) = x+++-- |Cast to number. Leading + or - signs are interpretted as unary+-- operators. The supplied MValue is scanned from left to right until+-- characters that can't be interpretted in a numeric context are found.+-- The resulting number is returned as an MValue. If the supplied MValue's+-- leading charecters cannot be interpretted in a numeric context, zero is+-- returned.+mNum :: MValue -> MValue+mNum v@String{}+ = case asString v of+ [] -> Number 0+ ('+':s) -> mNum $ fromString s+ ('-':s) -> case mNum (fromString s) of+ Number 0 -> Number 0+ Number n -> Number (- n)+ Float n -> Float (- n)+ String _ -> error "mNum should not produce an MValue contructed with \"String\""+ s -> if isSpace (head s) then Number 0 else+ case (reads s :: [(Integer,String)]) of+ (i,_):[] -> Number i+ _ -> case (reads s :: [(Double,String)]) of+ (f,_):[] -> Float f+ _ -> Number 0+mNum x = x++-- |Tests to see if an MValue is a number.+-- Note that a String constructed MValue can pass this test.+isNum :: MValue -> Bool+isNum (Number _) = True+isNum (Float _) = True+isNum mv = mv == mNum mv++mNot :: MValue -> MValue+mNot = boolToM . not . mToBool++mConcat :: MValue -> MValue -> MValue+mConcat (String left) (String right) = String $ left `mappend` right+mConcat l@(String _) r = l `mConcat` (mString r)+mConcat l r@(String _) = (mString l) `mConcat` r+mConcat l r = (mString l) `mConcat` (mString r)++mToBool :: MValue -> Bool+mToBool s@(String _) = (mToBool . mNum) s+mToBool (Number 0) = False+mToBool (Number _) = True+mToBool (Float 0) = False+mToBool (Float _) = True++boolToM :: Bool -> MValue+boolToM True = Number 1+boolToM False = Number 0++mAnd :: MValue -> MValue -> MValue+mAnd l r = boolToM $ (mToBool l) && (mToBool r)++mOr :: MValue -> MValue -> MValue+mOr l r = boolToM $ (mToBool l) || (mToBool r)++mLT :: MValue -> MValue -> MValue+mLT (Number n1) (Number n2) = boolToM $ n1 < n2+mLT (Float f1) (Number n2) = boolToM $ f1 < (fromIntegral n2)+mLT (Number n1) (Float f2) = boolToM $ (fromIntegral n1) < f2+mLT (Float f1) (Float f2) = boolToM $ f1 < f2+mLT l@(String _) r = (mNum l) `mLT` r+mLT l r@(String _) = l `mLT` (mNum r)++mGT :: MValue -> MValue -> MValue+mGT (Number n1) (Number n2) = boolToM $ n1 > n2+mGT (Float f1) (Number n2) = boolToM $ f1 > (fromIntegral n2)+mGT (Number n1) (Float f2) = boolToM $ (fromIntegral n1) > f2+mGT (Float f1) (Float f2) = boolToM $ f1 > f2+mGT l@(String _) r = (mNum l) `mGT` r+mGT l r@(String _) = l `mGT` (mNum r)+++mNumBinop :: (forall a . Num a => a -> a -> a) -> (MValue -> MValue -> MValue)+mNumBinop op (Number a) (Number b) = Number $ a `op` b+mNumBinop op (Float a) (Number b) = Float $ a `op` (fromIntegral b)+mNumBinop op (Number a) (Float b) = Float $ (fromIntegral a) `op` b+mNumBinop op (Float a) (Float b) = Float $ a `op` b+mNumBinop op l@(String _) r = (mNum l) `op` r+mNumBinop op l r@(String _) = l `op` (mNum r)++instance Num MValue where+ (+) = mNumBinop (+)+ (-) = mNumBinop (-)+ (*) = mNumBinop (*)++ negate (Number n) = Number (-n)+ negate (Float f) = Float (-f)+ negate s@(String _) = negate . mNum $ s++ abs (Float f) = Float $ abs f+ abs (Number n) = Number $ abs n+ abs s@(String _) = abs $ mNum s++ signum (Float f) = Number $ truncate $ signum f+ signum (Number n) = Number $ signum n+ signum s@(String _) = signum $ mNum s++ fromInteger = Number . fromIntegral++instance Real MValue where+ toRational s@(String _) = (toRational . mNum) s+ toRational (Number n) = toRational n+ toRational (Float f) = toRational f+++instance Fractional MValue where+ fromRational a | denominator a == 1 = Number $ numerator a+ | otherwise = Float $ fromRational a++ recip m@(Number 1) = m+ recip (Number n) = Float $ 1/(fromIntegral n)+ recip (Float f) = Float $ 1/f+ recip m@(String _) = recip $ mNum m++mRealFracOp :: (forall a . RealFrac a => a -> b) -> MValue -> b+mRealFracOp op m@(String _) = (op . mNum) m+mRealFracOp op (Number n) = op $ (fromIntegral n :: Double)+mRealFracOp op (Float f) = op f++instance RealFrac MValue where+ properFraction m@(String _) = (properFraction . mNum) m+ properFraction (Number n) = (fromIntegral n, 0)+ properFraction (Float f) = let (a,b) = properFraction f in+ (a, Float b)++ truncate = mRealFracOp truncate+ round = mRealFracOp round+ ceiling = mRealFracOp ceiling+ floor = mRealFracOp floor++mFloatUnop :: (forall a . Floating a => a -> a) -> (MValue -> MValue)+mFloatUnop op (Float f) = Float $ op f+mFloatUnop op (Number n) = Float . op $ fromIntegral n+mFloatUnop op s@(String _) = op . mNum $ s++mFloatBinop :: (forall a . Floating a => a -> a -> a)+ -> (MValue -> MValue -> MValue)+mFloatBinop op (Float f1) (Float f2) = Float $ f1 `op` f2+mFloatBinop op (Float f1) (Number n2) = Float $ f1 `op` (fromIntegral n2)+mFloatBinop op (Number n1) (Float f2) = Float $ (fromIntegral n1) `op` f2+mFloatBinop op (Number n1) (Number n2) = Float $ (fromIntegral n1) `op` (fromIntegral n2)+mFloatBinop op s@(String _) mv = (mNum s) `op` mv+mFloatBinop op mv s@(String _) = mv `op` (mNum s)++instance Floating MValue where+ pi = Float pi++ exp = mFloatUnop exp+ log = mFloatUnop log+ sqrt = mFloatUnop sqrt+ sin = mFloatUnop sin+ cos = mFloatUnop cos+ tan = mFloatUnop tan+ asin = mFloatUnop asin+ acos = mFloatUnop acos+ atan = mFloatUnop atan+ sinh = mFloatUnop sinh+ cosh = mFloatUnop cosh+ tanh = mFloatUnop tanh+ asinh = mFloatUnop asinh+ acosh = mFloatUnop acosh+ atanh = mFloatUnop atanh++ (**) = mFloatBinop (**)+ logBase = mFloatBinop logBase++mQuot :: MValue -> MValue -> MValue+mQuot (Number n1) (Number n2) = Number $ quot n1 n2+mQuot (Float f1) mv = mQuot (Number . truncate $ f1) mv+mQuot mv (Float f2) = mQuot mv (Number . truncate $ f2)+mQuot s@(String _) mv = mQuot (mNum s) mv+mQuot mv s@(String _) = mQuot mv (mNum s)++mRem :: MValue -> MValue -> MValue+mRem (Number n1) (Number n2) = Number $ rem n1 n2+mRem (Float f1) mv = mRem (Number . truncate $ f1) mv+mRem mv (Float f2) = mRem mv (Number . truncate $ f2)+mRem s@(String _) mv = mRem (mNum s) mv+mRem mv s@(String _) = mRem mv (mNum s)++mPow :: MValue -> MValue -> MValue+mPow l@(String _) r = (mNum l) `mPow` r+mPow r l@(String _) = l `mPow` (mNum r)+mPow (Number l) (Number r) = Number $ l ^ r+mPow (Float l) (Float r) = Float $ l ** r+mPow (Number l) (Float r) = Float $ (fromInteger l) ** r+mPow (Float l) (Number r) = Float $ l ^^ r++{-+instance Arbitrary Char where+ arbitrary = elements ('%':['A'..'z'])+ coarbitrary c = variant (fromEnum c `rem` 4)++instance Arbitrary MValue where+ arbitrary = oneof [do+ x <- arbitrary+ return $ fromString x,+ do+ x <- arbitrary+ return $ Number x,+ do+ x <- arbitrary+ return $ Float x]+ coarbitrary (String s) = variant 0 . coarbitrary s+ coarbitrary (Number n) = variant 1 . coarbitrary n+ coarbitrary (Float f) = variant 2 . coarbitrary f+++testStringCast :: MValue -> Bool+testStringCast mv = mString mv == mv+ where _types = mv :: MValue++testNumericCast :: Integer -> Bool+testNumericCast f = Number f == (mNum . mString . Number) f+ where _types = f :: Integer+++-- Displayed whole numbers should not have trailing zeros. This is a check+-- on that.+testTrailingZero :: Integer -> Bool+testTrailingZero n = (mString . Number) n == (mString . Float . fromIntegral) n+ where _types = n :: Integer++-}
+ HMumps/Parsers.hs view
@@ -0,0 +1,559 @@+{-# OPTIONS_GHC -Wall #-}++-- |This module contains everything needed to do the initial+-- parsing of either a MUMPS routine or MUMPS commands+-- entered at a REPL++module HMumps.Parsers (+ initLex,+ strip,+ comment,+ parseCommands,+ command,+ parseExp,+ parseVn,+ parseWriteArg,+ parseKillArg,+ parseNewArg,+ parseDoArg,+ parseRoutineRef,+ parseLabel,+ parseGotoArg,+ mlist,+ mlist1,+ arglist,+ arglist1,+ parse,+ parseFile,+ eol,+ ) where++import Data.MValue+import HMumps.Routine+import HMumps.SyntaxTree++import Data.Char+import Data.String+import Control.Monad+import Text.Parsec hiding (spaces)+import Text.Parsec.String+-- import Text.Regex++spaces :: Parser ()+spaces = (many $ oneOf " \t\r") >> return ()++parseFile :: Parser OldFile+parseFile = many $+ do tag <- parseTag+ spaces+ linelevel <- length `liftM` many (do spaces; x <- char '.'; spaces; return x)+ cmds <- parseCommands+ optional comment+ char_ '\n'+ return (tag, linelevel, cmds)++parseTag :: Parser Tag+parseTag = do name <- parseValidName+ args <- arglist parseValidName+ return $ Just (name,args) + <|> return Nothing++-- | The "initLex" function takes in a string representing all of the code+-- to be parsed (say, an entire routine) and:+-- * Breaks the code into lines+-- * Removes comments+-- * Removes trailing whitespace+initLex :: String -> [String]+initLex = map strip . lines++strip :: String -> String+strip = (dropWhile whitespace) . reverse . (dropWhile whitespace) . reverse . (takeWhile (/=';'))+ where whitespace x = any (==x) [' ','\t','\r']++-- |Parse Commands is fed a LINE of MUMPS (after line-level has been detrimined).+parseCommands :: Parser [Command]+parseCommands = (many $ do c <- command+ spaces+ return c)+ <|> (do comment;+ return [])+ <|> (eol >> return [])+ <|> (spaces >> parseCommands)++-- I think I do this wrong, because I'm not sure what happens on+-- mal-formed input. anyway, I think it's better than it was.+++-- munch comments+comment :: Parser ()+comment = do char_ ';'+ _ <- many $ noneOf "\n"+ return ()++-- |Parses a single command.+command :: Parser Command+command = parseBreak+ <|> parseDo+ <|> parseElse+ <|> parseFor+ <|> parseGoto+ <|> parseHa -- left factored halt or hang+ <|> parseIf+ <|> parseKill+ <|> parseMerge+ <|> parseNew+ <|> parseQuit+ <|> parseRead+ <|> parseSet+ <|> parseWrite+ <|> parseXecute <?> "MUMPS command"++parseBreak :: Parser Command+parseBreak = do stringOrPrefix1 "break"+ cond <- postCondition+ return $ Break cond++postCondition :: Parser (Maybe Expression)+postCondition = do char_ ':'+ cond <- parseExpAtom+ return $ Just cond+ <|> return Nothing++-- Should work for end-of-line do statements. Need more tests though.+parseDo :: Parser Command+parseDo = do stringOrPrefix1 "do"+ cond <- postCondition+ do char_ ' '+ args <- mlist parseDoArg+ return $ Do cond args+ <|> do eol+ return $ Do cond []++parseDoArg :: Parser DoArg+parseDoArg = (do char_ '@'; expr <- parseExpAtom; return $ DoArgIndirect expr)+ <|> (do loc <- parseEntryRef+ args <- arglist parseFunArg+ cond <- postCondition+ return $ DoArg cond loc args)++-- very similar to the DO parser - which makes sense, as they do+-- similar things.+parseGoto :: Parser Command+parseGoto = do stringOrPrefix1 "goto"+ cond <- postCondition+ do char_ ' '+ args <- mlist parseGotoArg+ return $ Goto cond args+ <|> do eol+ return $ Goto cond []++parseGotoArg :: Parser GotoArg+parseGotoArg = (try (do char_ '@'; expr <- parseExpAtom; return $ GotoArgIndirect expr))+ <|> (do loc <- parseEntryRef+ cond <- postCondition+ return $ GotoArg cond loc)++parseElse :: Parser Command+parseElse = do+ stringOrPrefix1 "else"+ eol <|> do char_ ' '+ eol <|> char_ ' '+ return Else++parseFor :: Parser Command+parseFor = do stringOrPrefix1 "for"+ (eol >> return ForInf)+ <|>+ (do char_ ' '+ (do vn <- parseLvn+ char_ '='+ arg <- forArg+ return $ For vn arg)+ <|> (do eol <|> char_ ' '+ return ForInf))++ where forArg :: Parser ForArg+ forArg = do args <- colonlist parseExp+ case length args of+ 1 -> return $ ForArg1 (head args)+ 2 -> return $ ForArg2 (args !! 0) (args !! 1)+ 3 -> return $ ForArg3 (args !! 0) (args !! 1) (args !! 2)+ _ -> fail "Wrong number of arguments to FOR"+++parseHa :: Parser Command+parseHa = do stringOrPrefix1 "ha"+ (try parseHang <|> parseHalt)+ +--Not sufficiently left factored+parseHang :: Parser Command+parseHang = do+ stringOrPrefix "ng"+ cond <- postCondition+ char_ ' '+ expr <- parseExp+ return $ Hang cond expr++parseHalt :: Parser Command+parseHalt = do+ stringOrPrefix "lt"+ cond <- postCondition+ return $ Halt cond++parseIf :: Parser Command+parseIf = do stringOrPrefix1 "if"+ (char_ ' ' >> If `liftM` mlist parseExp)+ <|> (eol >> (return $ If []))++parseKill :: Parser Command+parseKill = do + stringOrPrefix1 "kill"+ cond <- postCondition+ (do char_ ' '+ args <- mlist parseKillArg+ return $ Kill cond args)+ <|> (eol >> (return $ Kill cond []))++parseMerge :: Parser Command +parseMerge = do stringOrPrefix1 "merge"+ cond <- postCondition+ char_ ' '+ args <- mlist1 parseMergeArg+ return $ Merge cond args++parseMergeArg :: Parser MergeArg+parseMergeArg = (do char_ '@'+ expr <- parseExpAtom+ return $ MergeArgIndirect expr)+ <|> (liftM2 MergeArg parseVn (char_ '=' >> parseVn))+ <?> "MERGE argument or indirection"++parseNew :: Parser Command+parseNew = do stringOrPrefix1 "new"+ cond <- postCondition+ (char_ ' ' >> New cond `liftM` (mlist parseNewArg))+ <|> (eol >> (return $ New cond []))++parseNewArg :: Parser NewArg+parseNewArg = (do char_ '('+ args <- mlist litName+ char_ ')'+ return $ NewExclusive args)+ <|> (NewIndirect `liftM` (char_ '@' >> parseExpAtom))+ <|> NewSelective `liftM` litName++parseQuit :: Parser Command+parseQuit = do stringOrPrefix1 "quit"+ return Quit `ap` postCondition `ap` quitArg+ where quitArg = (char_ ' ' >> (Just `liftM` parseExp <|> (eol >> return Nothing) <|> (char_ ' ' >> return Nothing)))+ <|> (eol >> return Nothing)++eol :: Parser ()+eol = notFollowedBy $ noneOf "\n;"++parseRead :: Parser Command+parseRead = do stringOrPrefix1 "read"+ cond <- postCondition+ char_ ' '+ args <- mlist1 parseWriteArg+ case last args of+ WriteExpression (ExpVn vn) -> return $ Read cond (init args) vn+ _ -> fail "last argument to READ must be a variable name"+++parseSet :: Parser Command+parseSet = do stringOrPrefix1 "set"+ return Set `ap` postCondition `ap` (char_ ' ' >> mlist1 setArg)+ where setArg = do lhs <- arglist1 parseVn <|> liftM (\x->[x]) parseVn+ char_ '='+ rhs <- parseExp+ return (lhs,rhs)++parseWrite :: Parser Command+parseWrite = do stringOrPrefix1 "write"+ return Write `ap` postCondition `ap` (char_ ' ' >> mlist1 parseWriteArg)++parseWriteArg :: Parser WriteArg+parseWriteArg = (WriteFormat `liftM` many1 parseWriteFormatCode)+ <|> do char_ '@'+ expr <- parseExpAtom+ (char_ '@' >> do args <- arglist parseExp+ return $ WriteExpression $ ExpVn $ IndirectVn expr args)+ <|> (return $ WriteIndirect expr)+ <|> (WriteExpression `liftM` parseExp)++parseWriteFormatCode :: Parser WriteFormatCode+parseWriteFormatCode = (char_ '#' >> return Formfeed)+ <|> (char_ '!' >> return Newline)+ <|> (char_ '?' >> return Tab `ap` parseInt)+ where parseInt :: Parser Int+ parseInt = return read `ap` many1 (oneOf ['0'..'9'])++parseXecute :: Parser Command+parseXecute = do+ stringOrPrefix1 "x"+ cond <- postCondition+ char_ ' '+ arg <- parseExp+ return $ Xecute cond arg++parseKillArg :: Parser KillArg+parseKillArg = (KillIndirect `liftM` (char_ '@' >> parseExpAtom))+ <|> (KillExclusive `liftM` arglist1 litName)+ <|> (KillSelective `liftM` parseVn)++stringOrPrefix :: String -> Parser ()+stringOrPrefix str = stringOrPrefix1 str <|> return ()++stringOrPrefix1 :: String -> Parser ()+stringOrPrefix1 [] = return ()+stringOrPrefix1 (x:xs) = do char_ (toUpper x) <|> char_ (toLower x) <|> char_ x+ stringOrPrefix xs++parseExpAtom :: Parser Expression+parseExpAtom = (parseExpUnop <|> parseExpVn <|> parseExpFuncall <|> parseSubExp <|> parseExpLit)++-- |Parse an expression. Is not at all forgiving about extraneous whitespace.+parseExp :: Parser Expression+parseExp = do let parseWrapper :: Parser ((Expression -> Expression) -> Expression -> Expression)+ parseWrapper = (do char_ '\''; return $ \f x -> ExpUnop UNot (f x)) <|> (return id)++ parseTailItem :: Parser (Expression -> Expression)+ parseTailItem = do wrapper <- parseWrapper;+ ((do binop <- parseBinop;+ expr <- parseExpAtom;+ return $ wrapper $ \x -> ExpBinop binop x expr)+ <|>(do char_ '?';+ pat <- undefined;+ return $ pat))+ exp1 <- parseExpAtom+ tails <- many parseTailItem++ return $ foldl (flip (.)) id tails $ exp1 ++parseExpUnop :: Parser Expression+parseExpUnop = (do unop <- parseUnop; expr <- parseExpAtom; return $ ExpUnop unop expr)++parseUnop :: Parser UnaryOp+parseUnop = (do char_ '\''; return UNot)+ <|> (do char_ '+'; return UPlus)+ <|> (do char_ '-'; return UMinus)++parseExpVn :: Parser Expression+parseExpVn = do vn <- parseVn+ return $ ExpVn vn++parseExpFuncall :: Parser Expression+parseExpFuncall = char_ '$' >>+ (parseBif <|> parseExFun)++parseBif :: Parser Expression+parseBif = liftM ExpBifCall $ msum+ [ parseBifC+ , parseBifX+ , parseBifY+ , parseBifT+ , parseBifO+ , parseReplace+ ]++parseBifC :: Parser BifCall+parseBifC = do+ stringOrPrefix1 "char"+ args <- arglist1 parseExp+ return $ BifChar args++parseBifX :: Parser BifCall+parseBifX = char_ 'x' >> return BifX++parseBifY :: Parser BifCall+parseBifY = char_ 'y' >> return BifY++parseBifT :: Parser BifCall+parseBifT = stringOrPrefix1 "test" >> return BifTest++parseBifO :: Parser BifCall+parseBifO = do+ stringOrPrefix1 "order"+ (vn, dir) <- parse2args parseVn parseExp+ return $ BifOrder vn dir++parseReplace :: Parser BifCall+parseReplace = do+ stringOrPrefix1 "zreplace"+ args <- arglist1 parseExp+ case args of+ [haystack,needle,replacement] -> return $ BifReplace haystack needle replacement+ _ -> fail "$$ZREPLACE requires three arguments"++-- | parse two function arguments where the second is optional+parse2args :: Parser a -> Parser b -> Parser (a, Maybe b)+parse2args a1 a2 = do+ char_ '('+ v1 <- a1+ v2 <- ((char_ ',' >> liftM Just a2) <|> return Nothing)+ char_ ')'+ return (v1, v2)++parseExFun :: Parser Expression+parseExFun = do+ char_ '$'+ (do char_ '^'+ name2 <- parseValidName+ args <- arglist parseFunArg+ return $ FunCall "" name2 args)+ <|> (do name1 <- parseValidName+ (do char_ '^'+ name2 <- parseValidName+ args <- arglist parseFunArg+ return $ FunCall name1 name2 args)+ <|> (do args <- arglist parseFunArg+ return $ FunCall name1 "" args))+ ++parseSubExp :: Parser Expression+parseSubExp = do char_ '('+ expr <- parseExp+ char_ ')'+ return expr++-- Take a positive number or a string. Any leading -/+ signs should've+-- been picked up by parseExpUnop by now.+parseExpLit :: Parser Expression+parseExpLit = parseNumLit <|> parseStringLit++-- Does not work with scientific notation yet+parseNumLit :: Parser Expression+parseNumLit = do xs <- many1 digit+ (do char_ '.'; ys <- many1 digit; (return . ExpLit . fromDouble . read) (xs ++ ['.'] ++ ys))+ <|> (return . ExpLit. fromInteger . read) xs++-- parse a string literal - uses one char of look-ahead+parseStringLit :: Parser Expression+parseStringLit = do char_ '"'+ xs <- many $ (try $ do string_ "\"\"";return '\"') <|> (noneOf "\"")+ char_ '"'+ (return . ExpLit . fromString) xs+++-- No guarantees that the list of binops is complete.+parseBinop :: Parser BinOp+parseBinop = (char_ '_' >> return Concat)+ <|> (char_ '+' >> return Add)+ <|> (char_ '-' >> return Sub)+ <|> (char_ '*' >> ((char_ '*' >> return Pow) <|> return Mult))+ <|> (char_ '/' >> return Div)+ <|> (char_ '#' >> return Rem)+ <|> (char_ '\\' >> return Quot)+ <|> (char_ '&' >> return And)+ <|> (char_ '!' >> return Or)+ <|> (char_ '=' >> return Equal)+ <|> (char_ '<' >> return LessThan)+ <|> (char_ '>' >> return GreaterThan)+ <|> (char_ ']' >> ((char_ ']' >> return SortsAfter) <|> return Follows))+ <|> (char_ '[' >> return Contains)+ <?> "binary operator"+++-- Used in DoArg and GotoArg+parseRoutineRef :: Parser Routineref+parseRoutineRef = (do char_ '^'+ (do char_ '@'+ RoutinerefIndirect `liftM` parseExpAtom)+ <|> Routineref `liftM` litName)++parseEntryRef :: Parser EntryRef+parseEntryRef = (Routine `liftM` parseRoutineRef)+ <|> (do lbl <- parseLabel+ offset <- parseOffset+ routine <- parseRoutine+ return $ Subroutine lbl offset routine)+ where+ parseOffset = (char_ '+' >> (Just . read) `liftM` many1 (oneOf "1234567890"))+ <|> (return Nothing)+ parseRoutine = (Just `liftM` parseRoutineRef)+ <|> (return Nothing)+ ++parseLabel :: Parser Label+parseLabel = (char_ '@' >> LabelIndirect `liftM` parseExpAtom)+ <|> (Label `liftM` litName)++ +-- Differs from parseExp because a funarg may be either:+-- 1) An Expression+-- 2) A (local?) variable passed by ref+parseFunArg :: Parser FunArg+parseFunArg = (do char_ '.'+ FunArgName `liftM` litName)+ <|> (FunArgExp `liftM` parseExp)++-- |Parses the name of a variable (with subscripts)+parseVn :: Parser Vn+parseVn = (do char_ '@'+ expr <- parseExpAtom+ args <- (do char_ '@'+ arglist parseExp) <|> return []+ return $ IndirectVn expr args)+ <|> (do char_ '^'+ name <- litName <|> return ""+ args <- arglist parseExp+ return $ Gvn name args)+ <|> parseLvn+ <?> "variable name"++parseLvn :: Parser Vn+parseLvn = return Lvn `ap` litName `ap` arglist parseExp++-- |Parses a literal name.+litName :: Parser Name+litName = parseValidName+ +parseValidName :: Parser String+parseValidName = do x <- oneOf (return '%' ++ ident)+ xs <- many (oneOf (ident ++ digits))+ return (x:xs)+ where ident = ['a'..'z'] ++ ['A'..'Z']+ digits = ['0'..'9']++-- |Given a parser, parse a comma separated list of these.+mlist :: Parser a -> Parser [a]+mlist pa = mlist1 pa <|> return []+++-- |Similar to mlist, but must grab at least one element+mlist1 :: Parser a -> Parser [a]+mlist1 pa = do + x <- pa+ xs <- (do char_ ','+ mlist pa) <|> return []+ return (x:xs)++colonlist :: Parser a -> Parser [a]+colonlist pa = do x <- pa+ xs <- many (char_ ':' >> pa)+ return (x:xs)+ +++-- |Given a parser, parse a comma separated list of these surrounded by parens+arglist :: Parser a -> Parser [a]+arglist pa = do char_ '('+ xs <- mlist pa+ char_ ')'+ return xs+ <|> return []++-- |Given a parser, parse a comma separated non-empty list of these+-- surounded by parens+arglist1 :: Parser a -> Parser [a]+arglist1 pa = do char_ '('+ xs <- mlist1 pa+ char_ ')'+ return xs++char_ :: Char -> Parser ()+char_ c = char c >>= \_ -> return ()++string_ :: String -> Parser ()+string_ str = string str >>= \_ -> return ()
+ HMumps/Routine.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC+ -Wall+ -Werror+ #-}++module HMumps.Routine(Line,+ File,+ OldFile,+ Routine,+ Tag,+ transform,+ pack)+ where++++-- import qualified Prelude as P++import HMumps.Types++-- |After initial parsing, do a pass over each tag to handle things.+transform :: OldFile -> File+transform [] = []+transform (x:xs) = case x of+ (tag,0,[]) -> (tag, [Nop]) : transform xs+ (tag,0,cmds)| any isEmptyDo cmds -> (tag,replaceEmptyDos cmds xs) : transform xs+ | otherwise -> (tag,cmds) : transform xs+ (_,_,_) -> (Nothing,[Nop]) : transform xs++isEmptyDo :: Command -> Bool+isEmptyDo (Do _ []) = True+isEmptyDo _ = False++replaceEmptyDos :: Line -> OldFile -> Line+replaceEmptyDos cmds oldlines =+ let helper :: Command -> Command+ helper (Do cond []) = Block cond tags llines+ helper cmd = cmd++ tags :: Routine+ tags = pack contents++ llines :: [Line]+ llines = fmap snd contents++ contents :: File+ contents = transform $ takeWhile (\(_,n,_) -> n >= 0) $ fmap (\(x,n,y) -> (x,n-1,y)) oldlines+ in fmap helper cmds++-- who needs data structures?+pack :: File -> Routine+pack [] = const Nothing+pack (x:xs) = let (tag,cmds) = x+ in case tag of+ Nothing -> pack xs+ Just (name, args) -> \label -> + if label == name then Just (args,cmds:strip xs)+ else (pack xs) label+strip :: File -> [Line]+strip [] = []+strip (x:xs) = let (_tag,line) = x in line : strip xs+ +
+ HMumps/Runtime.hs view
@@ -0,0 +1,806 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, ViewPatterns, ScopedTypeVariables,+ Rank2Types, GeneralizedNewtypeDeriving+ #-}++module HMumps.Runtime(RunState(..),+ Env(..),+ emptyState,+ eval,+ exec,+ Normalizable(..),+ setX, setY,+ addX, addY,+ RunMonad,+ step+ )+where++import Prelude hiding (lookup,break,map)++import Data.Char (chr)+import Data.String+import Data.Map+import Data.MValue hiding (join)+import qualified Data.MValue as M+import Data.MArray+import Data.Monoid++import HMumps.Routine+import HMumps.SyntaxTree+import HMumps.Parsers++import Control.Applicative hiding (empty)+import Control.Monad.State+import Control.Monad.Error++import System(exitWith)+import System.Exit(ExitCode(..))++newtype RunMonad a = RM {runRunMonad :: ErrorT String (StateT [RunState] IO) a}+ deriving (Functor, Monad, MonadIO, MonadState [RunState], MonadError String)++step :: (MonadState [RunState] m, MonadIO m) => RunMonad a -> m (Either String a)+step k+ = do+ s <- get+ (a, s') <- liftIO $ flip runStateT s $ runErrorT $ runRunMonad k+ put s'+ return a++-- |Anything you may ever want to strip indirection off of should+-- be an instance of this class+class Normalizable a where+ normalize :: a -> RunMonad a++instance Normalizable Vn where+ normalize (IndirectVn expr subs)+ = do result <- eval expr+ let str = asString result+ case parse parseVn "Indirect VN" str of+ Right (IndirectVn expr' subs') -> normalize $ IndirectVn expr' (subs' ++ subs)+ Right (Lvn label subs') -> return $ Lvn label (subs' ++ subs)+ Right (Gvn label subs') -> return $ Gvn label (subs' ++ subs)+ Left err -> normalizeError err+ normalize x = return x++instance Normalizable WriteArg where+ normalize (WriteIndirect expr)+ = do result <- eval expr+ let str = asString result+ case parse parseWriteArg "Indirect Write Argument" str of+ Right wa -> case wa of+ w@(WriteIndirect _) -> normalize w+ w -> return w+ Left err -> normalizeError err+ normalize x = return x++instance Normalizable KillArg where+ normalize (KillIndirect expr)+ = do+ result <- eval expr+ let str = asString result+ case parse (mlist1 parseKillArg) "Indirect KILL argument" str of+ Right args -> do+ args' <- mapM normalize args+ case args' of+ [arg] -> return arg+ _ -> return $ KillArgList args'+ Left err -> normalizeError err+ normalize x = return x++instance Normalizable NewArg where+ normalize (NewIndirect expr)+ = do+ result <- eval expr+ let str = asString result+ case parse (mlist1 parseNewArg) "Indirect NEW argument" str of+ Right args -> do+ args' <- mapM normalize args+ case args' of+ [arg] -> return arg+ _ -> return $ NewArgList args'+ Left err -> normalizeError err+ normalize x = return x++instance Normalizable DoArg where+ normalize (DoArgIndirect expr)+ = do+ result <- eval expr+ let str = asString result+ case parse (mlist1 parseDoArg) "Indirect DO argument" str of+ Right args -> do+ args' <- mapM normalize args+ case args' of+ [arg] -> return arg+ _ -> return $ DoArgList args'+ Left err -> normalizeError err+ normalize x = return x++instance Normalizable Routineref where+ normalize (RoutinerefIndirect expr)+ = do+ result <- eval expr+ let str = asString result+ case parse parseRoutineRef "Indirect routine ref" str of+ Right ref -> normalize ref+ Left err -> normalizeError err+ normalize x = return x++instance Normalizable Label where+ normalize (LabelIndirect expr)+ = do+ str <- asString <$> eval expr+ case parse parseLabel "Indirect label" str of+ Right lbl -> normalize lbl+ Left err -> normalizeError err+ normalize x = return x++instance Normalizable GotoArg where+ normalize (GotoArgIndirect expr)+ = do+ str <- asString <$> eval expr+ case parse parseGotoArg "GOTO argument" str of+ Right arg -> return arg+ Left err -> normalizeError err+ normalize x = return x++normalizeError :: (Show a, MonadIO m) => a -> m b+normalizeError err = (liftIO . putStrLn . show $ err) >> fail ""++-- | Remove any KillArgList constructors+flattenKillArgs :: [KillArg] -> [KillArg]+flattenKillArgs (KillArgList args':args) = flattenKillArgs args' ++ flattenKillArgs args+flattenKillArgs [] = []+flattenKillArgs (x:xs) = x : flattenKillArgs xs++-- | Remove any NewArgList constructors+flattenNewArgs :: [NewArg] -> [NewArg]+flattenNewArgs (NewArgList args':args) = flattenNewArgs args' ++ flattenNewArgs args+flattenNewArgs [] = []+flattenNewArgs (x:xs) = x : flattenNewArgs xs++data RunState = RunState { env :: Maybe Env+ , tags :: Routine+ , gotoTags :: Routine+ }++emptyState :: [RunState]+emptyState = [emptyFrame]++emptyFrame :: RunState+emptyFrame = RunState Nothing (\_ -> Nothing) (\_ -> Nothing)++data Env = Env EnvTag (Map String EnvEntry)++data EnvTag = NormalEnv+ | StopEnv+ deriving Eq++data EnvEntry = LookBack (Maybe Name)+ | Entry MArray+++killLocal :: Name -> RunMonad ()+killLocal = modify . go++ where go _ [] = []+ go label (f:fs)+ | noEnvFrame f = f : go label fs+ | otherwise+ = case f of+ RunState (Just (Env envTag envMap)) rou gRou+ -> case label `lookup` envMap of+ Nothing+ | envTag == StopEnv -> f:fs+ | otherwise -> f : go label fs+ Just (Entry _ary)+ -> (RunState (Just (Env envTag (label `delete` envMap))) rou gRou) : fs+ Just (LookBack Nothing) -> f : go label fs+ Just (LookBack (Just newLabel)) -> f : go newLabel fs+ _ -> error "Fatal error in KILL"++ noEnvFrame (RunState Nothing _ _) = True+ noEnvFrame _ = False++new :: Name -> RunMonad ()+new label+ = modify $ \state ->+ case state of+ [] -> fail "NEW called with an empty stack!"+ (x:xs) -> go x : xs++ where+ go (RunState Nothing r gr) = RunState (Just (Env NormalEnv (insert label (Entry mEmpty) empty))) r gr+ go (RunState (Just ev) r gr)+ = let newEnv+ = case ev of+ Env NormalEnv eMap -> Env NormalEnv $ insert label (Entry mEmpty) eMap+ Env StopEnv eMap -> Env StopEnv $ delete label eMap+ in RunState (Just newEnv) r gr++newExclusive :: [Name] -> RunMonad ()+newExclusive labels+ = modify $ \state ->+ case state of+ [] -> fail "NEW called with an empty stack!"+ (x:xs) -> go x : xs++ where+ go (RunState oldEnv r gr)+ = let newEnv = foldr addLabel (Env StopEnv mempty) labels+ in RunState (Just newEnv) r gr+ where+ addLabel label@(inEnv oldEnv -> Just entry) (Env _StopEnv eMap)+ = Env StopEnv $ insert label entry eMap+ addLabel label (Env _StopEnv eMap)+ = Env StopEnv $ insert label (LookBack Nothing) eMap++ inEnv Nothing _ = Nothing+ inEnv (Just (Env _ eMap)) lbl+ = lbl `lookup` eMap+++fetch' :: String -> [RunState] -> Maybe MArray+fetch' str xs = join . fst $ foldl helper (Nothing,str) [x | Just x <- fmap env xs] where++ helper :: (Maybe (Maybe MArray),Name) -> Env -> (Maybe (Maybe MArray), Name)++ helper rhs@(Just _, _) _ = rhs+ helper (_,name) (Env tag m) = case tag of+ NormalEnv -> case name `lookup` m of+ Nothing -> (Nothing, name)+ Just (Entry ma) -> (Just (Just ma), name)+ Just (LookBack newname') -> case newname' of+ Just newname -> (Nothing, newname)+ Nothing -> (Nothing, name)+ StopEnv -> case name `lookup` m of+ Nothing -> (Just Nothing, name)+ Just (Entry ma) -> (Just (Just ma), name)+ Just (LookBack newname') -> case newname' of+ Just newname -> (Nothing, newname)+ Nothing -> (Nothing, name)++-- |Returns the MArray associated with the named local var, or the empty MArray+fetch :: String -> RunMonad MArray+fetch str = do result <- (fetch' str) `liftM` get+ case result of+ Just x -> return x+ Nothing -> return mEmpty+++put' :: String -> MArray -> [RunState] -> [RunState]+put' _ _ [] = error "SET called with an empty stack"+put' str ma (x:[]) = case (env x) of+ Nothing -> x {env = Just $ Env NormalEnv (insert str (Entry ma) empty)} : []+ Just (Env tag m) -> x {env = Just $ Env tag (insert str (Entry ma) m)} : []+put' str ma (x:xs) = case (env x) of+ Nothing -> x : (put' str ma xs)+ Just (Env tag m) -> let enter = x {env = Just $ Env tag (insert str (Entry ma) m)} : xs in+ case str `lookup` m of+ Nothing -> case tag of+ NormalEnv -> x : (put' str ma xs)+ StopEnv -> enter++ Just (Entry _) -> enter+ Just (LookBack Nothing) -> x : (put' str ma xs)+ Just (LookBack (Just str')) -> x : (put' str' ma xs)++setVar :: String -> MArray -> RunMonad ()+setVar str ma = modify (put' str ma)++change :: String -> [MValue] -> MValue -> RunMonad ()+change name subs val = do ma <- fetch name+ setVar name (arrayUpdate ma subs val)++kill :: Name -> [MValue] -> RunMonad ()+kill label [] = killLocal label+kill label subs = do+ ma <- fetch label+ setVar label (killSub ma subs)++orM :: Monad m => [m Bool] -> m Bool+orM [] = return False+orM (x:xs) = do x' <- x+ if x'+ then return True+ else orM xs++-- |A return value of 'Nothing' indicates we did not quit, and should not unroll the stack.+-- A return value of 'Just Nothing' means we should quit with no return value.+-- A return value of 'Just (Just mv)' means that we should quit with a return value of mv.+exec :: Line -> RunMonad (Maybe (Maybe MValue))+exec [] = return Nothing++-- special commamds which (may) use the rest of the command list, or may+-- return without processing the entire list+exec (ForInf:cmds) = forInf (cycle cmds)+exec ((For vn farg):cmds) = case farg of+ ForArg1 expr -> exec $ (Set Nothing [([vn],expr)]) : ForInf : cmds+ ForArg2 exprStart exprInc ->+ do mStart <- eval exprStart+ mInc <- eval exprInc+ exec $ (Set Nothing [([vn],ExpLit mStart)]) : ForInf : cmds +++ [Set Nothing [([vn],ExpBinop Add (ExpVn vn) (ExpLit mInc))]]+ ForArg3 exprStart exprInc exprTest -> + do mStart <- eval exprStart+ mInc <- eval exprInc+ mTest <- eval exprTest+ exec $ (Set Nothing [([vn],ExpLit mStart)]) : ForInf : cmds ++++ [Quit (Just $ if mToBool (mTest `mLT` 0)+ then ExpBinop LessThan (ExpVn vn) (ExpLit (mTest + 1))+ else ExpBinop GreaterThan (ExpVn vn) (ExpLit (mTest - 1))) Nothing,++ Set Nothing [([vn],ExpBinop Add (ExpVn vn) (ExpLit mInc))]]++exec ((Break cond):cmds) = do+ condition <- evalCond cond+ when condition $ break+ exec cmds++exec (Else:cmds) = do t <- getTest+ if not t+ then exec cmds+ else return Nothing+exec ((If xs):cmds) = do let xs' = fmap eval xs+ cond <- orM $ (liftM . liftM) mToBool xs'+ if cond+ then setTest True >> exec cmds+ else setTest False >> return Nothing+exec ((Halt cond):cmds)+ = do+ condition <- evalCond cond+ if condition+ then liftIO (exitWith ExitSuccess) >> return Nothing+ else exec cmds++exec ((Quit cond arg):cmds)+ = do+ condition <- evalCond cond+ if condition+ then case arg of+ Nothing -> return $ Just Nothing+ Just expr -> do+ mv <- eval expr+ return $ Just $ Just mv+ else exec cmds++exec ((Goto cond args):cmds)+ = do+ condition <- evalCond cond+ if condition+ then execGotoArgs args+ else exec cmds++ where+ execGotoArgs [] = exec cmds+ execGotoArgs (arg:rest)+ = do+ GotoArg argCond entryRef <- normalize arg+ condition <- evalCond argCond+ if condition+ then do+ (rou,tag) <- unpackEntryRef entryRef+ liftM Just $ goto rou tag+ else execGotoArgs rest++ unpackEntryRef :: EntryRef -> RunMonad (Maybe Name, Name)+ unpackEntryRef entryRef =+ case entryRef of+ Routine rRef -> do+ Routineref name <- normalize rRef+ return (Just name, "")+ Subroutine label' Nothing Nothing -> do+ label <- labelName label'+ return (Nothing, label)+ Subroutine label' Nothing (Just rRef) -> do+ label <- labelName label'+ Routineref name <- normalize rRef+ return (Just name, label)+ Subroutine _ Just{} _ -> fail "unable to process numberic offsets for DO or GOTO"++ labelName :: Label -> RunMonad Name+ labelName label' = do+ label <- normalize label'+ case label of+ Label name -> return name+ LabelInt{} -> fail "Unable to handle numeric labels"+ _ -> error "Fatal error handling entry reference"+ ++-- regular commands go through the command driver++exec (cmd:cmds)+ = do+ go cmd+ exec cmds++ where+ go Nop = return ()++ go (Write cond ws) = do+ condition <- evalCond cond+ when condition $ write ws++ go (Set cond sas) = do+ condition <- evalCond cond+ when condition $ set sas++ go (Xecute cond arg) = do+ condition <- evalCond cond+ when condition $ do+ str <- asString `liftM` eval arg+ case parse parseCommands "XECUTE" str of+ Left _err -> fail "" -- todo, better error message+ Right xcmds -> do+ modify (emptyFrame:)+ res <- exec $ xcmds ++ [Quit Nothing Nothing]+ case res of+ Just (Just{}) -> fail "XECUTE cannot return with a value"+ _ -> return ()+ modify tail++ -- the "routine" argument is only for use with GOTO,+ -- so we ignore it for now+ go (Block cond rou doLines) = do+ condition <- evalCond cond+ when condition $ do+ RunState _ r _ <- gets head+ modify (emptyFrame {tags = r,gotoTags=rou}:)+ doBlockLines doLines+ modify tail+ where+ doBlockLines [] = return ()+ doBlockLines (doCmds:rest)+ = do+ res <- exec doCmds+ case res of+ Nothing -> doBlockLines rest+ Just Nothing -> return ()+ Just Just{} -> fail "Argumentless DO block cannot quit with a value"+++ go (Kill cond args) = do+ condition <- evalCond cond+ when condition $ case args of+ [] -> fail "Sorry, I don't know how to kill everything"+ _ -> do+ args' <- flattenKillArgs `liftM` (mapM normalize args)+ forM_ args' $ \arg ->+ case arg of+ KillSelective vn'+ -> do+ vn <- normalize vn'+ case vn of+ Lvn name subs' -> do+ subs <- mapM eval subs'+ kill name subs+ _ -> fail "I can only kill locals, sorry"+ _ -> fail "I can only do selective kills, sorry!"++ go (New cond args) = do+ condition <- evalCond cond+ when condition $ case args of+ [] -> newExclusive []+ _ -> do+ args' <- flattenNewArgs `liftM` (mapM normalize args)+ forM_ args' $ \arg ->+ case arg of+ NewSelective name -> new name+ NewExclusive names -> newExclusive names+ _ -> error "Fatal error processing arguments to NEW"++ go (Do cond args) = do+ condition <- evalCond cond+ when condition $ forM_ args $ \arg' -> do+ arg <- normalize arg'+ case arg of+ DoArgList argList -> mapM_ processDo argList+ _ -> processDo arg++ go c = fail $ "Sorry, I don't know how to execute: " ++ (takeWhile (\x -> not (x==' ')) $ show c)++processDo :: DoArg -> RunMonad ()+processDo (DoArg cond entryRef args)+ = do+ condition <- evalCond cond+ when condition $ do+ case entryRef of+ Routine routineRef'+ -> do+ Routineref rou <- normalize routineRef'+ sub (Just rou) "" args+ Subroutine label' Nothing Nothing+ -> do+ label <- normalize label'+ case label of+ Label name -> sub Nothing name args+ LabelInt{} -> fail "Cannot use numeric labels"+ _ -> error "fatal error in DO"+ Subroutine label' Nothing (Just rouRef')+ -> do+ Routineref rou <- normalize rouRef'+ label <- normalize label'+ case label of+ Label name -> sub (Just rou) name args+ LabelInt{} -> fail "Cannot use numeric labels"+ _ -> error "fatal error in DO"+ Subroutine _ Just{} _ -> fail "Unable to execute DO with a numeric offset"+processDo _ = error "fatal error in DO"++evalCond :: Maybe Expression -> RunMonad Bool+evalCond Nothing = return True+evalCond (Just e) = mToBool `liftM` eval e++set :: [SetArg] -> RunMonad ()+set [] = return ()+set ((vns,expr):ss) = do vns' <- mapM normalize vns+ mv <- eval expr+ mapM_ (setHelper mv) vns' >> set ss+ where setHelper mv (Lvn name subs) = do subs' <- mapM eval subs+ change name subs' mv+ setHelper _ (Gvn _ _) = fail "We don't supposrt global variables yet. sorry."+ setHelper _ (IndirectVn _ _) = fail "Variable name should be normalized"++write :: [WriteArg] -> RunMonad ()+write = mapM_ f+ where f wa = do+ wa' <- normalize wa+ case wa' of+ WriteExpression expr -> do m <- eval expr+ let s = asString m+ liftIO $ putStr s+ addX $ fromIntegral $ length s+ WriteFormat fs -> writeFormat fs+ WriteIndirect _ -> fail "write argument should be normalized"++writeFormat :: [WriteFormatCode] -> RunMonad ()+writeFormat = mapM_ f+ where+ f Formfeed = liftIO (putChar '\f') >> setY 1+ f Newline = liftIO (putChar '\n') >> setX 1 >> addY 1+ f (Tab n) = do x <- getX+ let n' = fromIntegral n+ if x >= n'+ then return ()+ else do liftIO (putStr $ (replicate . floor) (n'-x) ' ')+ setX n'++setX :: MValue -> RunMonad ()+setX = change "$x" []++setY :: MValue -> RunMonad ()+setY = change "$y" []++getX :: RunMonad MValue+getX = getLocal "$x" []++getY :: RunMonad MValue+getY = getLocal "y" []++addX :: Int -> RunMonad ()+addX n = do x <- getX+ setX (x + fromIntegral n)++addY :: Int -> RunMonad ()+addY n = do y <- getY+ setY (y + fromIntegral n)++getLocal :: String -> [MValue] -> RunMonad MValue+getLocal label subs = do ma <- fetch label+ return $ case mIndex ma subs of+ Just mv -> mv+ Nothing -> fromString "" ++getLocalArray :: String -> [MValue] -> RunMonad (Maybe MArray)+getLocalArray label subs = do+ ma <- fetch label+ return $ mSubArray ma subs++forInf :: Line -> RunMonad (Maybe (Maybe MValue))+forInf ((Quit cond Nothing):xs) = case cond of+ Nothing -> return Nothing+ Just expr -> do mv <- eval expr+ if mToBool mv+ then return Nothing+ else forInf xs+forInf ((Quit _ _):_) = fail "QUIT with argument in a for loop"+forInf (cmd:xs) = exec [cmd] >> forInf xs+forInf [] = forInf [] -- dumb++break :: RunMonad ()+break = fail "BREAK not working"++getTest :: RunMonad Bool+getTest = mToBool `liftM` getLocal "$test" []++setTest :: Bool -> RunMonad ()+setTest = change "$test" [] . boolToM+++eval :: Expression -> RunMonad MValue+eval (ExpLit m) = return m+eval (ExpVn vn) = do vn' <- normalize vn+ case vn' of+ Lvn label subs -> do mvs <- mapM eval subs+ getLocal label mvs+ Gvn _ _ -> fail "Globals not yet implemented"+ IndirectVn _ _ -> fail "normalized VNs should not be indirect"++eval (ExpUnop unop expr) = do mv <- eval expr+ return $ case unop of+ UNot -> mNot mv+ UPlus -> mv+0+ UMinus -> negate mv+eval (ExpBinop binop lexp rexp) + = do lv <- eval lexp+ rv <- eval rexp+ return $ case binop of+ Concat -> lv `mConcat` rv+ Add -> lv + rv+ Sub -> lv - rv+ Mult -> lv * rv+ Div -> lv / rv+ Rem -> lv `mRem` rv+ Quot -> lv `mQuot` rv+ Pow -> lv `mPow` rv+ And -> lv `mAnd` rv+ Or -> lv `mOr` rv+ Equal -> boolToM $ lv == rv+ LessThan -> lv `mLT` rv+ GreaterThan -> lv `mGT` rv+ Follows -> lv `follows` rv+ Contains -> lv `contains` rv+ SortsAfter -> boolToM $ lv > rv+-- eval (Pattern _ _) = fail "Can't evaluate pattern matches"+eval (FunCall label "" args) = function Nothing label args +eval (FunCall label rou args) = function (Just rou) label args+eval (ExpBifCall bif) = evalBif bif++function :: Maybe Name -> Name -> [FunArg] -> RunMonad MValue+function routine tag args+ = do+ retVal <- call routine tag args+ case retVal of+ Nothing -> fail "Function quit without returning a value"+ Just v -> return v+++sub :: Maybe Name -> Name -> [FunArg] -> RunMonad ()+sub routine tag args+ = do+ retVal <- call routine tag args+ case retVal of+ Nothing -> return ()+ Just{} -> fail "Subroutine quit with a value!"+++call :: Maybe Name -> Name -> [FunArg] -> RunMonad (Maybe MValue)+call Nothing tag args = localCall tag args+call (Just routine) "" args = call (Just routine) routine args+call (Just routine) tag args = remoteCall tag routine args+++ +localCall :: Name -> [FunArg] -> RunMonad (Maybe MValue)+localCall label args = do (r :: Routine) <- (tags . head) `liftM` get+ case r label of+ Nothing -> fail $ "Noline: " ++ label+ Just (argnames, cmds) -> funcall args argnames cmds r+++remoteCall :: Name -> Name -> [FunArg] -> RunMonad (Maybe MValue)+remoteCall label routine args+ = openRemote routine $ \r ->+ case r label of+ Nothing -> fail $ "Noline: " ++ label ++ "^" ++ routine+ Just (argnames, cmds) -> funcall args argnames cmds r++goto :: Maybe Name -> Name -> RunMonad (Maybe MValue)+goto Nothing tag+ = do+ s <- gets head+ doGoto tag (tags s) (gotoTags s)+goto (Just rouName) tag+ = openRemote rouName $ \r -> doGoto tag r r++doGoto :: Name -> Routine -> Routine -> RunMonad (Maybe MValue)+doGoto tag r gr+ = case gr tag of+ Nothing -> fail $ "Noline: " ++ tag+ Just ([], cmds) -> do+ modify $ \(s:ss) -> s {tags=r,gotoTags=gr} : ss+ runLines cmds+ Just{} -> fail "Error in GOTO: tag should not take arguments"++openRemote :: MonadIO m => Name -> (Routine -> m a) -> m a +openRemote routine k+ = do+ let filename = routine ++ ".hmumps"+ text <- liftIO $ readFile filename+ case parse parseFile filename text of+ Left a -> (fail . show) a+ Right f -> let r = pack $ transform f in+ k r++evalBif :: BifCall -> RunMonad MValue+evalBif (BifChar args') = do+ args <- mapM eval args'+ let str = fmap (chr . asInt) args+ return $ fromString str++evalBif BifX = getX+evalBif BifY = getY+evalBif BifTest = boolToM `liftM` getTest+evalBif (BifOrder vn' expForward) = do+ vn <- normalize vn'+ case vn of+ Lvn label subs' -> do+ subs <- mapM eval subs'+ case unSnoc subs of+ Nothing -> fail "Cannot $ORDER with no subscripts"+ Just (rest,lastSub)+ -> do+ ma <- getLocalArray label rest+ case ma of+ Nothing -> return ""+ Just a -> do+ forward <- case expForward of+ Nothing -> return True+ Just ex -> mToBool `liftM` eval ex+ case order a forward lastSub of+ Nothing -> return ""+ Just v -> return v+ Gvn{} -> fail "$ORDER on globals is not supported"+ _ -> error "Fatal error in ORDER"+evalBif (BifReplace haystack' needle' replacement') = do+ haystack <- eval haystack'+ needle <- eval needle'+ replacement <- eval replacement'+ return $ M.join replacement $ M.split needle haystack++-- evalBif bif = fail $ "oops! I don't know what to do with " ++ show bif+++-- | returns the front of a list plus the last element.+-- returns Nothing if the list is empty.+unSnoc :: [a] -> Maybe ([a],a)+unSnoc [] = Nothing+unSnoc (x:xs) = Just $ case unSnoc xs of+ Nothing -> ([],x)+ Just ~(ys,y) -> (x:ys,y)++funcall :: [FunArg] -> [Name] -> [Line] -> Routine -> RunMonad (Maybe MValue)+funcall args' argnames cmds r = + let (pairs, remainder) = zipRem args' argnames in+ case remainder of+ Just (Left _) -> fail "Supplied too many parameters to function"+ _ -> do m <- foldM helper empty pairs+ let newframe = RunState (Just $ Env NormalEnv m) r r+ modify (newframe:)+ x <- runLines cmds+ modify tail+ return x++ where helper :: Map Name EnvEntry -> (FunArg, Name) -> RunMonad (Map Name EnvEntry)+ helper m (arg,name) = case arg of+ FunArgExp expr -> do mval <- eval expr+ let entry = Entry $ arrayUpdate mEmpty [] mval+ return $ insert name entry m+ FunArgName name' -> return $ insert name (LookBack $ Just name') m++runLines :: [Line] -> RunMonad (Maybe MValue)+runLines [] = return Nothing+runLines (x:xs) = do result <- exec x+ case result of+ Nothing -> runLines xs+ Just x' -> return x'++zipRem :: [a] -> [b] -> ([(a,b)],Maybe (Either [a] [b]))+zipRem [] [] = ([],Nothing)+zipRem [] xs = ([],Just $ Right xs)+zipRem xs [] = ([],Just $ Left xs)+zipRem (x:xs) (y:ys) = let (pairs, remainder) = zipRem xs ys+ in ((x,y):pairs,remainder)+
+ HMumps/SyntaxTree.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -Wall -Werror #-}++-- |This module defines all of the data types that make up parsed+-- MUMPS syntax.++module HMumps.SyntaxTree (+ -- * Syntax-Tree Types+ -- ** Commands+ Command(..),+ EntryRef(..),+ FunArg(..),+ Vn(..),+ Label(..),+ Routineref(..),+ DoArg(..),+ ForArg(..),+ KillArg(..),+ GotoArg(..),+ MergeArg(..),+ NewArg(..),+ SetArg,+ WriteArg(..),+ WriteFormatCode(..),+ Name,+ -- ** Expressions+ Expression(..),+ BifCall(..),+ Condition,+ Subscript,+ UnaryOp(..),+ BinOp(..),+ ) where++-- Copyright 2007-2010 Antoine Latter+-- aslatter@gmail.com++import HMumps.Types
+ HMumps/Types.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS -Wall -Werror #-}++module HMumps.Types where++-- import Text.Regex+import Data.MValue++type Routine = String -> Maybe Subroutine+type Line = [Command]+type File = [(Tag, Line)]+type OldFile = [(Tag, Int, Line)]+type Subroutine = ([Name],[Line]) -- Arguments and commands+type Tag = Maybe (Name, [Name]) -- Label and arguments++instance Show Routine where+ show _ = "[Routine]"+++{- Definition of lexical tokens follows:+ routinehead -> name eol+ name -> startname [alphanumeric]+ startname -> % | ['A'..'Z']++['a'..'z']+ digit -> ['0'..'9']+ control -> 127:[0..31] + graphic -> [x | x<-[0..255], not (elem x control)]+ eol -> '\n'++-}++-- Where we put this may change, but I'm going to just include the pre+-- processing here so that we can know where we stand. The fundamental+-- assumptions that can go into the true parsing is that +-- 1. There are no comments+-- 2. There are no trailing whitespaces+-- 3. There are no newlines+-- Leaving in stupid version until I can think of a good way to fuse the traversals.+++-- AST data structures+-- These structures are what MUMPS will look like AFTER parsing,+-- but these structures do NOT describe the execution environment.+--+-- EXCEPTION: The MValue data type is both used as literals in+-- the AST structures, and in the run-time environment.+--+-- These data structures, taken together, should be trvially+-- isomorphic to unparsed MUMPS+--+-- It's intended that the execution environment will execute these+-- structures - so that it's a step removed from parsing and line+-- reading, even if the base execution environment still has a+-- concept of "line"+++-- I feel like this is going to turn into an explosion of type contructors+--+-- | These commands make up the initial sub-set of commands I'd like+-- to implement. I'm not sure if the ASTs described here will make+-- up the optimizable representation, but they will make up what's+-- executed by my first stab at a run-time environment.+data Command = Break (Maybe Condition)+ | Do (Maybe Condition) [DoArg]+ | Else+ | For Vn ForArg+ | ForInf+ | Goto (Maybe Condition) [GotoArg]+ | Halt (Maybe Condition)+ | Hang (Maybe Condition) Expression+ | If [Condition]+ | Kill (Maybe Condition) [KillArg]+ | Merge (Maybe Condition) [MergeArg]+ | New (Maybe Condition) [NewArg]+ | Quit (Maybe Condition) (Maybe Expression)+ | Read (Maybe Condition) [WriteArg] Vn+ | Set (Maybe Condition) [SetArg]+ | Write (Maybe Condition) [WriteArg]+ | Xecute (Maybe Condition) Expression+ -- The following commands will not have parsers written for them+ | Nop+ | Block (Maybe Condition) Routine [[Command]]+ deriving (Show)+++data DoArg = DoArg (Maybe Condition) EntryRef [FunArg]+ | DoArgIndirect Expression+ | DoArgList [DoArg] -- not parsed, only used during run-time+ deriving (Show)++data ForArg = ForArg1 Expression+ | ForArg2 Expression Expression+ | ForArg3 Expression Expression Expression+ deriving (Show)++data GotoArg = GotoArg (Maybe Condition) EntryRef+ | GotoArgIndirect Expression+ deriving (Show)++-- | "EntryRef" is a thing that can be pointed to by a DO or a GOTO,+-- it may be specify a subroutine or a routine. This datatype should+-- be equivalent to the "entryref" of the MUMPS spec.+data EntryRef = Routine Routineref+ | Subroutine Label (Maybe Integer) (Maybe Routineref)+ deriving (Show)++-- | The DLabel is tag pointed to by an enytryref, if the entryref+-- specifies a label.+data Label = Label Name+ | LabelInt Integer -- ^Labels can be given as integers+ | LabelIndirect Expression+ deriving (Show)++-- | The Routineref specifies a routine and an optional+-- environment. May be indirect.+data Routineref = Routineref Name+ | RoutinerefIndirect Expression+ deriving (Show)++type Condition = Expression+type Subscript = Expression++-- | Each argument to KILL may be+-- 1) A variable name+-- 2) A list containing the names of variables+-- not to kill (the remainder are killed)+-- 3) An expression, evaluating to a list of +-- valid kill arguments+-- See 8.2.11+data KillArg = KillSelective Vn+ | KillExclusive [Name]+ | KillIndirect Expression+ | KillArgList [KillArg] -- not parsed, only used internally+ deriving (Show)++-- |An argument to merge specifies a source and a target.+-- See 8.2.13+data MergeArg = MergeArg Vn Vn | MergeArgIndirect Expression+ deriving (Show)+++-- | The arguments to NEW are pretty much the same as the arguments+-- to KILL.+-- See 8.2.14+data NewArg = NewSelective Name+ | NewExclusive [Name]+ | NewIndirect Expression+ | NewArgList [NewArg] -- not parsed. Internal only.+ deriving (Show)++data WriteArg = WriteExpression Expression+ | WriteFormat [WriteFormatCode]+ | WriteIndirect Expression+ deriving (Show)++data WriteFormatCode = Formfeed+ | Newline+ | Tab Int+ deriving (Show)++-- |Vn describes the name of a variable, which may be local, global,+-- or indirect. Each form may optionally indicate a Subscript.+-- See 7.1.2+data Vn = Lvn Name [Subscript] -- these two will only ever+ | Gvn Name [Subscript] -- be direct names. Maybe.+ | IndirectVn Expression [Subscript]+ deriving (Show)++-- | A funarg can be an expression, or the name of a local to pass+-- in by reference.+data FunArg = FunArgExp Expression+ | FunArgName Name+ deriving (Show)++type Name = String+++-- | An expression is something which evaluates to an MValue.+data Expression+ -- |An expression may be a literal MValue+ = ExpLit MValue+ -- |or a variable to be fetched+ | ExpVn Vn+ -- |Any expression may be precedded by one of the+ -- unary operators+ | ExpUnop UnaryOp Expression+ -- |Binary operators may be used to combine expressions.+ | ExpBinop BinOp Expression Expression+ -- |MUMPS provides many builtin functions, some of which+ -- are of arity zero (so are more like builtin constants)+ | ExpBifCall BifCall+ -- |You can even call your own functions! Locally defined+ -- functions need not specify the parent routine.+ | FunCall String String [FunArg]+ -- |A pattern match is similar to a regular expression match.+ -- This binary operator returns either 0 or 1.+-- | Pattern Expression Regex+ deriving (Show)++type PatCode = ()++{-+instance Show Regex where+ show _ = "<Regex>"+-}++data UnaryOp = UNot | UPlus | UMinus+ deriving (Show)++data BinOp = Concat | Add | Sub | Mult | Div | Rem | Quot | Pow | And | Or+ | Equal | LessThan | GreaterThan | Follows | Contains | SortsAfter+ deriving (Show)++data BifCall+ = BifChar [Expression]+ | BifX+ | BifY+ | BifTest+ | BifOrder Vn (Maybe Expression)+ | BifReplace Expression Expression Expression+ deriving Show+++-- I don't know why I hadn't defined this earlier.+-- I'm glad I hadn't - it liekly would've been+-- more complicated.+-- |A set argument consists of list of variable names that are to be+-- set to the supplied expression. Even though the SetArg as a whole+-- may not be indirect, the Vn or Expression may allow for indirection.+type SetArg=([Vn],Expression)
+ LICENSE view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Main.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS -Wall #-}+{-# LANGUAGE TemplateHaskell, FlexibleContexts, RelaxedPolyRec #-}++module Main where++-- import Text.Parsec+import System.Console.Haskeline.Class+import Control.Monad.State++import HMumps.Runtime+import HMumps.Parsers++import Templates++main :: IO ()+main = do+ -- hSetBuffering stdout NoBuffering+ putStrLn splash+ runHaskelineT defaultSettings $ evalStateT loop emptyState+ return ()++loop :: (MonadState [RunState] m, MonadHaskeline m) => m ()+loop = do line <- getInputLine "> "+ case line of+ Just x -> if x == ""+ then loop+ else + case x of+ '!':xs -> interpreterCommands xs loop+ _ -> (repl . strip) x >> loop+ Nothing -> liftIO (putStrLn "") >> return ()+++interpreterCommands :: (MonadIO m, MonadState [RunState] m) => String -> m () -> m ()+interpreterCommands "q" _ = return ()+interpreterCommands "w" next = (liftIO $ putStrLn warranty) >> next+interpreterCommands str next = (liftIO $ putStrLn $ "Unkown interpreter command: " ++ str) >> next++repl :: (MonadState [RunState] m, MonadIO m) => String -> m ()+repl [] = return ()+repl x = do+ case parse parseCommands "" x of+ Left err -> do+ liftIO $ putStrLn $ show err+ modify (take 1)+ Right xs -> do+ result <- step (exec xs >> liftIO (putChar '\n') >> setX 0 >> addY 1)+ case result of+ Right _ -> return ()+ Left str -> liftIO $ putStrLn str++splash :: String+splash = $(bakedString "SPLASH")++warranty :: String+warranty = $(bakedString "WARRANTY")
+ SPLASH view
@@ -0,0 +1,5 @@+HMUMPS Copyright (C) 2007, 2009-2010 Antoine Latter, Creighton Hogg+This program comes with ABSOLUTELY NO WARRANTY; for details type `!w'.+This is free software, and you are welcome to redistribute it+under certain conditions; for details see the enclosed LICENSE file.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Console/Haskeline/Class.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances+ , MultiParamTypeClasses+ , UndecidableInstances+ , GeneralizedNewtypeDeriving+ #-}++module System.Console.Haskeline.Class+ (HaskelineT+ ,runHaskelineT+ ,runHaskelineTWithPrefs+ ,MonadHaskeline(..)+ ,H.Settings(..)+ ,H.defaultSettings+ ,H.setComplete+ ,H.Prefs()+ ,H.readPrefs+ ,H.defaultPrefs+ ,H.Interrupt(..)+ ,H.handleInterrupt+ ,module System.Console.Haskeline.Completion+ ,module System.Console.Haskeline.MonadException+ ) where++import qualified System.Console.Haskeline as H+import System.Console.Haskeline.Completion+import System.Console.Haskeline.MonadException++import Control.Applicative+import Control.Monad.State++newtype HaskelineT m a = HaskelineT {unHaskeline :: H.InputT m a}+ deriving (Monad, Functor, Applicative, MonadIO, MonadException, MonadTrans, MonadHaskeline)++runHaskelineT :: MonadException m => H.Settings m -> HaskelineT m a -> m a+runHaskelineT s m = H.runInputT s (unHaskeline m)++runHaskelineTWithPrefs :: MonadException m => H.Prefs -> H.Settings m -> HaskelineT m a -> m a+runHaskelineTWithPrefs p s m = H.runInputTWithPrefs p s (unHaskeline m)++class MonadException m => MonadHaskeline m where+ getInputLine :: String -> m (Maybe String)+ getInputChar :: String -> m (Maybe Char)+ outputStr :: String -> m ()+ outputStrLn :: String -> m ()+++instance MonadException m => MonadHaskeline (H.InputT m) where+ getInputLine = H.getInputLine+ getInputChar = H.getInputChar+ outputStr = H.outputStr+ outputStrLn = H.outputStrLn+++instance MonadState s m => MonadState s (HaskelineT m) where+ get = lift get+ put = lift . put++instance MonadHaskeline m => MonadHaskeline (StateT s m) where+ getInputLine = lift . getInputLine+ getInputChar = lift . getInputChar+ outputStr = lift . outputStr+ outputStrLn = lift . outputStrLn+
+ Templates.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TemplateHaskell#-}++module Templates(bakedString) where++import Foreign+++bakedString file =+ let x = unsafePerformIO $ readFile file+ in [| x |]
+ WARRANTY view
@@ -0,0 +1,8 @@+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+ hmumps.cabal view
@@ -0,0 +1,45 @@+-- hmumps.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: hmumps++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.1++Synopsis: Interpreter for the MUMPS langugae+Description: Partial interpreter for the MUMPS language.+ As this isn't nearly complete, it is mostly useful+ for educational purposes and exploring how the interpreter+ is constructed.+License: GPL+License-file: LICENSE+Author: Antoine Latter+Maintainer: aslatter@gmail.com+Copyright: 2007, 2009-2010 Antoine Latter+Category: Development+Build-type: Simple++Extra-source-files: SPLASH, WARRANTY++Cabal-version: >=1.6+++Executable hmumps+ Main-is: Main.hs+ + Build-depends: base == 4.*, haskell98, regex-compat, parsec == 3.1.*,+ QuickCheck == 1.*, mtl == 1.1.*, containers == 0.3.*,+ haskeline == 0.6.*, syb == 0.1.*, text == 0.7.*+ + Other-modules: Data.MArray+ Data.MValue+ HMumps.Parsers+ HMumps.Routine+ HMumps.Runtime+ HMumps.SyntaxTree+ HMumps.Types+ System.Console.Haskeline.Class+ Templates