Changeset 8153

Show
Ignore:
Timestamp:
12/10/05 13:24:15 (3 years ago)
Author:
gaal
Message:

* Refactor Cxt, Pos, and Prag nodes in Exp to a unified Ann

(for Annotation) type. This should ease work on lexical pragmas.

Location:
src
Files:
14 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs.hs

    r7867 r8153  
    346346        _ -> return $ makeDumpEnv exp 
    347347    -- XXX Generalize this into structural folding 
    348     makeDumpEnv (Stmts x exp)   = Stmts x   $ makeDumpEnv exp 
    349     makeDumpEnv (Cxt x exp)     = Cxt x     $ makeDumpEnv exp 
    350     makeDumpEnv (Pad x y exp)   = Pad x y   $ makeDumpEnv exp 
    351     makeDumpEnv (Sym x y exp)   = Sym x y   $ makeDumpEnv exp 
    352     makeDumpEnv (Pos x exp)     = Pos x     $ makeDumpEnv exp 
     348    makeDumpEnv (Stmts x exp)     = Stmts x   $ makeDumpEnv exp 
     349    makeDumpEnv (Ann ann exp)     = Ann ann   $ makeDumpEnv exp 
     350    makeDumpEnv (Pad x y exp)     = Pad x y   $ makeDumpEnv exp 
     351    makeDumpEnv (Sym x y exp)     = Sym x y   $ makeDumpEnv exp 
    353352    makeDumpEnv exp = Stmts exp (Syn "env" []) 
    354353    handler err = if not (isUserError err) then ioError err else do 

  • src/Pugs/AST.hs

    r7622 r8153  
    129129mergeStmts (Syn "package" [kind, pkg@(Val (VStr _))]) y = 
    130130    Syn "namespace" [kind, pkg, y] 
    131 mergeStmts x@(Pos pos (Syn syn _)) y | (syn ==) `any` words "subst match //"  = 
    132     mergeStmts (Pos pos (App (Var "&infix:~~") Nothing [Var "$_", x])) y 
    133 mergeStmts x y@(Pos pos (Syn syn _)) | (syn ==) `any` words "subst match //"  = 
    134     mergeStmts x (Pos pos (App (Var "&infix:~~") Nothing [Var "$_", y])) 
    135 mergeStmts (Pos pos (Syn "sub" [Val (VCode sub)])) y 
     131mergeStmts x@(Ann ann (Syn syn _)) y | (syn ==) `any` words "subst match //"  = 
     132    mergeStmts (Ann ann (App (Var "&infix:~~") Nothing [Var "$_", x])) y 
     133mergeStmts x y@(Ann ann (Syn syn _)) | (syn ==) `any` words "subst match //"  = 
     134    mergeStmts x (Ann ann (App (Var "&infix:~~") Nothing [Var "$_", y])) 
     135mergeStmts (Ann ann (Syn "sub" [Val (VCode sub)])) y 
    136136    | subType sub >= SubBlock, isEmptyParams (subParams sub) = 
    137137    -- bare Block in statement level; annul all its parameters and run it! 
    138     mergeStmts (Pos pos $ App (Val $ VCode sub{ subParams = [] }) Nothing []) y 
    139 mergeStmts x (Pos pos (Syn "sub" [Val (VCode sub)])) 
     138    mergeStmts (Ann ann $ App (Val $ VCode sub{ subParams = [] }) Nothing []) y 
     139mergeStmts x (Ann ann (Syn "sub" [Val (VCode sub)])) 
    140140    | subType sub >= SubBlock, isEmptyParams (subParams sub) = 
    141141    -- bare Block in statement level; annul all its parameters and run it! 
    142     mergeStmts x (Pos pos $ App (Val $ VCode sub{ subParams = [] }) Nothing []) 
     142    mergeStmts x (Ann ann $ App (Val $ VCode sub{ subParams = [] }) Nothing []) 
    143143mergeStmts x (Stmts y Noop) = mergeStmts x y 
    144144mergeStmts x (Stmts Noop y) = mergeStmts x y 

  • src/Pugs/AST/Internals.hs

    r8077 r8153  
    44module Pugs.AST.Internals ( 
    55    Eval,      -- uses Val, Env, SIO 
     6    Ann(..),   -- Cxt, Pos, Prag 
    67    Exp(..),   -- uses Pad, Eval, Val 
    78    Env(..),   -- uses Pad, TVar, Exp, Eval, Val 
    … …  
    862863    show _ = "<ref>" 
    863864 
     865{- Expression annotation 
     866-} 
     867data Ann 
     868    = Cxt !Cxt                -- ^ Context 
     869    | Pos !Pos                -- ^ Position 
     870    | Prag ![Pragma]          -- ^ Lexical pragmas 
     871     deriving (Show, Eq, Ord, Typeable) 
     872 
    864873{- Expressions 
    865874   "App" represents function application, e.g. myfun($invocant: $arg) 
    … …  
    882891    | Syn !String ![Exp]                -- ^ Syntactic construct that cannot 
    883892                                        --     be represented by 'App'. 
    884     | Cxt !Cxt !Exp                     -- ^ Context 
    885     | Pos !Pos !Exp                     -- ^ Position 
    886     | Prag ![Pragma] !Exp               -- ^ Lexical pragmas 
     893    | Ann !Ann !Exp                     -- ^ Annotation (see @Ann@) 
    887894    | Pad !Scope !Pad !Exp              -- ^ Lexical pad 
    888895    | Sym !Scope !Var !Exp              -- ^ Symbol declaration 
    … …  
    925932 
    926933instance Unwrap Exp where 
    927     unwrap (Cxt _ exp)      = unwrap exp 
    928     unwrap (Pos _ exp)      = unwrap exp 
    929     unwrap (Prag _ exp)     = unwrap exp 
     934    ---gaal unwrap (Cxt _ exp)      = unwrap exp 
     935    ---gaal unwrap (Pos _ exp)      = unwrap exp 
     936    ---gaal unwrap (Prag _ exp)     = unwrap exp 
     937    unwrap (Ann _ exp)      = unwrap exp 
    930938    unwrap (Pad _ _ exp)    = unwrap exp 
    931939    unwrap (Sym _ _ exp)    = unwrap exp 
    … …  
    978986    | otherwise 
    979987    = (Var name, vs) 
    980 extract (Prag prag ex) vs = ((Prag prag ex'), vs') 
    981     where 
    982     (ex', vs') = extract ex vs 
    983 extract (Pos pos ex) vs = ((Pos pos ex'), vs') 
    984     where 
    985     (ex', vs') = extract ex vs 
    986 extract (Cxt cxt ex) vs = ((Cxt cxt ex'), vs') 
     988extract (Ann ann ex) vs = ((Ann ann ex'), vs') 
    987989    where 
    988990    (ex', vs') = extract ex vs 
    989991extract exp vs = (exp, vs) 
     992 
    990993 
    991994-- can be factored 

  • src/Pugs/Bind.hs

    r7622 r8153  
    104104          -> MaybeError (Bindings, SlurpLimit) 
    105105bindArray vs ps oldLimit = do 
    106     let exp = Cxt cxtSlurpyAny (Syn "," vs) 
     106    let exp = Ann (Cxt cxtSlurpyAny) (Syn "," vs) 
    107107    case foldM (doBindArray exp) ([], 0) prms of 
    108108        Left errMsg      -> fail errMsg 

  • src/Pugs/Compile.hs

    r7696 r8153  
    137137 
    138138instance Compile Exp PIL_Stmts where 
    139     compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
    140     compile (Cxt cxt rest) = enter cxt $ compile rest 
     139    compile (Ann (Pos _) rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
     140    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest 
     141    -- XXX: pragmas? 
    141142    compile (Stmts (Pad SOur _ exp) rest) = do 
    142143        compile $ mergeStmts exp rest 
    … …  
    192193 
    193194instance Compile Exp PIL_Stmt where 
    194     compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
    195     compile (Cxt cxt rest) = enter cxt $ compile rest 
     195    compile (Ann (Pos pos) rest) = fmap (PPos pos rest) $ compile rest 
     196    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest 
     197    -- XXX: pragmas? 
    196198    compile Noop = return PNoop 
    197199    compile (Val val) = do 
    … …  
    266268 
    267269instance Compile Exp PIL_LValue where 
    268     compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
    269     compile (Cxt cxt rest) = enter cxt $ compile rest 
     270    compile (Ann (Pos _) rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
     271    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest 
     272    -- XXX: pragmas? 
    270273    compile (Var name) = return $ PVar name 
    271274    compile (Syn (sigil:"::()") exps) = do 
    … …  
    361364{-| Compiles various 'Exp's to 'PIL_Expr's. -} 
    362365instance Compile Exp PIL_Expr where 
    363     compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
    364     compile (Cxt cxt rest) = enter cxt $ compile rest 
     366    compile (Ann (Pos _) rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
     367    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest 
     368    -- XXX: pragmas? 
    365369    compile (Var name) = return . PExp $ PVar name 
    366370    compile exp@(Val (VCode _)) = compile $ Syn "sub" [exp] 

  • src/Pugs/Compile/Haskell.hs

    r5890 r8153  
    6565    argC1 = compile arg1 
    6666    argC2 = compile arg2 
    67 compile (Cxt _ arg) = compile arg 
    68 compile (Pos _ arg) = compile arg 
     67compile (Ann _ arg) = compile arg 
    6968compile (Val (VInt i)) = [| return (VInt i) |] 
    7069compile (Val (VStr s)) = [| return (VStr s) |] 

  • src/Pugs/Compile/PIL2.hs

    r7866 r8153  
    128128 
    129129instance Compile Exp PIL_Stmts where 
    130     compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
    131     compile (Cxt cxt rest) = enter cxt $ compile rest 
     130    compile (Ann (Pos _) rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
     131    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest 
     132    -- XXX: pragmas? 
    132133    compile (Stmts (Pad SOur _ exp) rest) = do 
    133134        compile $ mergeStmts exp rest 
    … …  
    183184 
    184185instance Compile Exp PIL_Stmt where 
    185     compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
    186     compile (Cxt cxt rest) = enter cxt $ compile rest 
     186    compile (Ann (Pos pos) rest) = fmap (PPos pos rest) $ compile rest 
     187    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest 
     188    -- XXX: pragmas? 
    187189    compile Noop = return PNoop 
    188190    compile (Val val) = do 
    … …  
    257259 
    258260instance Compile Exp PIL_LValue where 
    259     compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
    260     compile (Cxt cxt rest) = enter cxt $ compile rest 
     261    compile (Ann (Pos _) rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
     262    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest 
    261263    compile (Var name) = return $ PVar name 
    262264    compile (Syn (sigil:"::()") exps) = do 
    … …  
    352354{-| Compiles various 'Exp's to 'PIL_Expr's. -} 
    353355instance Compile Exp PIL_Expr where 
    354     compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
    355     compile (Cxt cxt rest) = enter cxt $ compile rest 
     356    compile (Ann (Pos _) rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
     357    compile (Ann (Cxt cxt) rest) = enter cxt $ compile rest 
    356358    compile (Var name) = return . PExp $ PVar name 
    357359    compile exp@(Val (VCode _)) = compile $ Syn "sub" [exp] 

  • src/Pugs/Compile/Pugs.hs

    r7843 r8153  
    6161            , text "return" <+> parens (text $ "Syn " ++ show syn ++ " exps") 
    6262            ] 
    63     compile (Cxt cxt exp) = compileShow2 "Cxt" cxt exp 
    64     compile (Pos pos exp) = compileShow2 "Pos" pos exp 
     63    compile (Ann (Cxt cxt) exp) = compileShow2 "Cxt" cxt exp 
     64    compile (Ann (Pos pos) exp) = compileShow2 "Pos" pos exp 
     65    compile (Ann (Prag prag) exp) = compileShow2 "Prag" prag exp 
    6566    compile (Pad scope pad exp) = do 
    6667        padC <- compile pad 

  • src/Pugs/Eval.hs

    r8076 r8153  
    230230reduce (Stmts this rest) = reduceStmts this rest 
    231231 
    232 reduce (Prag prag exp) = reducePrag prag exp 
    233  
    234 reduce (Pos pos exp) = reducePos pos exp 
     232reduce (Ann (Prag prag) exp) = reducePrag prag exp 
     233 
     234reduce (Ann (Pos pos) exp) = reducePos pos exp 
    235235 
    236236reduce (Pad scope lexEnv exp) = reducePad scope lexEnv exp 
    … …  
    238238reduce (Sym scope name exp) = reduceSym scope name exp 
    239239 
    240 reduce (Cxt cxt exp) = reduceCxt cxt exp 
     240reduce (Ann (Cxt cxt) exp) = reduceCxt cxt exp 
    241241 
    242242-- Reduction for no-operations 

  • src/Pugs/Eval/Var.hs

    r8076 r8153  
    332332    cxt <- inferExpCxt idxExp 
    333333    return (typeOfCxt cxt) 
    334 inferExpType (Cxt cxt _) | typeOfCxt cxt /= (mkType "Any") = return $ typeOfCxt cxt 
    335 inferExpType (Cxt _ exp) = inferExpType exp 
    336 inferExpType (Pos _ exp) = inferExpType exp 
     334inferExpType (Ann (Cxt cxt) _) | typeOfCxt cxt /= (mkType "Any") = return $ typeOfCxt cxt 
     335inferExpType (Ann (Cxt _) exp) = inferExpType exp 
     336inferExpType (Ann (Pos _) exp) = inferExpType exp 
    337337inferExpType (Pad _ _ exp) = inferExpType exp 
    338338inferExpType (Sym _ _ exp) = inferExpType exp 
    … …  
    355355inferExpCxt :: Exp -- ^ Expression to find the context of 
    356356         -> Eval Cxt 
    357 inferExpCxt (Pos _ exp)            = inferExpCxt exp 
    358 inferExpCxt (Cxt cxt _)            = return cxt 
     357inferExpCxt (Ann (Pos _) exp)            = inferExpCxt exp 
     358inferExpCxt (Ann (Cxt cxt) _)            = return cxt 
    359359inferExpCxt (Syn "," _)            = return cxtSlurpyAny 
    360360inferExpCxt (Syn "[]" [_, exp])    = inferExpCxt exp 

  • src/Pugs/Lexer.hs

    r8006 r8153  
    163163interpolatingStringLiteral startrule endrule interpolator = do 
    164164    list <- stringList 0 
    165     return . Cxt (CxtItem $ mkType "Str") $ homogenConcat list 
     165    return $ Ann (Cxt (CxtItem $ mkType "Str")) (homogenConcat list) 
    166166    where 
    167167    homogenConcat :: [Exp] -> Exp 

  • src/Pugs/Parser.hs

    r8121 r8153  
    7676    exp  <- rule 
    7777    pos2 <- getPosition 
    78     return $ Pos (mkPos pos1 pos2) (unwrap exp) 
     78    return $ Ann (Pos (mkPos pos1 pos2)) (unwrap exp) 
    7979 
    8080{-| 
    … …  
    623623        name | twigil == '.' = '&':(envPackage env ++ "::" ++ key) 
    624624                | otherwise     = '&':(envPackage env ++ "::" ++ (twigil:key)) 
    625         fun = Cxt (cxtOfSigil sigil) (Syn "{}" [Var "$?SELF", Val (VStr key)]) 
     625        fun = Ann (Cxt (cxtOfSigil sigil)) (Syn "{}" [Var "$?SELF", Val (VStr key)]) 
    626626    unsafeEvalExp (Sym SGlobal name exp) 
    627627    return emptyExp 
    … …  
    663663        -- And note that IIRC not the type object should be the invocant, but 
    664664        -- an undef which knows to dispatch .new to the real class. 
    665         let exp' | Pos _ (App sub Nothing args) <- exp, sym == ".=" && typename /= "" 
     665        let exp' | Ann (Pos _) (App sub Nothing args) <- exp, sym == ".=" && typename /= "" -- XXX: App _ maybe? 
    666666                 = return $ App sub (Just . Var $ ':':typename) args 
    667667                 | sym == ".=" && typename /= "" 
    … …  
    20702070    Syn "{}" [Var "$/", doSplitStr (init name)] 
    20712071makeVar (sigil:'.':name) = 
    2072     Cxt (cxtOfSigil sigil) (Syn "{}" [Var "$?SELF", Val (VStr name)]) 
     2072    Ann (Cxt (cxtOfSigil sigil)) (Syn "{}" [Var "$?SELF", Val (VStr name)]) 
    20732073makeVar (sigil:'!':name) | not (null name) = 
    2074     Cxt (cxtOfSigil sigil) (Syn "{}" [Var "$?SELF", Val (VStr name)]) 
     2074    Ann (Cxt (cxtOfSigil sigil)) (Syn "{}" [Var "$?SELF", Val (VStr name)]) 
    20752075makeVar var = Var var 
    20762076 
    … …  
    22772277    -- words() regards \xa0 as (breaking) whitespace. But \xa0 is 
    22782278    -- a nonbreaking ws char. 
    2279     doSplit (Cxt (CxtItem _) (Val (VStr str))) = return $ doSplitStr str 
     2279    doSplit (Ann (Cxt (CxtItem _)) (Val (VStr str))) = return $ doSplitStr str -- XXX: generalize to Ann _? 
    22802280    doSplit expr = doSplitRx expr 
    22812281 

  • src/Pugs/Pretty.hs

    r8077 r8153  
    4141    format (Sym scope name exp) = text "Sym" <+> text (show scope) <+> format name $+$ format exp 
    4242    format (Pad scope pad exp) = text "Pad" <+> text (show scope) <+> format pad $+$ format exp 
    43     format (Pos _ exp) = format exp 
     43    format (Ann _ exp) = format exp 
    4444    format x = text $ show x 
    4545 

  • src/Pugs/Run/Perl5.hs

    r7478 r8153  
    7777            _                   -> Val sub 
    7878    val <- runEvalIO env $ 
    79         evalExp (Cxt (cxtEnum cxt) $ App subExp (fmap Val inv) (map Val args)) 
     79        evalExp (Ann (Cxt (cxtEnum cxt)) $ App subExp (fmap Val inv) (map Val args)) 
    8080    newSVval val 
    8181