Changeset 2951

Show
Ignore:
Timestamp:
05/11/05 00:04:52 (4 years ago)
Author:
bsmith
svk:copy_cache_prev:
4498
Message:

Refactoring: Pugs.Prim.List, Pugs.Prim.Numeric, Pugs.AST.SIO.
Moved strRangeInf et al from Pugs.AST.Internals to Pugs.AST.

Location:
src/Pugs
Files:
5 added
4 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/AST.hs

    r2950 r2951  
    3737    ThunkClass(..), 
    3838 
    39     MonadSTM(..), 
    4039    -- MonadEval(..), 
    4140 
    42     runSTM, runIO, runEvalSTM, runEvalIO, shiftT, resetT, runEvalMain, 
     41    runEvalSTM, runEvalIO, shiftT, resetT, runEvalMain, 
    4342    evalExp, 
    4443    undef, defined, 
    … …  
    6362    doPair, doHash, doArray, 
    6463 
    65     -- TODO: move to Pugs.Parser.NaturalOrRat 
    66     naturalOrRat, 
    67  
    6864    module Pugs.AST.Pos, 
    6965    module Pugs.AST.Scope, 
     66    module Pugs.AST.SIO, 
    7067) where 
     68import Pugs.Internals 
    7169 
    7270import Pugs.AST.Internals 
    7371import Pugs.AST.Pos 
    7472import Pugs.AST.Scope 
     73import Pugs.AST.SIO 
     74 
     75-- |Return an infinite (lazy) Haskell list of the given string and its 
     76-- successors. 'strInc' is used to determine what the \'next\' string is. 
     77-- Is used to implement the @...@ infinite-range operator on strings. 
     78strRangeInf :: String -> [String] 
     79strRangeInf s = (s:strRangeInf (strInc s)) 
     80 
     81-- |Return a range of strings from the first argument to the second, inclusive 
     82-- (as a Haskell list). 'strInc' is used to determine what the \'next\' string  
     83-- is. Is used to implement the @..@ range operator on strings. 
     84strRange :: String -> String -> [String] 
     85strRange s1 s2 
     86    | s1 == s2              = [s2] 
     87    | length s1 > length s2 = [] 
     88    | otherwise             = (s1:strRange (strInc s1) s2) 
     89 
     90-- |Find the successor of a string (i.e. the next string \'after\' it). 
     91-- Special rules are used to handle strings ending in an alphanumeric 
     92-- character; otherwise the last character is simply incremented using 
     93-- 'charInc'. 
     94strInc :: String -> String 
     95strInc []       = "1" 
     96strInc "z"      = "aa" 
     97strInc "Z"      = "AA" 
     98strInc "9"      = "10" 
     99strInc str 
     100    | x == 'z'  = strInc xs ++ "a" 
     101    | x == 'Z'  = strInc xs ++ "A" 
     102    | x == '9'  = strInc xs ++ "0" 
     103    | otherwise = xs ++ [charInc x] 
     104    where 
     105    x   = last str 
     106    xs  = init str 
     107 
     108-- |Return the code-point-wise successor of a given character. 
     109charInc :: Char -> Char 
     110charInc x   = chr $ 1 + ord x 
     111 

  • src/Pugs/AST/Internals.hs

    r2950 r2951  
    1111import qualified Data.IntMap    as IntMap 
    1212 
     13import Pugs.Parser.Number 
    1314import Pugs.AST.Pos 
    1415import Pugs.AST.Scope 
     16import Pugs.AST.SIO 
    1517 
    1618#include "../Types/Array.hs" 
    … …  
    392394    castV = id -- XXX not really correct; need to referencify things 
    393395 
    394 -- |Return an infinite (lazy) Haskell list of the given string and its 
    395 -- successors. 'strInc' is used to determine what the \'next\' string is. 
    396 -- Is used to implement the @...@ infinite-range operator on strings. 
    397 strRangeInf :: String -> [String] 
    398 strRangeInf s = (s:strRangeInf (strInc s)) 
    399  
    400 -- |Return a range of strings from the first argument to the second, inclusive 
    401 -- (as a Haskell list). 'strInc' is used to determine what the \'next\' string  
    402 -- is. Is used to implement the @..@ range operator on strings. 
    403 strRange :: String -> String -> [String] 
    404 strRange s1 s2 
    405     | s1 == s2              = [s2] 
    406     | length s1 > length s2 = [] 
    407     | otherwise             = (s1:strRange (strInc s1) s2) 
    408  
    409 -- |Find the successor of a string (i.e. the next string \'after\' it). 
    410 -- Special rules are used to handle strings ending in an alphanumeric 
    411 -- character; otherwise the last character is simply incremented using 
    412 -- 'charInc'. 
    413 strInc :: String -> String 
    414 strInc []       = "1" 
    415 strInc "z"      = "aa" 
    416 strInc "Z"      = "AA" 
    417 strInc "9"      = "10" 
    418 strInc str 
    419     | x == 'z'  = strInc xs ++ "a" 
    420     | x == 'Z'  = strInc xs ++ "A" 
    421     | x == '9'  = strInc xs ++ "0" 
    422     | otherwise = xs ++ [charInc x] 
    423     where 
    424     x   = last str 
    425     xs  = init str 
    426  
    427 -- |Return the code-point-wise successor of a given character. 
    428 charInc :: Char -> Char 
    429 charInc x   = chr $ 1 + ord x 
    430  
    431396intCast :: Num b => Val -> b 
    432397intCast x   = fromIntegral (vCast x :: VInt) 
    … …  
    905870newtype EvalT m a = EvalT { runEvalT :: m a } 
    906871 
    907 data SIO a = MkSTM !(STM a) | MkIO !(IO a) | MkSIO !a 
    908     deriving (Typeable) 
    909  
    910 runSTM :: SIO a -> STM a 
    911 runSTM (MkSTM stm)  = stm 
    912 runSTM (MkIO _ )    = fail "Unsafe IO caught in STM" 
    913 {- 
    914 do 
    915     let rv = unsafePerformIO io 
    916     trace ("*** Unsafe CALL!") return rv 
    917 -} 
    918 runSTM (MkSIO x)    = return x 
    919  
    920 runIO :: SIO a -> IO a 
    921 runIO (MkIO io)     = io 
    922 runIO (MkSTM stm)   = atomically stm 
    923 runIO (MkSIO x)     = return x 
    924  
    925872runEvalSTM :: Env -> Eval Val -> STM Val 
    926873runEvalSTM env = runSTM . (`runReaderT` env) . (`runContT` return) . runEvalT 
    … …  
    936883resetT e = lift . lift $ 
    937884    runContT (runEvalT e) return 
    938  
    939 instance Monad SIO where 
    940     return a = MkSIO a 
    941     (MkIO io)   >>= k = MkIO $ do { a <- io; runIO (k a) } 
    942     (MkSTM stm) >>= k = MkSTM $ do { a <- stm; runSTM (k a) } 
    943     (MkSIO x)   >>= k = k x 
    944885 
    945886instance Monad EvalMonad where 
    … …  
    958899    fmap f (EvalT a) = EvalT (fmap f a) 
    959900 
    960 class (Monad m) => MonadSTM m where 
    961     liftSTM :: STM a -> m a 
    962  
    963901instance MonadIO EvalMonad where 
    964902    liftIO io = EvalT (liftIO io) 
    … …  
    968906    -- liftSTM stm = EvalT (lift . lift . liftSTM $ stm) 
    969907    liftSTM stm = EvalT (lift . lift . liftIO . liftSTM $ stm) 
    970  
    971 instance MonadSTM STM where 
    972     liftSTM = id 
    973  
    974 instance MonadSTM IO where 
    975     liftSTM = atomically 
    976  
    977 instance MonadIO SIO where 
    978     liftIO io = MkIO io 
    979  
    980 instance MonadSTM SIO where 
    981     liftSTM stm = MkSTM stm 
    982908 
    983909instance MonadReader Env EvalMonad where 
    … …  
    1052978retError :: (Show a) => VStr -> a -> Eval b 
    1053979retError str a = fail $ str ++ ": " ++ show a 
    1054  
    1055 naturalOrRat :: GenParser Char st (Either Integer (Ratio Integer)) 
    1056 naturalOrRat  = (<?> "number") $ do 
    1057     sig <- sign 
    1058     num <- natRat 
    1059     return $ if sig 
    1060         then num 
    1061         else case num of 
    1062             Left i  -> Left $ -i 
    1063             Right d -> Right $ -d 
    1064     where 
    1065     natRat = do 
    1066             char '0' 
    1067             zeroNumRat 
    1068         <|> decimalRat 
    1069  
    1070     zeroNumRat = do 
    1071             n <- hexadecimal <|> decimal <|> octalBad <|> octal <|> binary 
    1072             return (Left n) 
    1073         <|> decimalRat 
    1074         <|> fractRat 0 
    1075         <|> return (Left 0) 
    1076  
    1077     decimalRat = do 
    1078         n <- decimalLiteral 
    1079         option (Left n) (try $ fractRat n) 
    1080  
    1081     fractRat n = do 
    1082             fract <- try fraction 
    1083             expo  <- option (1%1) expo 
    1084             return (Right $ ((n % 1) + fract) * expo) -- Right is Rat 
    1085         <|> do 
    1086             expo <- expo 
    1087             if expo < 1 
    1088                 then return (Right $ (n % 1) * expo) 
    1089                 else return (Right $ (n % 1) * expo) 
    1090  
    1091     fraction = do 
    1092             char '.' 
    1093             notFollowedBy . satisfy $ \x -> 
    1094                 (isAlpha x && ((x /=) `all` "eE")) 
    1095                 || ((x ==) `any` ".=") 
    1096             digits <- many digit <?> "fraction" 
    1097             return (digitsToRat digits) 
    1098         <?> "fraction" 
    1099         where 
    1100         digitsToRat d = digitsNum d % (10 ^ length d) 
    1101         digitsNum d = foldl (\x y -> x * 10 + (toInteger $ digitToInt y)) 0 d 
    1102  
    1103     expo :: GenParser Char st Rational 
    1104     expo = do 
    1105             oneOf "eE" 
    1106             f <- sign 
    1107             e <- decimalLiteral <?> "exponent" 
    1108             return (power (if f then e else -e)) 
    1109         <?> "exponent" 
    1110         where 
    1111         power e | e < 0      = 1 % (10^abs(e)) 
    1112                 | otherwise  = (10^e) % 1 
    1113  
    1114     sign            =   (char '-' >> return False) 
    1115                     <|> (char '+' >> return True) 
    1116                     <|> return True 
    1117  
    1118     decimalLiteral         = number 10 digit 
    1119     hexadecimal     = do{ char 'x'; number 16 hexDigit } 
    1120     decimal         = do{ char 'd'; number 10 digit } 
    1121     octal           = do{ char 'o'; number 8 octDigit } 
    1122     octalBad        = do{ many1 octDigit ; fail "0100 is not octal in perl6 any more, use 0o100 instead." } 
    1123     binary          = do{ char 'b'; number 2 (oneOf "01")  } 
    1124  
    1125     number base baseDigit 
    1126         = do{ digits <- many1 baseDigit 
    1127             ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits 
    1128             ; seq n (return n) 
    1129             } 
    1130980 
    1131981-- |Evaluate the given expression, using the currently active evaluator 

  • src/Pugs/Parser.hs

    r2944 r2951  
    2222import Pugs.Pretty 
    2323import qualified Data.Set as Set 
     24 
     25import Pugs.Parser.Number 
    2426 
    2527-- Lexical units -------------------------------------------------- 

  • src/Pugs/Prim.hs

    r2941 r2951  
    2020import Pugs.External 
    2121import Text.Printf 
    22 import qualified Data.Set as Set 
    2322 
    2423import Pugs.Prim.Keyed 
    … …  
    2625import Pugs.Prim.Match 
    2726import qualified Pugs.Prim.FileTest as FileTest 
     27import Pugs.Prim.List 
     28import Pugs.Prim.Numeric 
    2829 
    2930op0 :: Ident -> [Val] -> Eval Val 
    … …  
    5455op0 "return" = \v -> return (VError "cannot return() outside a subroutine" (Val $ VList v)) 
    5556op0 other = \_ -> fail ("Unimplemented listOp: " ++ other) 
    56  
    57 op0Zip :: [[Val]] -> [[Val]] 
    58 op0Zip lists | all null lists = [] 
    59 op0Zip lists = (map zipFirst lists):(op0Zip (map zipRest lists)) 
    60     where 
    61     zipFirst []     = undef 
    62     zipFirst (x:_)  = x 
    63     zipRest  []     = [] 
    64     zipRest  (_:xs) = xs 
    6557 
    6658op1 :: Ident -> Val -> Eval Val 
    … …  
    225217    else return undef 
    226218 
    227 op1 ('[':op) = op1Fold . init $ op 
     219op1 ('[':op) = op1Fold . op2 . init $ op 
    228220op1 "rand"  = \v -> do 
    229221    x    <- fromVal v 
    … …  
    431423op1mkType str = (VStr . showType . mkType) str 
    432424 
    433 op1Fold :: String -> Val -> Eval Val 
    434 op1Fold op v = do 
    435     args    <- fromVal v 
    436     case args of 
    437         (a:as)  -> foldM (op2 op) a as 
    438         _       -> return undef 
    439  
    440  
    441425op1EvalHaskell :: Val -> Eval Val 
    442426op1EvalHaskell cv = do 
    … …  
    467451        []      -> [] 
    468452        (c:cs)  -> (f c:cs) 
    469  
    470 op1Pick :: Val -> Eval Val 
    471 op1Pick (VRef r) = op1Pick =<< readRef r 
    472 op1Pick (VList []) = return undef 
    473 op1Pick (VList vs) = do 
    474     rand <- liftIO $ randomRIO (0, length vs - 1) 
    475     return $ vs !! rand 
    476 op1Pick (VJunc (MkJunc _ _ set)) | Set.null set = return undef 
    477 op1Pick (VJunc (MkJunc JAny _ set)) = do -- pick mainly works on 'any' 
    478     rand <- liftIO $ randomRIO (0 :: Int, (Set.size set) - 1) 
    479     return $ (Set.elems set) !! rand 
    480 op1Pick (VJunc (MkJunc JNone _ _)) = return undef 
    481 op1Pick (VJunc (MkJunc JAll _ set)) = 
    482     if (Set.size $ set) == 1 then return $ head $ Set.elems set 
    483     else return undef 
    484 op1Pick (VJunc (MkJunc JOne dups set)) = 
    485     if (Set.size $ set) == 1 && (Set.size $ dups) == 0 
    486     then return $ head $ Set.elems set 
    487     else return undef 
    488 op1Pick v = return $ VError "pick not defined" (Val v) 
    489  
    490 op1Sum :: Val -> Eval Val 
    491 op1Sum list = do 
    492     vals <- fromVal list 
    493     foldM (op2 "+") undef vals 
    494453 
    495454op1Print :: (Handle -> String -> IO ()) -> Val -> Eval Val 
    … …  
    834793    return $ castV idx 
    835794 
    836 op2Fold :: Val -> Val -> Eval Val 
    837 op2Fold sub@(VCode _) list = op2Fold list sub 
    838 op2Fold list sub = do 
    839     args <- fromVal list 
    840     if null args then return undef else do 
    841     let doFold x y = do 
    842         evl <- asks envEval 
    843         local (\e -> e{ envContext = cxtItemAny }) $ do 
    844             evl (App (Val sub) [Val x, Val y] []) 
    845     foldM doFold (head args) (tail args) 
    846  
    847 op2Grep :: Val -> Val -> Eval Val 
    848 op2Grep sub@(VCode _) list = op2Grep list sub 
    849 op2Grep list sub = do 
    850     args <- fromVal list 
    851     vals <- (`filterM` args) $ \x -> do 
    852         evl <- asks envEval 
    853         rv  <- local (\e -> e{ envContext = cxtItem "Bool" }) $ do 
    854             evl (App (Val sub) [Val x] []) 
    855         fromVal rv 
    856     return $ VList vals 
    857  
    858 op2Map :: Val -> Val -> Eval Val 
    859 op2Map sub@(VCode _) list = op2Map list sub 
    860 op2Map list sub = do 
    861     args <- fromVal list 
    862     vals <- (`mapM` args) $ \x -> do 
    863         evl <- asks envEval 
    864         rv  <- local (\e -> e{ envContext = cxtSlurpyAny }) $ do 
    865             evl (App (Val sub) [Val x] []) 
    866         fromVal rv 
    867     return $ VList $ concat vals 
    868  
    869 op2Join :: Val -> Val -> Eval Val 
    870 op2Join x y = do 
    871     (strVal, listVal) <- ifValTypeIsa x "Scalar" 
    872         (return (x, y)) 
    873         (return (y, x)) 
    874     str     <- fromVal strVal 
    875     ref     <- fromVal listVal 
    876     list    <- readRef ref 
    877     strList <- fromVals list 
    878     return . VStr . concat . intersperse str $ strList 
    879  
    880795vCastStr :: Val -> Eval VStr 
    881796vCastStr = fromVal 
    … …  
    996911        EQ -> 0 
    997912        GT -> 1 
    998  
    999 op1Floating :: (Double -> Double) -> Val -> Eval Val 
    1000 op1Floating f v = do 
    1001     foo <- fromVal v 
    1002     return $ VNum $ f foo 
    1003  
    1004 op1Numeric :: (forall a. (Num a) => a -> a) -> Val -> Eval Val 
    1005 op1Numeric f VUndef     = return . VInt $ f 0 
    1006 op1Numeric f (VInt x)   = return . VInt $ f x 
    1007 op1Numeric f l@(VList _)= fmap (VInt . f) (fromVal l) 
    1008 op1Numeric f (VRat x)   = return . VRat $ f x 
    1009 op1Numeric f (VRef x)   = op1Numeric f =<< readRef x 
    1010 op1Numeric f x          = fmap (VNum . f) (fromVal x) 
    1011  
    1012 --- XXX wrong: try num first, then int, then vcast to Rat (I think) 
    1013 op2Numeric :: (forall a. (Num a) => a -> a -> a) -> Val -> Val -> Eval Val 
    1014 op2Numeric f x y 
    1015     | VUndef <- x = op2Numeric f (VInt 0) y 
    1016     | VUndef <- y = op2Numeric f x (VInt 0) 
    1017     | (VInt x', VInt y') <- (x, y)  = return $ VInt $ f x' y' 
    1018     | (VRat x', VInt y') <- (x, y)  = return $ VRat $ f x' (y' % 1) 
    1019     | (VInt x', VRat y') <- (x, y)  = return $ VRat $ f (x' % 1) y' 
    1020     | (VRat x', VRat y') <- (x, y)  = return $ VRat $ f x' y' 
    1021     | VRef r <- x = do 
    1022         x' <- readRef r 
    1023         op2Numeric f x' y 
    1024     | VRef r <- y = do 
    1025         y' <- readRef r 
    1026         op2Numeric f x y' 
    1027     | otherwise = do 
    1028         x' <- fromVal x 
    1029         y' <- fromVal y 
    1030         return . VNum $ f x' y' 
    1031913 
    1032914primOp :: String -> String -> Params -> String -> STM (Pad -> Pad) 
    … …  
    11211003    return $ "(" ++ concat (intersperse ", " vs') ++ ")" 
    11221004prettyVal _ v = return $ pretty v 
    1123  
    1124 sortByM :: (Val -> Val -> Eval Bool) -> [Val] -> Eval [Val] 
    1125 sortByM _ []  = return [] 
    1126 sortByM _ [x] = return [x] 
    1127 sortByM f xs  = do 
    1128     let (as, bs) = splitAt (length xs `quot` 2) xs 
    1129     aSorted <- sortByM f as 
    1130     bSorted <- sortByM f bs 
    1131     doMerge f aSorted bSorted 
    1132     where 
    1133     doMerge :: (Val -> Val -> Eval Bool) -> [Val] -> [Val] -> Eval [Val] 
    1134     doMerge _ [] ys = return ys 
    1135     doMerge _ xs [] = return xs 
    1136     doMerge f (x:xs) (y:ys) = do 
    1137         isLessOrEqual <- f x y 
    1138         if isLessOrEqual 
    1139             then do 
    1140                 rest <- doMerge f xs (y:ys) 
    1141                 return (x:rest) 
    1142             else do 
    1143                 rest <- doMerge f (x:xs) ys 
    1144                 return (y:rest) 
    11451005 
    11461006-- XXX -- Junctive Types -- XXX --