Changeset 5357 for src/Pugs/Compile

Show
Ignore:
Timestamp:
07/10/05 14:47:37 (3 years ago)
Author:
autrijus
svk:copy_cache_prev:
7349
Message:

* proper closure support for Compile.Pugs; that's one step closer to compiled prelude

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Compile/Pugs.hs

    r5356 r5357  
    88import Pugs.Internals 
    99import Text.PrettyPrint 
    10 #if !defined(PUGS_HAVE_PERL5) && !defined(PUGS_HAVE_PARROT) && defined(PUGS_HAVE_TH) && (__GLASGOW_HASKELL__ <= 604) 
    11 import qualified Language.Haskell.TH as TH 
    12 #endif 
    1310 
    1411class (Show x) => Compile x where 
    … …  
    1613    compile x = fail ("Unrecognized construct: " ++ show x) 
    1714    compileList :: [x] -> Eval Doc 
    18     compileList = liftM prettyList . mapM compile 
     15    compileList = fmap prettyList . mapM compile 
    1916 
    2017instance (Compile x) => Compile [x] where 
    … …  
    3027prettyDo docs = parens $ sep (text "do":punctuate semi docs) 
    3128 
    32 #if !defined(PUGS_HAVE_PERL5) && !defined(PUGS_HAVE_PARROT) && defined(PUGS_HAVE_TH) && (__GLASGOW_HASKELL__ <= 604) 
    3329prettyRecord :: String -> [(String, Doc)] -> Doc 
    3430prettyRecord con = (text con <+>) . braces . sep . punctuate comma . map assign 
    3531    where assign (name, val) = text name <+> char '=' <+> val 
    36 #endif 
    3732 
    3833prettyBind :: String -> Doc -> Doc 
    … …  
    4035 
    4136 
     37instance Compile (Maybe Exp) where 
     38    compile Nothing = return $ text "return Nothing" 
     39    compile (Just exp) = do 
     40        expC <- compile exp 
     41        return $ prettyDo  
     42            [ prettyBind "exp" expC 
     43            , text "return (Just exp)" 
     44            ] 
    4245 
    4346instance Compile Exp where 
     47    compile (App exp1 exp2 exps) = do 
     48        exp1C <- compile exp1 
     49        exp2C <- compile exp2 
     50        expsC <- compileList exps 
     51        return $ prettyDo  
     52            [ prettyBind "exp1" exp1C 
     53            , prettyBind "exp2" exp2C 
     54            , prettyBind "exps" (text "sequence" `sep1` expsC) 
     55            , text "return (App exp1 exp2 exps)" 
     56            ] 
    4457    compile (Syn syn exps) = do 
    4558        expsC <- compileList exps 
    4659        return $ prettyDo 
    47                 [ prettyBind "exps" (text "sequence" `sep1` expsC) 
    48                 , text "return" <+> parens (text $ "Syn " ++ show syn ++ " exps") 
    49                 ] 
     60            [ prettyBind "exps" (text "sequence" `sep1` expsC) 
     61            , text "return" <+> parens (text $ "Syn " ++ show syn ++ " exps") 
     62            ] 
     63    compile (Cxt cxt exp) = compileShow2 "Cxt" cxt exp 
     64    compile (Pos pos exp) = compileShow2 "Pos" pos exp 
     65    compile (Pad scope pad exp) = do 
     66        padC <- compile pad 
     67        expC <- compile exp 
     68        return $ prettyDo 
     69            [ prettyBind "pad" padC 
     70            , prettyBind "exp" expC 
     71            , text ("return (Pad " ++ show scope ++ " pad exp)") 
     72            ] 
    5073    compile (Stmts exp1 exp2) = do 
    5174        exp1C <- compile exp1 
    5275        exp2C <- compile exp2 
    5376        return $ prettyDo  
    54                 [ prettyBind "exp1" exp1C 
    55                 , prettyBind "exp2" exp2C 
    56                 , text "return (Stmts exp1 exp2)" 
    57                 ] 
    58     compile (Pad scope pad exp) = do 
    59         padC <- compile pad 
    60         expC <- compile exp 
    61         return $ prettyDo 
    62                 [ prettyBind "pad" padC 
    63                 , prettyBind "exp" expC 
    64                 , text ("return (Pad " ++ show scope ++ " pad exp)") 
    65                 ] 
    66     compile (Pos pos exp) = compileShow2 "Pos" pos exp 
    67     compile (Cxt cxt exp) = compileShow2 "Cxt" cxt exp 
     77            [ prettyBind "exp1" exp1C 
     78            , prettyBind "exp2" exp2C 
     79            , text "return (Stmts exp1 exp2)" 
     80            ] 
     81    compile (Val val) = do 
     82        valC <- compile val 
     83        return $ prettyDo  
     84            [ prettyBind "val" valC 
     85            , text "return (Val val)" 
     86            ] 
    6887    compile exp = return $ text "return" $+$ parens (text $ show exp) 
    6988 
    … …  
    117136        vref    <- liftSTM $ readTVar fresh 
    118137        vrefC   <- compile vref 
    119         return $ prettyDo             
    120                 [ prettyBind "vref" vrefC 
    121                 , text "liftSTM (newTVar vref)" 
    122                 ] 
     138        return $ prettyDo 
     139            [ prettyBind "vref" vrefC 
     140            , text "liftSTM (newTVar vref)" 
     141            ] 
    123142 
    124143instance Compile VRef where 
    125144    compile (MkRef (ICode cv)) = do 
    126         vsub <- code_fetch cv 
    127         vsubC <- compile vsub 
    128         return (text "return (MkRef " <>  
    129                 parens (sep [text "ICode $ ", vsubC]) <> text ")") 
    130     compile (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" 
    131                                  = do 
    132         sv <- scalar_fetch sv 
     145        vsub    <- code_fetch cv 
     146        vsubC   <- compile vsub 
     147        return $ prettyDo 
     148            [ prettyBind "vsub" vsubC 
     149            , text "return (MkRef $ ICode vsub)" 
     150            ] 
     151    compile (MkRef (IScalar sv)) | scalar_iType sv == mkType "Scalar::Const" = do 
     152        sv  <- scalar_fetch sv 
    133153        svC <- compile sv 
    134         return (text "return (MkRef " <>  
    135                 parens (sep [text "IScalar $ ", svC]) <> text ")") 
    136  
     154        return $ prettyDo 
     155            [ prettyBind "sv" svC 
     156            , text "return (MkRef $ IScalar sv)" 
     157            ] 
    137158    compile ref = do 
    138159        return $ text $ "newObject (mkType \"" ++ showType (refType ref) ++ "\")" 
    139160 
    140161instance Compile Val where 
    141     compile (VCode vc) = liftM ((text "VCode" <+>) . parens) $ compile vc 
    142     compile x = return $ text $ show x 
     162    compile (VCode code) = do 
     163        codeC <- compile code 
     164        return $ prettyDo 
     165            [ prettyBind "code" codeC 
     166            , text "return $ VCode code" 
     167            ] 
     168    compile x = return $ text "return" $+$ parens (text $ show x) 
     169 
     170-- This wants a total rewrite.  I strongly want Data.Generics at this point now. 
    143171 
    144172-- Haddock can't cope with Template Haskell 
    145173instance Compile VCode where 
    146 #if !defined(HADDOCK) && !defined(PUGS_HAVE_PERL5) && !defined(PUGS_HAVE_PARROT) && defined(PUGS_HAVE_TH) && (__GLASGOW_HASKELL__ <= 604) 
    147     compile code | subType code == SubPrim = return $ text "mkPrim" 
     174    compile code | subType code == SubPrim = return $ text "return mkPrim" 
    148175    compile code = do  
    149         return $ prettyRecord "MkCode" $ 
    150             $(liftM TH.ListE $  
    151               mapM (\name -> [|(name, tshow $ 
    152                                 $(TH.varE $ TH.mkName name) code{ subEnv = Nothing })|]) $ 
    153               ["isMulti", "subName", "subType", "subEnv", "subAssoc", 
    154               "subParams", "subBindings", "subSlurpLimit", 
    155               "subReturns", "subLValue", "subCont"]) 
    156             ++ 
    157             [] 
    158         where  
    159         tshow :: Show a => a -> Doc 
    160         tshow = text . show 
    161 #else  
    162     compile code | subType code == SubPrim = return $ text "mkPrim" 
    163     compile code = return $ text $ show code{ subEnv = Nothing } 
    164 #endif  
     176        bodyC <- compile $ subBody code 
     177        let comp :: Show a => (VCode -> a) -> Doc 
     178            comp f = text $ show (f code) 
     179            vsub = prettyRecord "MkCode" $ 
     180                [ ("isMulti",       comp isMulti) 
     181                , ("subName",       comp subName) 
     182                , ("subType",       comp subType) 
     183                , ("subEnv",        text "Nothing") 
     184                , ("subAssoc",      comp subAssoc) 
     185                , ("subParams",     comp subParams) 
     186                , ("subBindings",   comp subBindings) 
     187                , ("subSlurpLimit", comp subSlurpLimit) 
     188                , ("subReturns",    comp subReturns) 
     189                , ("subLValue",     comp subLValue) 
     190                , ("subBody",       text "body") 
     191                , ("subCont",       text "Nothing") 
     192                ] 
     193        return $ prettyDo 
     194            [ prettyBind "body" bodyC 
     195            , text "return" <+> parens vsub 
     196            ] 
    165197 
    166198genPugs :: Eval Val