Changeset 16627

Show
Ignore:
Timestamp:
06/04/07 10:08:30 (18 months ago)
Author:
gaal
Message:

* reintroduce the description field in CompUnit?, and chase codeGens

to use the filename where possible.
You may need to "rm blib6/lib/*yml" with this revision.
TODO: think about adding a parser revision number to the compunit

Location:
src
Files:
12 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs.hs

    r16610 r16627  
    194194 
    195195doCompile :: String -> FilePath -> String -> IO String 
    196 doCompile backend = doParseWith $ \env _ -> do 
     196doCompile backend = doParseWith $ \env file -> do 
    197197    globRef <- stm $ do 
    198198        glob <- readMPad $ envGlobal env 
    199199        newMPad $ filterUserDefinedPad glob 
    200     codeGen backend env{ envGlobal = globRef } 
     200    codeGen backend file env{ envGlobal = globRef } 
    201201 
    202202initCompile :: IO () 

  • src/Pugs/AST/Internals.hs

    r16610 r16627  
    15471547-} 
    15481548data CompUnit = MkCompUnit 
    1549     { ver  :: Int        -- a version number, currently 1 
    1550     --, desc :: String     -- e.g., the name of the contained module 
     1549    { ver  :: Int        -- a version number, see compUnitVersion 
     1550    , desc :: String     -- e.g., the name of the contained module 
    15511551    , pad  :: Pad        -- pad for unit Env 
    15521552    , ast  :: Exp        -- AST of unit 
    … …  
    15541554 
    15551555mkCompUnit :: String -> Pad -> Exp -> CompUnit 
    1556 mkCompUnit _ pad ast = MkCompUnit compUnitVersion pad ast 
     1556mkCompUnit = MkCompUnit compUnitVersion 
    15571557 
    15581558{-# NOINLINE compUnitVersion #-} 
    15591559compUnitVersion :: Int 
    1560 compUnitVersion = 17 
     1560compUnitVersion = 18 
    15611561 
    15621562{-| 

  • src/Pugs/AST/Internals/Instances.hs

    r16413 r16627  
    710710    fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of 
    711711        "MkCompUnit" -> do 
    712             let ESeq [aa, ab, ac] = e 
    713             liftM3 MkCompUnit (fromYAML aa) (fromYAML ab) (fromYAML ac) 
     712            let ESeq [aa, ab, ac, ad] = e 
     713            liftM4 MkCompUnit (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) 
    714714        _ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkCompUnit"] ++ " in node " ++ show e 
    715715    fromYAML e = fail $ "no tag found: expecting " ++ show ["MkCompUnit"] ++ " in node " ++ show e 
    716     asYAML (MkCompUnit aa ab ac) = asYAMLseq "MkCompUnit" 
    717            [asYAML aa, asYAML ab, asYAML ac] 
     716    asYAML (MkCompUnit aa ab ac ad) = asYAMLseq "MkCompUnit" 
     717           [asYAML aa, asYAML ab, asYAML ac, asYAML ad] 
    718718 
    719719instance YAML VMultiCode where 

  • src/Pugs/CodeGen.hs

    r15297 r16627  
    2525import qualified Data.Map as Map 
    2626 
    27 type Generator = Eval Val 
     27type Generator = FilePath -> Eval Val 
    2828 
    2929generators :: Map String Generator 
    … …  
    4343    , ("Parse-YAML",  genParseYAML) 
    4444    , ("Parse-HsYAML",genParseHsYAML) 
    45     , ("Parse-Pretty",fmap (VStr . (++"\n") . pretty) (asks envBody)) 
     45    , ("Parse-Pretty",const $ fmap (VStr . (++"\n") . pretty) (asks envBody)) 
    4646--  , ("XML",         genXML) 
    4747    ] 
    … …  
    8585        key -> Map.lookup key generators 
    8686 
    87 codeGen :: String -> Env -> IO String 
    88 codeGen s env = do 
     87codeGen :: String -> FilePath -> Env -> IO String 
     88codeGen s file env = do 
    8989    gen <- catchIO (doLookup s) . const $ do 
    90         fail $ "Cannot generate code for " ++ s 
    91     rv <- runEvalIO env gen 
     90        fail $ "Cannot generate code for " ++ s ++ ": " ++ file 
     91    rv <- runEvalIO env (gen file) 
    9292    case rv of 
    9393        VStr str    -> return str 

  • src/Pugs/CodeGen/JSON.hs

    r15297 r16627  
    88import DrIFT.JSON 
    99 
    10 genJSON :: Eval Val 
    11 genJSON = do 
     10-- XXX: do something useful with the filename arg 
     11genJSON :: FilePath -> Eval Val 
     12genJSON _ = do 
    1213    penv <- compile () :: Eval PIL_Environment 
    1314    return . VStr . unlines $ [showJSON penv] 

  • src/Pugs/CodeGen/PIL1.hs

    r15297 r16627  
    77import Pugs.Compile 
    88 
    9 genPIL1 :: Eval Val 
    10 genPIL1 = do 
     9genPIL1 :: FilePath -> Eval Val 
     10genPIL1 _ = do 
    1111    penv <- compile () 
    1212    return . VStr . unlines $ 

  • src/Pugs/CodeGen/PIR.hs

    r15651 r16627  
    370370varInit x       = internalError $ "Invalid name: " ++ x 
    371371 
    372 genPIR_YAML :: Eval Val 
    373 genPIR_YAML = genPIRWith $ \globPIR mainPIR _ -> do 
     372-- XXX: do something useful with the filename arg 
     373genPIR_YAML :: FilePath -> Eval Val 
     374genPIR_YAML _ = genPIRWith $ \globPIR mainPIR _ -> do 
    374375    yaml <- io (showYaml (mainPIR, globPIR)) 
    375376    return (VStr yaml) 
    376377 
    377378{-| Compiles the current environment to PIR code. -} 
    378 genPIR :: Eval Val 
    379 genPIR = genPIRWith $ \globPIR mainPIR penv -> do 
     379genPIR :: FilePath -> Eval Val 
     380genPIR file = genPIRWith $ \globPIR mainPIR penv -> do 
    380381    libs        <- io $ getLibs 
    381382    return . VStr . unlines $ 
    382383        [ "#!/usr/bin/env parrot" 
     384        , "# " ++ file 
    383385        , renderStyle (Style PageMode 0 0) $ preludePIR $+$ vcat 
    384386        -- Namespaces have bugs in both pugs and parrot. 

  • src/Pugs/CodeGen/Perl5.hs

    r15297 r16627  
    88import DrIFT.Perl5 
    99 
    10 genPerl5 :: Eval Val 
    11 genPerl5 = do 
     10-- XXX: do something useful with the filename arg 
     11genPerl5 :: FilePath -> Eval Val 
     12genPerl5 _ = do 
    1213    penv <- compile () :: Eval PIL_Environment 
    1314    return . VStr . unlines $ [showPerl5 penv] 

  • src/Pugs/CodeGen/YAML.hs

    r15753 r16627  
    99import DrIFT.YAML 
    1010 
    11 genParseHsYAML, genParseYAML :: Eval Val 
    12 genParseHsYAML = doGenParseYAML (fmap show . toYamlNode) 
    13 genParseYAML   = doGenParseYAML showYamlCompressed 
     11genParseHsYAML, genParseYAML :: FilePath -> Eval Val 
     12genParseHsYAML file = doGenParseYAML file (fmap show . toYamlNode) 
     13genParseYAML   file = doGenParseYAML file showYamlCompressed 
    1414 
    15 doGenParseYAML :: (CompUnit -> IO String) -> Eval Val 
    16 doGenParseYAML f = do 
     15doGenParseYAML :: FilePath -> (CompUnit -> IO String) -> Eval Val 
     16doGenParseYAML file f = do 
    1717    pad  <- filterPrim =<< asks envGlobal 
    1818    main <- asks envBody 
    19     yaml <- io $ f $ mkCompUnit "<unused>" pad main 
     19    yaml <- io $ f $ mkCompUnit file pad main 
    2020    return $ VStr yaml 
    2121 
    22 genYAML :: Eval Val 
    23 genYAML = do 
     22-- XXX: do something useful with the filename arg 
     23genYAML :: FilePath -> Eval Val 
     24genYAML _ = do 
    2425    penv <- compile () :: Eval PIL_Environment 
    2526    yaml <- io (showYamlCompressed penv) 

  • src/Pugs/Compile/Pugs.hs

    r16340 r16627  
    198198    -} 
    199199 
    200 genPugs :: Eval Val 
    201 genPugs = do 
     200genPugs :: FilePath -> Eval Val 
     201genPugs file = do 
    202202    exp             <- asks envBody 
    203203    glob            <- askGlobal 
    … …  
    214214        , "import qualified Data.Set as Set" 
    215215        , "" 
     216        , "-- compiled from " ++ file ++ " with -CPugs" 
     217        , "" 
    216218        , "main = do" 
    217219        , "    glob <- globC" 

  • src/Pugs/Prim/Eval.hs

    r16626 r16627  
    150150        Right yml' -> do 
    151151            globTVar    <- asks envGlobal 
    152             MkCompUnit _ glob ast <- io $ fromYAML yml' 
     152            MkCompUnit _ _ glob ast <- io $ fromYAML yml' 
    153153            tryT $ do 
    154154                -- Inject the global bindings 

  • src/Pugs/Run.hs

    r16433 r16627  
    276276        --(glob, ast) <- fromYAML yml 
    277277        -- cleanSeen 
    278         MkCompUnit _ glob ast <- io $ fromYAML yml 
     278        MkCompUnit _ _ glob ast <- io $ fromYAML yml 
    279279        -- print "Loading done!" 
    280280        -- z   <- stm $ join (findSym (cast "&*__fail") glob)