diff --git a/Data/MArray.hs b/Data/MArray.hs new file mode 100644 --- /dev/null +++ b/Data/MArray.hs @@ -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) +-} diff --git a/Data/MValue.hs b/Data/MValue.hs new file mode 100644 --- /dev/null +++ b/Data/MValue.hs @@ -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 + +-} diff --git a/HMumps/Parsers.hs b/HMumps/Parsers.hs new file mode 100644 --- /dev/null +++ b/HMumps/Parsers.hs @@ -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 () diff --git a/HMumps/Routine.hs b/HMumps/Routine.hs new file mode 100644 --- /dev/null +++ b/HMumps/Routine.hs @@ -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 + + diff --git a/HMumps/Runtime.hs b/HMumps/Runtime.hs new file mode 100644 --- /dev/null +++ b/HMumps/Runtime.hs @@ -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) + diff --git a/HMumps/SyntaxTree.hs b/HMumps/SyntaxTree.hs new file mode 100644 --- /dev/null +++ b/HMumps/SyntaxTree.hs @@ -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 diff --git a/HMumps/Types.hs b/HMumps/Types.hs new file mode 100644 --- /dev/null +++ b/HMumps/Types.hs @@ -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 _ = "" +-} + +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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. + + + Copyright (C) + + 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 . + +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: + + Copyright (C) + 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 +. + + 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 +. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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") diff --git a/SPLASH b/SPLASH new file mode 100644 --- /dev/null +++ b/SPLASH @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Console/Haskeline/Class.hs b/System/Console/Haskeline/Class.hs new file mode 100644 --- /dev/null +++ b/System/Console/Haskeline/Class.hs @@ -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 + diff --git a/Templates.hs b/Templates.hs new file mode 100644 --- /dev/null +++ b/Templates.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell#-} + +module Templates(bakedString) where + +import Foreign + + +bakedString file = + let x = unsafePerformIO $ readFile file + in [| x |] diff --git a/WARRANTY b/WARRANTY new file mode 100644 --- /dev/null +++ b/WARRANTY @@ -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. diff --git a/hmumps.cabal b/hmumps.cabal new file mode 100644 --- /dev/null +++ b/hmumps.cabal @@ -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