Changeset 26

Show
Ignore:
Timestamp:
02/14/05 06:02:18 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
1041
Message:

* snapshot during monadic refactoring

Location:
src
Files:
9 modified

Legend:

Unmodified
Added
Removed

  • src/AST.hs

    r25 r26  
    1818type Ident = String 
    1919 
    20 class Context n where 
     20class Value n where 
    2121    vCast :: Val -> n 
    2222    vCast (VRef v)      = vCast v 
    … …  
    3131    fmapVal f = castV . f . vCast 
    3232 
    33 instance Context (Val, Val) where 
     33instance Value (Val, Val) where 
    3434    castV (x, y)        = VPair x y 
    3535    vCast (VPair x y)   = (x, y) 
    … …  
    3939        other   -> error $ "cannot cast into (Val, Val): " ++ (show v) 
    4040 
    41 instance Context VHash where 
     41instance Value VHash where 
    4242    castV = VHash 
    4343    vCast x = MkHash $ listToFM (map vCast $ vCast x)  
    4444 
    45 instance Context VSub where 
     45instance Value VSub where 
    4646    castV = VSub 
    4747    doCast (VSub b) = b 
    4848 
    49 instance Context VBool where 
     49instance Value VBool where 
    5050    castV = VBool 
    5151    doCast (VJunc j)   = juncToBool j 
    … …  
    7070    = (1 ==) . length . filter vCast $ setToList vs 
    7171 
    72 instance Context VInt where 
     72instance Value VInt where 
    7373    castV = VInt 
    7474    doCast (VInt i)     = i 
    … …  
    7878    doCast x            = round (vCast x :: VNum) 
    7979 
    80 instance Context VRat where 
     80instance Value VRat where 
    8181    castV = VRat 
    8282    doCast (VInt i)     = i % 1 
    … …  
    8484    doCast x            = approxRational (vCast x :: VNum) 1 
    8585 
    86 instance Context VNum where 
     86instance Value VNum where 
    8787    castV = VNum 
    8888    doCast VUndef       = 0 
    … …  
    9797    doCast x            = error $ "cannot cast: " ++ (show x) 
    9898 
    99 instance Context VComplex where 
     99instance Value VComplex where 
    100100    castV = VComplex 
    101101    doCast x            = (vCast x :: VNum) :+ 0 
    102102 
    103 instance Context VStr where 
     103instance Value VStr where 
    104104    castV = VStr 
    105105    vCast VUndef        = "" 
    … …  
    121121    str = show x  
    122122 
    123 instance Context VArray where 
     123instance Value VArray where 
    124124    castV = VArray 
    125125    vCast x = MkArray (vCast x)  
    126126 
    127127{- 
    128 instance Context VJunc where 
     128instance Value VJunc where 
    129129    castV = JAny . castV 
    130130    vCast x = JAny $ mkSet (vCast x) 
    131131-} 
    132132 
    133 instance Context VList where 
     133instance Value VList where 
    134134    castV = VList 
    135135    vCast (VList l)     = l 
    … …  
    139139    vCast v             = [v] 
    140140 
    141 instance Context (Maybe a) where 
     141instance Value (Maybe a) where 
    142142    vCast VUndef        = Nothing 
    143143    vCast _             = Just undefined 
    144144 
    145 instance Context Int   where doCast = intCast 
    146 instance Context Word  where doCast = intCast 
    147 instance Context Word8 where doCast = intCast 
    148 instance Context [Word8] where doCast = map (toEnum . ord) . vCast 
     145instance Value Int   where doCast = intCast 
     146instance Value Word  where doCast = intCast 
     147instance Value Word8 where doCast = intCast 
     148instance Value [Word8] where doCast = map (toEnum . ord) . vCast 
    149149 
    150150type VScalar = Val 
    151151-- type VJunc = Set Val 
    152152 
    153 instance Context VScalar where 
     153instance Value VScalar where 
    154154    vCast = id 
    155155    castV = id 
    … …  
    239239    , subName       :: String 
    240240    , subType       :: SubType 
    241     , subPad        :: Symbols 
     241    , subPad        :: Pad 
    242242    , subAssoc      :: String 
    243243    , subParams     :: Params 
    … …  
    257257-} 
    258258 
    259 instance Ord ([Val] -> StateEnv Val) where 
    260     compare _ _ = LT 
    261259instance (Ord a) => Ord (Set a) where 
    262260    compare x y = compare (setToList x) (setToList y) 
    … …  
    272270    | Syn String [Exp] 
    273271    | Sym Scope Var 
    274     | Prim ([Val] -> StateEnv Val) 
     272    | Prim ([Val] -> Eval Val) 
    275273    | Val Val 
    276274    | Var Var SourcePos 
    … …  
    326324defaultScalarParam  = buildParam "" "*" "$_" (Val VUndef) 
    327325 
    328 -- The eval monad! 
    329 type StateEnv a = State Env a 
    330  
    331326data Env = Env { envContext :: Cxt 
    332                , envPad     :: Symbols 
     327               , envPad     :: Pad 
    333328               , envClasses :: ClassTree 
    334329               , envEval    :: Exp -> Eval Val 
    … …  
    339334               } deriving (Show, Eq) 
    340335 
    341 type Symbols = [Symbol] 
     336type Pad = [Symbol] 
    342337data Symbol = Symbol { symScope :: Scope 
    343338                     , symName  :: String 

  • src/Eval.hs

    r25 r26  
    2222import Monad 
    2323 
    24 emptyEnv = Env { envContext = "List" 
    25                , envPad     = [initSyms] 
    26                , envClasses = initTree 
    27                , envEval    = evaluate 
    28                } 
    29  
    30 addSym :: Symbols -> StateEnv () 
    31 addSym syms = modify doAddSyms 
    32     where 
    33     doAddSyms env@Env{ envPad = (pad:outer) } = env{ envPad = ((syms++pad):outer) } 
    34  
    35 pushPad :: Symbols -> StateEnv () 
    36 pushPad syms = modify (\env -> env{ envPad = tail $ envPad env }) 
    37  
    38 popPad :: StateEnv () 
    39 popPad = modify (\env -> env{ envPad = tail $ envPad env }) 
    40  
    41 evaluate :: Exp -> StateEnv Val 
     24emptyEnv :: (MonadIO m) => m Env 
     25emptyEnv = do 
     26    uniq <- liftIO newUnique 
     27    return $ Env 
     28        { envContext = "List" 
     29        , envPad     = initSyms 
     30        , envClasses = initTree 
     31        , envEval    = evaluate 
     32        , envCC      = return 
     33        , envDepth   = 0 
     34        , envID      = uniq 
     35        , envBody    = Val VUndef 
     36        } 
     37 
     38evaluate :: Exp -> Eval Val 
    4239evaluate exp = do 
    43     val <- reduce exp 
     40    val <- local (\e -> e { envBody = exp }) reduce 
    4441    return $ case val of 
    4542        Val v       -> v 
    4643        otherwise   -> VError "Invalid expression" exp 
    4744 
     45evalEnv :: Exp -> Eval Val 
     46evalEnv exp = do 
     47    evl <- asks envEval 
     48    evl exp 
     49 
     50evalEnvWithContext :: Cxt -> Exp -> Eval Val 
     51evalEnvWithContext cxt exp = do 
     52    local (\e -> e { envContext = cxt }) $ evalEnv exp 
     53 
     54-- addSym :: Pad -> Eval () 
     55addSym syms f = local doAddSyms f 
     56    where 
     57    doAddSyms env@Env{ envPad = pad } = env{ envPad = syms++pad } 
     58 
    4859-- OK... Now let's implement the hideously clever autothreading algorithm. 
    4960-- First pass - thread thru all() and none() 
    5061-- Second pass - thread thru any() and one() 
    5162 
    52 chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> StateEnv Val 
     63chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> Eval Val 
    5364chainFun p1 f1 p2 f2 (v1:v2:vs) = do 
    5465    val <- applyFun (chainArgs p1 [v1, v2]) f1 
    … …  
    6071    chainArg (p, v) = ApplyArg (paramName p) v False 
    6172 
    62 applyFun :: [ApplyArg] -> Exp -> StateEnv Val 
     73applyFun :: [ApplyArg] -> Exp -> Eval Val 
    6374applyFun bound (Prim f) 
    6475    = f [ argValue arg | arg <- bound, (argName arg !! 1) /= '_' ] 
    6576applyFun bound body = do 
    66     pushPad formal 
    67     exp <- reduce body 
    68     return $ case exp of 
    69         Val val     -> val 
    70         otherwise   -> VError "Invalid expression" exp 
     77    -- pushPad formal 
     78    evalEnv body 
    7179    where 
    7280    formal = filter (not . null . symName) $ map argNameValue bound 
    7381    argNameValue (ApplyArg name val _) = Symbol SMy name val 
    7482 
    75 apply :: VSub -> [Exp] -> [Exp] -> StateEnv Exp 
     83apply :: VSub -> [Exp] -> [Exp] -> Eval Exp 
    7684apply sub invs args = do 
    77     env <- get 
     85    env <- ask 
    7886    doApply env sub invs args 
    7987 
    80 doApply :: Env -> VSub -> [Exp] -> [Exp] -> StateEnv Exp 
     88doApply :: Env -> VSub -> [Exp] -> [Exp] -> Eval Exp 
    8189doApply env@Env{ envClasses = cls } Sub{ subParams = prms, subFun = fun } invs args = 
    8290    case bindParams prms invs args of 
    … …  
    100108        | otherwise                     = False 
    101109 
    102 evalEnv exp = do 
    103     evl <- gets envEval 
    104     evl exp 
    105  
    106 evalEnvWithContext newCxt exp = do 
    107     Env{ envContext = cxt, envEval = evl } <- get 
    108     modify (\env -> env{ envContext = newCxt }) 
    109     val <- evl exp 
    110     modify (\env -> env{ envContext = cxt }) 
    111     return val 
    112  
    113110toGlobal name 
    114111    | (sigil, identifier) <- break (\x -> isAlpha x || x == '_') name 
    … …  
    117114    | otherwise = name 
    118115 
    119 retVal :: Val -> StateEnv Exp 
     116retVal :: Val -> Eval Exp 
    120117retVal val = return $ Val val 
    121118 
    … …  
    123120isGlobalExp _ = False 
    124121 
    125 findSym :: String -> [Symbols] -> Maybe Val 
     122findSym :: String -> Pad -> Maybe Val 
    126123findSym name pad 
    127     | Just s <- find ((== name) . symName) (concat pad) 
     124    | Just s <- find ((== name) . symName) pad 
    128125    = Just $ symValue s 
    129126    | otherwise 
    130127    = Nothing 
    131128 
    132 reduce :: Exp -> StateEnv Exp 
    133 reduce exp = do 
    134     env <- get 
    135     doReduce env exp 
     129reduce :: Eval Exp 
     130reduce = do 
     131    env@Env{ envBody = body } <- ask 
     132    doReduce env body 
    136133 
    137134doReduce Env{ envPad = pad } exp@(Var var _) 
    … …  
    152149        let [Var var _, exp] = exps 
    153150        val     <- evalEnv exp 
    154         addSym [Symbol SMy var val] -- XXX scope 
     151        -- addSym [Symbol SMy var val] -- XXX scope 
    155152        retVal val 
    156153    "::=" -> do -- XXX wrong 
    157154        let [Var var _, exp] = exps 
    158155        val     <- evalEnv exp 
    159         addSym [Symbol SMy var val] -- XXX scope 
     156        -- addSym [Symbol SMy var val] -- XXX scope 
    160157        retVal VUndef 
    161158    "=>" -> do 
    … …  
    234231        , fromJust fun 
    235232        ) 
    236         | ((Symbol _ n val), order) <- concat pad `zip` [0..] 
     233        | ((Symbol _ n val), order) <- pad `zip` [0..] 
    237234        , let sub@(Sub{ subType = subT, subReturns = ret, subParams = prms }) = vCast val 
    238235        , (n ==) `any` [name, toGlobal name] 
    … …  
    250247    deltaFromScalar x       = deltaType cls x "Scalar" 
    251248 
    252 doReduce _ (Parens exp) = reduce exp 
     249doReduce env (Parens exp) = doReduce env exp 
    253250doReduce _ other = return other 
    254251 

  • src/Internals.hs

    r25 r26  
    7777instance Eq (a -> b) where 
    7878    _ == _ = False 
     79instance Ord (a -> b) where 
     80    compare _ _ = LT 

  • src/Lexer.hs

    r25 r26  
    1515import qualified Text.ParserCombinators.Parsec.Token as P 
    1616 
    17 type Pad = [Symbols] 
    18 type RuleParser a = GenParser Char Pad a 
     17type RuleParser a = GenParser Char Env a 
    1918 
    2019perl6Def  = javaStyle 

  • src/Main.hs

    r25 r26  
    5353 
    5454doParse = parse 
    55 parse str = runRule emptyEnv (putStrLn . pretty) ruleProgram str 
     55parse str = do 
     56    env <- emptyEnv 
     57    runRule env (putStrLn . pretty) ruleProgram str 
    5658 
    5759eval str = doEval str [] 

  • src/Monads.hs

    r23 r26  
    164164    | otherwise = do 
    165165        env <- caller n 
    166         shiftT $ \r -> return $ VErr $ ErrRet ((==) (envID env) . envID) v 
     166        shiftT $ \r -> return $ VErr $ ErrRet (return . (==) (envID env) . envID) v 
    167167 
    168168returnScope = callerReturn 0 . VStr 
    169169 
    170170data VErr = ErrStr String 
    171           | ErrRet (Env -> Bool) Val 
     171          | ErrRet (Env -> Eval Bool) Val 
    172172    deriving (Typeable, Show, Eq) 
    173173 

  • src/Parser.hs

    r25 r26  
    1717-- Lexical units -------------------------------------------------- 
    1818 
    19 ruleProgram :: RuleParser Exp 
     19ruleProgram :: RuleParser Env 
    2020ruleProgram = rule "program" $ do 
     21    whiteSpace 
    2122    many (symbol ";") 
    2223    rv <- option [] ruleStatementList 
    2324    eof 
    24     retSyn ";" rv 
     25    env <- getState 
     26    return $ env { envBody = (Syn ";" rv) } 
    2527 
    2628ruleBlock :: RuleParser Exp 
    2729ruleBlock = rule "block" $ braces $ do 
     30    whiteSpace 
    2831    many (symbol ";") 
    2932    rv <- option [] ruleStatementList 
    … …  
    6366        return (scope, multi, name) 
    6467    pos     <- getPosition 
    65     cxt     <- option "Any" $ preSpace (ruleBareTrait "returns") 
     68    cxt     <- option "Any" $ ruleBareTrait "returns" 
    6669    formal  <- option Nothing $ return . Just =<< parens ruleSubParameters 
    6770    body    <- ruleBlock 
    … …  
    8588ruleSubName = rule "subroutine name" $ do 
    8689    star    <- option "" $ string "*" 
    87     fixity  <- option "prefix:" $ choice (map string $ words fixities) 
     90    fixity  <- option "prefix:" $ choice (map (try . string) $ words fixities) 
    8891    c       <- wordAlpha 
    8992    cs      <- many wordAny 
    … …  
    352355parseProgram = do { whiteSpace ; x <- parseOp ; eof ; return x } 
    353356 
    354 runRule :: Env -> (Exp -> a) -> RuleParser Exp -> String -> a 
    355 runRule env f p str = f $ case ( runParser ruleProgram (envPad env) "" str ) of 
    356     Left err    -> Val $ VError (showErr err) (NonTerm $ errorPos err) 
    357     Right ast   -> ast 
     357runRule :: Env -> (Env -> a) -> RuleParser Env -> String -> a 
     358runRule env f p str = f $ case ( runParser ruleProgram env "" str ) of 
     359    Left err    -> env { envBody = Val $ VError (showErr err) (NonTerm $ errorPos err) } 
     360    Right env'  -> env' 
    358361 
    359362showErr err =  

  • src/Pretty.hs

    r25 r26  
    2727    pretty (Val (VError msg (NonTerm pos))) = "Syntax error at " ++ (show pos) ++ msg 
    2828    pretty x = show x 
     29 
     30instance Pretty Env where 
     31    pretty x = "{ " ++ (pretty $ envBody x) ++ " }" 
    2932 
    3033instance Pretty Val where 

  • src/Prim.hs

    r25 r26  
    2727op0 s    = \x -> VError ("unimplemented listOp: " ++ s) (Val $ VList x) 
    2828 
    29 op1 :: Ident -> (forall a. Context a => a) -> StateEnv Val 
     29op1 :: Ident -> (forall a. Value a => a) -> Eval Val 
    3030op1 "!"    = return . fmapVal not 
    3131op1 "+"    = return . op1Numeric id 
    … …  
    5050op1 s      = return . (\x -> VError ("unimplemented unaryOp: " ++ s) (Val x)) 
    5151 
    52 opEval :: String -> StateEnv Val 
     52opEval :: String -> Eval Val 
    5353opEval str = do 
    54     pad <- gets envPad 
    55     let rv = ( runParser ruleProgram pad "" str ) 
     54    env <- ask 
     55    let rv = ( runParser ruleProgram env "" str ) 
    5656    return $ VUndef 
    5757    {- 
    5858    case rv of 
    5959        Left err    -> return $ VError (showErr err) (NonTerm $ errorPos err) 
    60         Right exp   -> gets evl >>= (($) exp) 
     60        Right exp   -> asks evl >>= (($) exp) 
    6161-} 
    6262 
    … …  
    200200                      , subFun      = (Prim f) 
    201201                      } 
    202     f :: [Val] -> StateEnv Val 
     202    f :: [Val] -> Eval Val 
    203203    f    = case arity of 
    204204        0 -> \(x:_) -> return $ op0 sym (vCast x)