Changeset 33

Show
Ignore:
Timestamp:
02/17/05 04:57:49 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
1041
Message:

* some IO primitives: open/close/<> etc

Location:
src
Files:
7 modified

Legend:

Unmodified
Added
Removed

  • src/AST.hs

    r32 r33  
    126126    vCast x = MkArray (vCast x)  
    127127 
     128instance Value MVal where 
     129    castV ref = unsafePerformIO $ readIORef ref 
     130 
    128131{- 
    129132instance Value VJunc where 
    … …  
    139142    vCast (VUndef)      = [] 
    140143    vCast v             = [v] 
     144 
     145instance Value VIO where 
     146    castV = VIO 
     147    doCast (VIO x) = x 
    141148 
    142149instance Value (Maybe a) where 
    … …  
    210217    | VJunc     VJunc 
    211218    | VError    VStr Exp 
     219    | VIO       VIO 
    212220    | VControl  VControl 
    213221    deriving (Show, Eq, Ord) 
    … …  
    261269instance Ord VComplex where {- ... -} 
    262270instance (Ord a, Ord b) => Ord (FiniteMap a b) 
     271instance Ord MVal where 
     272    compare x y = compare (castV x) (castV y) 
     273instance Show MVal where 
     274    show = show . castV 
     275instance Ord VIO where 
     276    compare x y = compare (show x) (show y) 
    263277 
    264278type Var = String 
     279type MVal = IORef Val 
     280type VIO = Handle 
    265281 
    266282data Exp 
    … …  
    269285    | Sym Symbol 
    270286    | Prim ([Val] -> Eval Val) 
     287    | MVal MVal 
    271288    | Val Val 
    272289    | Var Var 

  • src/Eval.hs

    r32 r33  
    7070    exp' <- local (\e -> e{ envBody = exp }) reduce 
    7171    debug "indent" (tail) " Ret" exp' 
    72     return $ case exp' of 
    73         Val v       -> v 
    74         otherwise   -> VError "Invalid expression" exp' 
     72    case exp' of 
     73        Val v       -> return v 
     74        MVal mv     -> liftIO $ readIORef mv 
     75        otherwise   -> return $ VError "Invalid expression" exp' 
    7576 
    7677evalExp :: Exp -> Eval Val 
    … …  
    101102retVal val = return $ Val val 
    102103 
    103 reduceStatements :: [Exp] -> Eval Exp 
    104 reduceStatements [] = retVal VUndef 
    105 reduceStatements [exp] = do 
    106     val <- evalExp exp 
    107     retVal val 
    108 reduceStatements (exp:rest) 
    109     | Syn "sym" [Sym sym@(Symbol SGlobal _ _)] <- exp = do 
     104newMVal val = do 
     105    mval <- liftIO $ newIORef val 
     106    return $ MVal mval 
     107 
     108reduceStatements :: ([Exp], Exp) -> Eval Exp 
     109reduceStatements ([], exp) = reduceExp exp 
     110reduceStatements ((exp:rest), _) 
     111    | Syn "sym" [Sym sym@(Symbol _ name (Syn "mval" [_, vexp]))] <- exp = do 
     112        val <- enterEvalContext (cxtOfSigil $ head name) vexp 
     113        mval <- newMVal val 
     114        reduceStatements ((Syn "sym" [Sym sym{ symExp = mval }]:rest), mval) 
     115    | Syn "sym" [Sym sym@(Symbol SGlobal _ vexp)] <- exp = do 
    110116        local (\e -> e{ envGlobal = (sym:envGlobal e) }) $ do 
    111             reduceStatements rest 
    112     | Syn "sym" [Sym sym@(Symbol SMy _ _)] <- exp = do 
     117            reduceStatements (rest, vexp) 
     118    | Syn "sym" [Sym sym@(Symbol SMy _ vexp)] <- exp = do 
    113119        enterLex [sym] $ do 
    114             reduceStatements rest 
    115     | Syn syn [Var name, exp'] <- exp 
     120            reduceStatements (rest, vexp) 
     121    | Syn syn [Var name, vexp] <- exp 
    116122    , (syn == ":=" || syn == "::=") = do 
    117123        lex <- asks envLexical 
    118124        case findSym name lex of 
    119125            Just _  -> do 
    120                 let sym = (Symbol SMy name exp') 
     126                let sym = (Symbol SMy name vexp) 
    121127                enterLex [sym] $ do 
    122                     reduceStatements rest 
     128                    reduceStatements (rest, vexp) 
    123129            Nothing -> do 
    124                 let sym = (Symbol SGlobal name exp') 
     130                let sym = (Symbol SGlobal name vexp) 
    125131                local (\e -> e{ envGlobal = (sym:envGlobal e) }) $ do 
    126                     reduceStatements rest 
     132                    reduceStatements (rest, vexp) 
    127133    | otherwise = do 
    128134        val <- enterContext "Void" $ evalExp exp 
    129135        processVal val $ do 
    130             reduceStatements rest 
     136            reduceStatements (rest, Val val) 
    131137    where 
    132138    processVal val action = case val of 
    … …  
    134140        _           -> action 
    135141 
     142findVar Env{ envLexical = lex, envGlobal = glob } name 
     143    | Just vexp <- findSym name lex 
     144    = Just vexp 
     145    | Just vexp <- findSym name glob 
     146    = Just vexp 
     147    | Just vexp <- findSym (toGlobal name) glob 
     148    = Just vexp 
     149    | otherwise 
     150    = Nothing 
     151     
    136152doReduce :: Env -> Exp -> Eval Exp 
    137153 
     154doReduce env exp@(MVal mval) = 
     155    retVal =<< liftIO (readIORef mval) 
     156 
    138157-- Reduction for variables 
    139 doReduce Env{ envLexical = lex, envGlobal = glob } exp@(Var var) 
    140     | Just vexp <- findSym var lex 
    141     = reduceExp vexp 
    142     | Just vexp <- findSym var glob 
    143     = reduceExp vexp 
    144     | Just vexp <- findSym (toGlobal var) glob 
     158doReduce env exp@(Var name) 
     159    | Just vexp <- findVar env name 
    145160    = reduceExp vexp 
    146161    | otherwise 
    147     = retVal $ VError ("Undefined variable " ++ var) exp 
     162    = retVal $ VError ("Undefined variable " ++ name) exp 
    148163 
    149164-- Reduction for syntactic constructs 
    … …  
    151166    ";" -> do 
    152167        let (global, local) = partition isGlobalExp exps 
    153         reduceStatements (global ++ local) 
     168        reduceStatements (global ++ local, Val VUndef) 
    154169    "sym" -> do 
    155170        let [Sym (Symbol _ _ exp)] = exps 
    156171        val     <- evalExp exp 
    157172        retVal VUndef 
     173    "mval" -> do 
     174        let [Var name, exp] = exps 
     175        val     <- enterEvalContext (cxtOfSigil $ head name) exp 
     176        newMVal val 
     177    "=" -> do 
     178        let [Var name, exp] = exps 
     179        case findVar env name of 
     180            Nothing -> retVal $ VError ("Undefined variable " ++ name) exp 
     181            Just (MVal mv) -> do 
     182                val <- enterEvalContext (cxtOfSigil $ head name) exp 
     183                liftIO $ writeIORef mv val 
     184                return (MVal mv) 
     185            _ -> do 
     186                retVal $ VError "Can't modify constant item" exp 
    158187    ":=" -> do 
    159         let [Var var, exp] = exps 
    160         val     <- enterEvalContext (cxtOfSigil $ head var) exp 
     188        let [Var name, exp] = exps 
     189        val     <- enterEvalContext (cxtOfSigil $ head name) exp 
    161190        retVal val 
    162191    "::=" -> do -- XXX wrong 
    163         let [Var var, exp] = exps 
     192        let [Var name, exp] = exps 
    164193        val     <- evalExp exp 
    165194        retVal VUndef -- XXX wrong 

  • src/Lexer.hs

    r32 r33  
    4040braces     = P.braces perl6Lexer 
    4141brackets   = P.brackets perl6Lexer 
     42angles     = P.angles perl6Lexer 
    4243 
    4344symbol s 

  • src/Main.hs

    r32 r33  
    8585runProgramWith fenv f name args prog = do 
    8686    env <- emptyEnv 
    87     let env' = runRule (prepare $ fenv env) id ruleProgram prog 
     87    str <- getContents 
     88    let env' = runRule (prepare str $ fenv env) id ruleProgram prog 
    8889    val <- (`runReaderT` env') $ do 
    8990        (`runContT` return) $ do 
    … …  
    9192    f val 
    9293    where 
    93     prepare e = e{ envGlobal = 
     94    prepare str e = e{ envGlobal = 
    9495        [ Symbol SGlobal "@*ARGS" (Val $ VList $ map VStr args) 
    9596        , Symbol SGlobal "$*PROGNAME" (Val $ VStr name) 
     97        , Symbol SGlobal "$*STDIN" (Val $ VStr str) 
    9698        ] ++ envGlobal e } 
    9799 

  • src/Parser.hs

    r32 r33  
    149149    scope   <- ruleScope 
    150150    name    <- parseVarName 
    151     exp     <- option (Val VUndef) $ do 
    152         tryChoice $ map symbol $ words " = := ::= " 
    153         ruleExpression 
     151    exp     <- option (Syn "mval" [Var name, Val VUndef]) $ do 
     152        sym <- tryChoice $ map symbol $ words " = := ::= " 
     153        exp <- ruleExpression 
     154        return $ case sym of 
     155            "=" -> (Syn "mval" [Var name, exp]) 
     156            _   -> exp 
    154157    return $ Syn "sym" [Sym $ Symbol scope name exp] 
    155158 
    … …  
    400403    , namedLiteral "Inf"    (VNum $ 1/0) 
    401404    , dotdotdotLiteral 
    402     ] 
     405    , angleLiteral 
     406    ] 
     407 
     408angleLiteral = try $ do 
     409    exp <- angles $ option Nothing $ return . Just =<< parseTerm 
     410    return $ case exp of 
     411        Nothing  -> App "&prefix:<>" [] [] 
     412        Just exp -> App "&prefix:<>" [] [exp] 
    403413 
    404414numLiteral = do 

  • src/Pretty.hs

    r31 r33  
    6666    pretty (VArray (MkArray x)) = pretty (VList x) 
    6767    pretty (VHash (MkHash x)) = show x 
     68    pretty (VIO x) = show x 
    6869    pretty VUndef = "undef" 
    6970 

  • src/Prim.hs

    r32 r33  
    5757op1 "print" = \v -> do 
    5858    liftIO . putStr . concatMap vCast . vCast $ v 
    59     return $ VUndef 
     59    return $ VBool True 
    6060op1 "say" = \v -> do 
    61     liftIO . putStrLn . concatMap vCast . vCast $ v 
    62     return $ VUndef 
     61    liftIO . mapM (putStrLn . vCast) . vCast $ v 
     62    return $ VBool True 
    6363op1 "die" = \v -> do 
    6464    return $ VError (concatMap vCast . vCast $ v) (Val v) 
    … …  
    6767        then liftIO $ exitWith (ExitFailure $ vCast v) 
    6868        else liftIO $ exitWith ExitSuccess 
    69  
     69-- handle timely destruction 
     70op1 "open" = \v -> do 
     71    fh <- liftIO $ openFile (vCast v) ReadMode 
     72    return $ VIO fh 
     73op1 "close" = \v -> do 
     74    liftIO $ hClose (vCast v) 
     75    return $ VBool True 
     76op1 "<>" = \v -> do 
     77    str <- readFrom v 
     78    cxt <- asks envContext 
     79    return $ if ((cxt ==) `any` ["Array", "List"]) -- XXX use isaType here 
     80        then VList $ map VStr $ lines str 
     81        else VStr str 
     82    where 
     83    readFrom VUndef = do 
     84        -- ARGS etc 
     85        glob <- asks envGlobal 
     86        strs <- liftIO $ sequence $ case find ((== "@*ARGS") . symName) glob of 
     87            Nothing     -> [getStdin glob] 
     88            Just sym    -> case symExp sym of 
     89                Val (VList [])  -> [getStdin glob] 
     90                Val (VList xs)  -> map ((hGetContents =<<) . (`openFile` ReadMode) . vCast) xs 
     91                _               -> error "not handled" 
     92        return $ concat strs 
     93    readFrom v = do 
     94        liftIO $ hGetContents $ vCast v 
     95    getStdin glob = do 
     96        case find ((== "$*STDIN") . symName) glob of 
     97            Just sym | (Val v) <- symExp sym -> return $ vCast v 
     98            _                                -> error "impossible" 
    7099op1 s      = return . (\x -> VError ("unimplemented unaryOp: " ++ s) (Val x)) 
    71100 
    … …  
    272301\\n   Action    pre     die     (List)\ 
    273302\\n   Any       pre     do      (Str)\ 
     303\\n   IO        pre     open    (Str)\ 
    274304\\n   Any       pre     return  (Any)\ 
     305\\n   Any       pre     <>      ()\ 
    275306\\n   Junction  pre     any     (List)\ 
    276307\\n   Junction  pre     all     (List)\