Changeset 15829 for src/Pugs/Parser

Show
Ignore:
Timestamp:
04/04/07 19:54:22 (20 months ago)
Author:
audreyt
Message:

* Revert r15828 as promised.

Location:
src/Pugs/Parser
Files:
7 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Parser/Export.hs

    r15828 r15829  
    1616 
    1717exportSym :: Scope -> String -> Val -> RuleParser () 
    18 exportSym scope name@('&':_) ref = do 
    19     pad <- unsafeEvalLexDiff $ _Sym scope name mempty (Val ref) Noop 
    20     addBlockPad pad 
     18exportSym scope ('&':subname) ref = do 
     19    rv <- unsafeEvalExp $ Syn "," [App (_Var "&values") (Just (Val ref)) []] 
     20    case rv of 
     21        Val (VList subs) -> do 
     22            exps <- forM (filter defined subs) $ \val -> do 
     23                let name    = '&':subname 
     24                    mkSym   = _Sym scope name mempty (Val val) Noop 
     25                doExport scope mkSym 
     26            case scope of 
     27                SMy -> addBlockPad SState  
     28                    (foldl' unionPads (mkPad []) [ pad | Pad SMy pad _ <- exps ]) 
     29                _   -> return ()  
     30        _ -> fail $ "Invalid export list: " ++ show rv 
    2131exportSym scope subname@(sig:_) ref | isWordAlpha sig = do 
    2232    exportSym scope ('&':subname) ref 
    2333exportSym _ _ _ = fail "Non-Code exports does not work yet" 
    2434--exportSym' scope name sym = other vars... 
     35 
     36doExport :: Scope -> Exp -> RuleParser Exp 
     37doExport SState sym = do 
     38    unsafeEvalExp sym 
     39    return emptyExp 
     40doExport SMy sym = do 
     41    lexDiff <- unsafeEvalLexDiff sym 
     42    return $ Pad SMy lexDiff emptyExp 
     43doExport _ _ = fail "notyet" -- XXX writeme. but do they all make sense at all? 

  • src/Pugs/Parser/Literal.hs

    r15828 r15829  
    248248            else mzero 
    249249        closure = if qfInterpolateClosure flags 
    250             then retInterpolatedBlock =<< ruleVerbatimBlock 
     250            then ruleVerbatimBlock 
    251251            else mzero 
    252252        backslash = case qfInterpolateBackslash flags of 

  • src/Pugs/Parser/Operator.hs

    r15828 r15829  
    138138    forceParens (Ann x inner)       = Ann x (forceParens inner) 
    139139    forceParens (Sym x y flags init inner) = Sym x y flags init (forceParens inner) 
     140    forceParens (Pad x y inner)     = Pad x y (forceParens inner) 
    140141    forceParens exp                 = exp 
    141142 

  • src/Pugs/Parser/Program.hs

    r15828 r15829  
    9999makeState :: Env -> RuleState 
    100100makeState env = MkState 
    101     { s_env             = env 
    102     , s_parseProgram    = parseProgram 
    103     , s_dynParsers      = MkDynParsersEmpty 
    104     , s_bracketLevel    = StatementBracket 
    105 --  , s_char            = ' ' 
    106 --  , s_name            = nullID 
    107 --  , s_pos             = 0 
    108     , s_wsLine          = 0 
    109     , s_wsColumn        = 0 
    110     , s_closureTraits   = [id] 
    111     , s_freeVars        = Set.empty 
    112     , s_knownVars       = Map.empty 
    113     , s_protoPad        = emptyPad 
     101    { s_env           = env 
     102    , s_parseProgram  = parseProgram 
     103    , s_dynParsers    = MkDynParsersEmpty 
     104    , s_bracketLevel  = StatementBracket 
     105--  , s_char          = ' ' 
     106--  , s_name          = nullID 
     107--  , s_pos           = 0 
     108    , s_wsLine        = 0 
     109    , s_wsColumn      = 0 
     110    , s_blockPads     = Map.empty 
     111    , s_closureTraits = [id] 
     112    , s_outerVars     = Set.empty 
    114113    } 
    115  
    116 -- XXX - Pending clarification about those 3 -- are they routine-implicit or block-implicit? 
    117 {- 
    118 protoPad :: Pad 
    119 protoPad = mkPad 
    120     [ (cast "$_", PELexical 
    121     , (cast "$/", 
    122     , (cast "$!",  
    123     ] 
    124 -} 
    125114 
    126115runRule :: Env -> RuleParser Env -> FilePath -> String -> Env 
    … …  
    164153ruleProgram :: RuleParser Env 
    165154ruleProgram = rule "program" $ do 
    166     env     <- getRuleEnv 
    167  
    168     topPad  <- genParamEntries SubRoutine [defaultArrayParam] 
    169     modify $ \s -> s{ s_protoPad = topPad } 
    170  
    171     block   <- ruleBlockBody 
    172     main    <- retVerbatimBlock SubPointy Nothing False $ 
    173         block{ bi_body = mergeStmts emptyExp $ bi_body block } 
    174  
     155    env <- getRuleEnv 
     156    statements <- ruleBlockBody 
    175157    -- error $ show statements 
    176158    eof 
    … …  
    190172    env' <- getRuleEnv 
    191173    return $ env' 
    192         { envBody       = App main Nothing [] -- _Var "@*ARGS"] 
     174        { envBody       = mergeStmts emptyExp statements 
    193175        , envPackage    = envPackage env 
    194176        } 

  • src/Pugs/Parser/Types.hs

    r15828 r15829  
    33module Pugs.Parser.Types ( 
    44    RuleParser, RuleState(..), CharClass(..), 
    5     DynParsers(..), ParensOption(..), FormalsOption(..), BracketLevel(..), OuterLevel, 
    6     BlockInfo(..), emptyBlockInfo, 
    7  
     5    DynParsers(..), ParensOption(..), FormalsOption(..), BracketLevel(..), 
    86    RuleOperator, RuleOperatorTable, 
    97    getRuleEnv, modifyRuleEnv, putRuleEnv, insertIntoPosition, 
    108    clearDynParsers, enterBracketLevel, getCurrCharClass, charClassOf, 
    11     addBlockPad, popClosureTrait, addClosureTrait, 
     9    addBlockPad, popClosureTrait, addClosureTrait, addOuterVar, 
    1210    -- Alternate Char implementations that keeps track of s_charClass 
    1311    satisfy, string, oneOf, noneOf, char, hexDigit, octDigit, 
    … …  
    2624import qualified Data.Set as Set 
    2725 
    28 data BlockInfo = MkBlockInfo 
    29     { bi_pad    :: !Pad 
    30     , bi_traits :: !(TraitBlocks -> TraitBlocks) 
    31     , bi_body   :: !Exp 
    32     } 
    33  
    34 emptyBlockInfo :: BlockInfo 
    35 emptyBlockInfo = MkBlockInfo emptyPad id emptyExp 
    36  
    37  
    3826{-# INLINE satisfy #-} 
    3927satisfy :: (Char -> Bool) -> RuleParser Char 
    … …  
    132120    } 
    133121 
    134 type OuterLevel = Int 
    135  
    136122{-| 
    137123State object that gets passed around during the parsing process. 
    … …  
    140126    { s_env           :: Env 
    141127    , s_parseProgram  :: (Env -> FilePath -> String -> Env) 
    142     , s_dynParsers    :: DynParsers         -- ^ Cache for dynamically-generated 
    143                                             --     parsers 
    144     , s_bracketLevel  :: !BracketLevel      -- ^ The kind of "bracket" we are in 
    145                                             --     part and has to suppress {..} literals 
    146 --  , s_char          :: Char               -- ^ What the previous character contains 
    147 --  , s_name          :: !ID                -- ^ Capture name 
    148 --  , s_pos           :: !Int               -- ^ Capture position 
    149     , s_wsLine        :: !Line              -- ^ Last whitespace position 
    150     , s_wsColumn      :: !Column            -- ^ Last whitespace position 
    151 --  , s_blockPads     :: Map Scope Pad      -- ^ Hoisted pad for this block 
    152     , s_knownVars     :: !(Map Var MPad)        -- ^ Map from variables to its associated scope 
    153     , s_freeVars      :: !(Set (Var, LexPads))  -- ^ Set of free vars and the mpadlist to check with 
    154     , s_protoPad      :: !Pad                   -- ^ Pad that's part of all scopes; used in param init 
     128    , s_dynParsers    :: DynParsers     -- ^ Cache for dynamically-generated 
     129                                        --     parsers 
     130    , s_bracketLevel  :: !BracketLevel  -- ^ The kind of "bracket" we are in 
     131                                        --     part and has to suppress {..} literals 
     132--  , s_char          :: Char           -- ^ What the previous character contains 
     133--  , s_name          :: !ID            -- ^ Capture name 
     134--  , s_pos           :: !Int           -- ^ Capture position 
     135    , s_wsLine        :: !Line          -- ^ Last whitespace position 
     136    , s_wsColumn      :: !Column        -- ^ Last whitespace position 
     137    , s_blockPads     :: Map Scope Pad  -- ^ Hoisted pad for this block 
     138    , s_outerVars     :: Set Var        -- ^ OUTER symbols we remembers 
     139                                        
    155140    , s_closureTraits :: [TraitBlocks -> TraitBlocks] 
    156141                                       -- ^ Closure traits: head is this block, tail is all outer blocks 
    … …  
    177162data FormalsOption = FormalsSimple | FormalsComplex 
    178163    deriving (Show, Eq) 
    179  
    180 instance MonadSTM RuleParser where 
    181     liftSTM x = return $! unsafePerformSTM x 
    182164 
    183165instance MonadReader Env RuleParser where 
    … …  
    247229Update the 's_blockPads' in the parser's state by applying a transformation function. 
    248230-} 
    249 addBlockPad :: Pad -> RuleParser () 
    250 addBlockPad pad = do 
    251     -- To add a Pad to the COMPILING block, we do two things: 
    252     -- First, we check that our pad does not contain shadowed OUTER symbols. 
    253     -- XXX TODO: it should be fine for two identical padEntry to shadow each other, 
    254     --     as is the case with { our multi f () {}; { &f(); our multi f ($x) {} } }. 
     231addBlockPad :: Scope -> Pad -> RuleParser () 
     232addBlockPad scope pad = do 
     233    -- First we check that our pad does not contain shadows OUTER symbols. 
    255234    state <- get 
    256     let myVars          = padKeys pad 
    257         dupVars         = myVars `Set.intersection` Map.keysSet outerKnownVars 
    258         outerKnownVars  = Map.filter (/= compPad) (s_knownVars state) 
    259         Just compPad    = envCompPad (s_env state) 
    260  
    261     unless (Set.null dupVars) $ do 
     235    let dupSyms = padKeys pad `Set.intersection` s_outerVars state 
     236    unless (Set.null dupSyms) $ do 
    262237        fail $ "Redeclaration of " 
    263             ++ unwords (map show (Set.elems dupVars)) 
     238            ++ unwords (map show (Set.elems dupSyms)) 
    264239            ++ " conflicts with earlier OUTER references in the same scope" 
    265  
    266     -- Then we merge the Pad into COMPILING, and add those vars into s_knownVars. 
    267     ()  <- stm $ modifyTVar compPad (`unionPads` pad) 
    268  
    269     let myKnownVars = Map.fromDistinctAscList [ (var, compPad) | var <- Set.toAscList myVars ] 
    270     put state{ s_knownVars = s_knownVars state `Map.union` myKnownVars } 
     240    put state{ s_blockPads = Map.insertWith unionPads scope pad (s_blockPads state) } 
    271241 
    272242popClosureTrait :: RuleParser () 
    … …  
    310280        "FIRST"     -> block{ subFirstBlocks = subFirstBlocks block ++ [trait] } 
    311281        _           -> trace ("Wrong closure trait name: "++name) block 
     282{-| 
     283Update the 's_outerVars' in the parser's state by applying a transformation function. 
     284-} 
     285addOuterVar :: Var -> RuleParser () 
     286addOuterVar var = modify $ \state -> 
     287    state{ s_outerVars = Set.insert var (s_outerVars state) } 
    312288 
    313289{-| 

  • src/Pugs/Parser/Unsafe.hs

    r15828 r15829  
    8383            -- The vcode is a macro! Apply it and substitute its return value. 
    8484            ret <- unsafeEvalExp $! App (Val $ VCode vcode{ subType = SubRoutine }) invs args 
    85             -- local (maybe id const (subEnv vcode)) $  
    86             substMacroResult ret 
     85            local (maybe id const (subEnv vcode)) $ substMacroResult ret 
    8786        | otherwise 
    8887        = return app 
    … …  
    9392        return $! fromObject o 
    9493    -- A Str should be (re)parsed. 
    95     substMacroResult (Val (VStr code)) = fmap bi_body . localBlock $ do 
     94    substMacroResult (Val (VStr code)) = localEnv $ do 
    9695        parseProgram <- gets s_parseProgram 
    9796        env          <- ask 

  • src/Pugs/Parser/Util.hs

    r15828 r15829  
    1414grammaticalCategories = ["prefix_circumfix_meta_operator:","infix_circumfix_meta_operator:","prefix_postfix_meta_operator:","postfix_prefix_meta_operator:","infix_postfix_meta_operator:","statement_modifier:","statement_control:","scope_declarator:","trait_auxiliary:","trait_verb:","regex_mod_external:","regex_mod_internal:","regex_assertion:","regex_backslash:","regex_metachar:","postcircumfix:","circumfix:","postfix:","infix:","prefix:","quote:","term:"] 
    1515 
    16  
    17 retBlockWith :: (Exp -> Exp) -> BlockInfo -> RuleParser BlockInfo 
    18 retBlockWith f bi = return bi{ bi_body = f (bi_body bi) } 
    19  
    2016-- around a block body we save the package and the current lexical pad 
    2117-- at the start, so that they can be restored after parsing the body 
    22 localBlock :: RuleParser Exp -> RuleParser BlockInfo 
    23 localBlock m = do 
     18localEnv :: RuleParser Exp -> RuleParser Exp 
     19localEnv m = do 
    2420    state   <- get 
    25  
    26     -- XXX - Perhaps clone the protopad right here, for $_ etc? 
    27     compPad <- stm $ newTVar (s_protoPad state) 
    28  
    29     let env     = s_env state 
    30         lexPads = (PCompiling compPad:envLexPads env) 
    31  
     21    let env = s_env state 
    3222    put state 
    33         { s_closureTraits   = (id : s_closureTraits state) 
    34         , s_env             = env 
    35             { envLexPads = lexPads  -- enter the scope 
    36             , envCompPad = Just compPad 
    37             } 
    38         , s_protoPad        = emptyPad 
     23        { s_blockPads = Map.empty 
     24        , s_closureTraits = (id : s_closureTraits state) 
     25        , s_outerVars = Set.empty 
     26        , s_env = env { envOuter = Just env } 
    3927        } 
    40  
    41     body    <- m 
     28    rv      <- m 
    4229    state'  <- get 
    43  
    44     -- Remove from knownVars the bindings belonging to this scope . 
    45     let outerKnownVars = Map.filter (/= compPad) (s_knownVars state') 
    46         (traits, outerTraits) = case s_closureTraits state' of 
    47             (t:ts)  -> (t, ts) 
    48             _       -> (id, []) 
    49  
    5030    put state 
    5131        { s_env = (s_env state') 
    5232            { envPackage = envPackage env 
    5333            , envLexical = envLexical env 
    54             , envLexPads = envLexPads env 
    55             , envCompPad = envCompPad env 
     34            , envOuter   = envOuter env 
    5635            } 
    57         , s_closureTraits = outerTraits 
    58         , s_knownVars     = outerKnownVars 
     36        , s_closureTraits = s_closureTraits state' 
    5937        } 
    60  
    6138    -- Re-read compile time refs into the new protos at end of scope. 
    62     newPad <- return $! unsafePerformSTM $! do 
    63         curPad  <- readTVar compPad 
    64         entries <- forM (padToList curPad) $ \(var, entry) -> do 
    65             proto   <- readPadEntry entry 
    66             let newEntry = entry{ pe_proto = proto } 
    67             return (newEntry `seq` (var, newEntry)) 
    68         let newPad = listToPad (length entries `seq` entries) 
    69         writeTVar compPad newPad 
    70         return newPad 
    71     return $ MkBlockInfo{ bi_pad = newPad, bi_body = body, bi_traits = traits } 
     39    newPads <- return $! unsafePerformSTM $! do 
     40        forM (Map.toList $ s_blockPads state') $ \(scope, pad) -> do 
     41            newPad <- forM (padToList pad) $ \(var, entry) -> do 
     42                proto   <- readPadEntry entry 
     43                let newEntry = entry{ pe_proto = proto } 
     44                return (newEntry `seq` (var, newEntry)) 
     45            return (scope, listToPad (length newPad `seq` newPad)) 
     46    return $ Map.foldWithKey Pad rv (length newPads `seq` Map.fromList newPads) 
    7247 
    7348ruleParamList :: ParensOption -> RuleParser a -> RuleParser (Maybe [[a]]) 
    … …  
    11994     
    12095defaultParamFor :: SubType -> [Param] 
    121 defaultParamFor SubBlock    = [] -- defaultScalarParam] 
     96defaultParamFor SubBlock    = [defaultScalarParam] 
    12297defaultParamFor SubPointy   = [] 
    12398defaultParamFor _           = [defaultArrayParam] 
    12499 
    125 extractNamedPlaceholders :: SubType -> Maybe [Param] -> Exp -> (Exp, [Var], [Param]) 
    126 extractNamedPlaceholders SubBlock formal body = (fun, names', params) 
     100doExtract :: SubType -> Maybe [Param] -> Exp -> (Exp, [Var], [Param]) 
     101doExtract SubBlock formal body = (fun, names', params) 
    127102    where 
    128103    (fun, names) = extractPlaceholderVars body Set.empty 
    … …  
    132107           = sortNames names 
    133108    params = map nameToParam names' ++ (maybe [] id formal) 
    134 extractNamedPlaceholders SubPointy formal body = (body, [], maybe [] id formal) 
    135 extractNamedPlaceholders SubMethod formal body = (body, [], maybe [] id formal) 
    136 extractNamedPlaceholders _ formal body = (body, names', params) 
     109doExtract SubPointy formal body = (body, [], maybe [] id formal) 
     110doExtract SubMethod formal body = (body, [], maybe [] id formal) 
     111doExtract _ formal body = (body, names', params) 
    137112    where 
    138113    (_, names) = extractPlaceholderVars body Set.empty 
    … …  
    190165    , isWritable    = True 
    191166    , isLazy        = False 
    192     , paramName     = cast "$__SELF__" 
     167    , paramName     = cast "&self" 
    193168    , paramContext  = CxtItem typ 
    194169    , paramDefault  = Noop 
    195170    } 
    196171 
    197 hashComposerCheck :: Exp -> RuleParser Bool 
    198 hashComposerCheck exp 
    199     | Ann (Prag [MkPrag "eol-block" _]) _ <- exp = do 
    200         when isHash $ 
    201             fail "Closing hash curly may not terminate a line;\nplease add a comma or a semicolon to disambiguate" 
    202         return False 
    203     | otherwise = return isHash 
    204     where 
    205     isHash = doCheck (possiblyUnwrap exp) 
     172extractHash :: Exp -> RuleParser (Maybe Exp) 
     173extractHash exp 
     174    | Ann (Prag [MkPrag "eol-block" _]) _ <- exp = case result of 
     175        Just{}  -> fail "Closing hash curly may not terminate a line;\nplease add a comma or a semicolon to disambiguate" 
     176        _       -> return Nothing 
     177    | otherwise = return result 
     178    where 
     179    result = extractHash' (possiblyUnwrap exp) 
    206180 
    207181    possiblyUnwrap (Ann _ exp) = possiblyUnwrap exp 
    … …  
    210184    possiblyUnwrap x = x 
    211185     
    212     isHashOrPair (Ann _ exp)            = isHashOrPair exp 
    213     isHashOrPair (App (Var var) _ _)    = (var == cast "&pair") || (var == cast "&infix:=>")  
    214     isHashOrPair (Syn "%{}" _)          = True 
    215     isHashOrPair (Var var)              = v_sigil var == SHash 
    216     isHashOrPair _                      = False 
     186    isHashOrPair (Ann _ exp) = isHashOrPair exp 
     187    isHashOrPair (App (Var var) _ _) = (var == cast "&pair") || (var == cast "&infix:=>")  
     188    isHashOrPair (Syn "%{}" _) = True 
     189    isHashOrPair (Var var) = v_sigil var == SHash 
     190    isHashOrPair _ = False 
    217191     
    218     doCheck Noop                   = True 
    219     doCheck (Syn "," (subexp:_))   = isHashOrPair subexp 
    220     doCheck exp                    = isHashOrPair exp 
     192    extractHash' exp                      | isHashOrPair exp    = Just exp 
     193    extractHash' exp@(Syn "," (subexp:_)) | isHashOrPair subexp = Just exp 
     194    extractHash' exp@Noop = Just exp 
     195    extractHash' _ = Nothing 
    221196 
    222197tryLookAhead :: RuleParser a -> RuleParser b -> RuleParser a