Changeset 6229 for src/Pugs/Compile.hs

Show
Ignore:
Timestamp:
08/13/05 21:16:15 (3 years ago)
Author:
autrijus
svk:copy_cache_prev:
8452
Message:

* de-GADT PIL structure -- likely to break all PIL2JS work

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/Compile.hs

    r6195 r6229  
    1212 
    1313module Pugs.Compile ( 
    14     PIL(..), 
     14    PIL_Stmts(..), PIL_Stmt(..), PIL_Expr(..), PIL_Decl(..), PIL_Literal(..), PIL_LValue(..), 
    1515    Compile(..), 
    1616    TEnv(..), initTEnv, 
    … …  
    3535-} 
    3636 
    37 #ifndef HADDOCK 
    38 -- Type-indexed with GADT; it is a bit too baroque -- refactor toward ANF? 
    39 data (Typeable a) => PIL a where 
    40     PNil        :: PIL [a] 
    41     PNoop       :: PIL Stmt 
    42  
    43     PPos        :: !Pos -> !Exp -> !(PIL a) -> PIL a 
    44     PRawName    :: !VarName -> PIL Expression -- XXX HACK! 
    45  
    46     PVal        :: !Val -> PIL Literal 
    47     PVar        :: !VarName -> PIL LValue 
    48  
    49     PExp        :: !(PIL LValue) -> PIL Expression  
    50     PLit        :: !(PIL Literal) -> PIL Expression 
    51     PThunk      :: !(PIL Expression) -> PIL Expression  
    52     PCode       :: !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Expression  
    53  
    54     PStmt       :: !(PIL Expression) -> PIL Stmt  
    55     PStmts      :: !(PIL Stmt) -> !(PIL [Stmt]) -> PIL [Stmt] 
    56  
    57     PApp        :: !TCxt -> !(PIL Expression) -> !(Maybe (PIL Expression)) -> ![PIL Expression] -> PIL LValue 
    58     PAssign     :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue 
    59     PBind       :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue 
    60  
    61     -- The New Pad: Occurs at whenever a variable may occur 
    62     --    PPad  :: !Scope -> !VarName -> PIL LValue 
    63  
    64     PPad        :: !Scope -> ![(VarName, PIL Expression)] -> !(PIL [Stmt]) -> PIL [Stmt] 
    65     PSub        :: !SubName -> !SubType -> ![TParam] -> !(PIL [Stmt]) -> PIL Decl 
    66 #endif 
    67  
    68 instance Typeable1 PIL where 
    69     typeOf1 _ = typeOf () 
     37data PIL_Stmts = PNil 
     38    | PStmts 
     39        { pStmt  :: !PIL_Stmt 
     40        , pStmts :: !PIL_Stmts 
     41        } 
     42    | PPad 
     43        { pScope :: !Scope 
     44        , pSyms  :: ![(VarName, PIL_Expr)] 
     45        , pStmts :: !PIL_Stmts 
     46        } 
     47    deriving (Show, Eq, Ord, Typeable) 
     48 
     49data PIL_Stmt = PNoop | PStmt { pExpr :: !PIL_Expr } | PPos 
     50        { pPos  :: !Pos 
     51        , pExp  :: !Exp 
     52        , pNode :: !PIL_Stmt 
     53        } 
     54    deriving (Show, Eq, Ord, Typeable) 
     55 
     56data PIL_Expr 
     57    = PRawName { pRawName :: !VarName } 
     58    | PExp { pLV  :: !PIL_LValue } 
     59    | PLit { pLit :: !PIL_Literal } 
     60    | PThunk { pThunk :: !PIL_Expr } 
     61    | PCode 
     62        { pType    :: !SubType 
     63        , pParams  :: ![TParam] 
     64        , pBody    :: !PIL_Stmts 
     65        } 
     66    deriving (Show, Eq, Ord, Typeable) 
     67 
     68data PIL_Decl = PSub 
     69    { pSubName      :: !SubName 
     70    , pSubType      :: !SubType 
     71    , pSubParams    :: ![TParam] 
     72    , pSubBody      :: !PIL_Stmts 
     73    } 
     74    deriving (Show, Eq, Ord, Typeable) 
     75 
     76data PIL_Literal = PVal { pVal :: Val } 
     77    deriving (Show, Eq, Ord, Typeable) 
     78 
     79data PIL_LValue = PVar { pVarName :: !VarName } 
     80    | PApp  
     81        { pCxt  :: !TCxt 
     82        , pFun  :: !PIL_Expr 
     83        , pInv  :: !(Maybe PIL_Expr) 
     84        , pArgs :: ![PIL_Expr] 
     85        } 
     86    | PAssign 
     87        { pLHS  :: ![PIL_LValue] 
     88        , pRHS  :: !PIL_Expr 
     89        } 
     90    | PBind 
     91        { pLHS  :: ![PIL_LValue] 
     92        , pRHS  :: !PIL_Expr 
     93        } 
     94    deriving (Show, Eq, Ord, Typeable) 
    7095 
    7196data TParam = MkTParam 
    7297    { tpParam   :: !Param 
    73     , tpDefault :: !(Maybe (PIL Expression)) 
     98    , tpDefault :: !(Maybe (PIL_Expr)) 
    7499    } 
    75     deriving (Show, Typeable) 
     100    deriving (Show, Eq, Ord, Typeable) 
    76101 
    77102data TCxt 
    78103    = TCxtVoid | TCxtLValue !Type | TCxtItem !Type | TCxtSlurpy !Type 
    79104    | TTailCall !TCxt 
    80     deriving (Show, Eq, Typeable) 
     105    deriving (Show, Eq, Ord, Typeable) 
    81106 
    82107tcVoid, tcLValue :: TCxt 
    … …  
    89114tcSlurpy    = TCxtSlurpy anyType 
    90115-} 
    91  
    92 instance Show (PIL a) where 
    93     show (PVal x) = "(PVal " ++ show x ++ ")" 
    94     show (PVar x) = "(PVar " ++ show x ++ ")" 
    95     show (PLit x) = "(PLit " ++ show x ++ ")" 
    96     show (PStmts x y) = "(PStmts " ++ show x ++ " " ++ show y ++ ")" 
    97     show PNil = "PNil" 
    98     show PNoop = "PNoop" 
    99     -- We don't show the raw Exp here to ease writing parsers for PIL (Exp 
    100     -- contains things like MkEnv, etc.). 
    101     show (PPos x _ z) = "(PPos " ++ show x ++ " Noop " ++ show z ++ ")" 
    102     show (PApp x y i z) = "(PApp " ++ show x ++ " " ++ show y ++ " " ++ show i ++ " " ++ show z ++ ")" 
    103     show (PExp x) = "(PExp " ++ show x ++ ")" 
    104     show (PStmt x) = "(PStmt " ++ show x ++ ")" 
    105     show (PAssign x y) = "(PAssign " ++ show x ++ " " ++ show y ++ ")" 
    106     show (PBind x y) = "(PBind " ++ show x ++ " " ++ show y ++ ")" 
    107     show (PThunk x) = "(PThunk " ++ show x ++ ")" 
    108     show (PRawName x) = "(PRawName " ++ show x ++ ")" 
    109     show (PPad x y z) = unwords ["(PPad", show x, show y, show z, ")"] 
    110     show (PCode x y z) = unwords ["(PCode", show x, show y, show z, ")"] 
    111     show (PSub x y z w) = unwords ["(PSub", show x, show y, show z, show w, ")"] 
    112116 
    113117data TEnv = MkTEnv 
    … …  
    118122    , tLabel    :: !(TVar Int)          -- ^ Label name supply 
    119123    } 
    120     deriving (Show, Eq) 
     124    deriving (Show, Eq, Ord, Typeable) 
    121125 
    122126type Comp a = Eval a 
    … …  
    129133 
    130134-- Compile instances 
    131 instance Compile (Var, [(TVar Bool, TVar VRef)]) (PIL Decl) where 
     135instance Compile (Var, [(TVar Bool, TVar VRef)]) (PIL_Decl) where 
    132136    compile = compError 
    133137 
    … …  
    142146            } 
    143147 
    144 {-| Compiles a 'Pad' to a list of 'PIL Decl's. Currently, only subroutines and 
     148{-| Compiles a 'Pad' to a list of 'PIL_Decl's. Currently, only subroutines and 
    145149    @\@*END@ are compiled. -} 
    146 instance Compile Pad [PIL Decl] where 
     150instance Compile Pad [PIL_Decl] where 
    147151    compile pad = do 
    148152        entries' <- mapM canCompile entries 
    … …  
    164168            cvList  <- fromVals =<< readRef ref :: Comp [VCode] 
    165169            decls   <- eachM cvList $ \(i, cv) -> do 
    166                 compile (("&*END_" ++ show i), cv) :: Comp [PIL Decl] 
     170                compile (("&*END_" ++ show i), cv) :: Comp [PIL_Decl] 
    167171            compile ("&*END", concat decls) 
    168172        canCompile ((_:twigil:_), _) | not (isAlphaNum twigil) = return [] 
    … …  
    186190eachM = forM . ([0..] `zip`) 
    187191 
    188 instance Compile (SubName, [PIL Decl]) [PIL Decl] where 
     192instance Compile (SubName, [PIL_Decl]) [PIL_Decl] where 
    189193    compile (name, decls) = do 
    190194        let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) Nothing [] 
    … …  
    193197        return (PSub name SubPrim [] (combine bodyC PNil):decls) 
    194198 
    195 instance Compile (SubName, VCode) [PIL Decl] where 
     199instance Compile (SubName, VCode) [PIL_Decl] where 
    196200    compile (name, vsub) | packageOf name /= packageOf (subName vsub) = do 
    197201        let storeC  = PBind [PVar $ qualify name] (PExp . PVar . qualify $ subName vsub) 
    … …  
    206210        return [PSub name (subType vsub) paramsC bodyC] 
    207211 
    208 instance Compile (String, [(TVar Bool, TVar VRef)]) (PIL Expression) where 
     212instance Compile (String, [(TVar Bool, TVar VRef)]) (PIL_Expr) where 
    209213    compile (name, _) = return $ PRawName name 
    210214 
    211 instance Compile Exp (PIL [Stmt]) where 
    212     compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
     215instance Compile Exp (PIL_Stmts) where 
     216    compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
    213217    compile (Cxt cxt rest) = enter cxt $ compile rest 
    214218    compile (Stmts (Pad SOur _ exp) rest) = do 
    … …  
    229233    enter cxt = local (\e -> e{ envContext = cxt }) 
    230234 
    231 compileStmts :: Exp -> Comp (PIL [Stmt]) 
     235compileStmts :: Exp -> Comp (PIL_Stmts) 
    232236compileStmts exp = case exp of 
    233237    Stmts this Noop -> do 
    … …  
    250254    _           -> compile (Stmts exp Noop) 
    251255 
    252 instance Compile Val (PIL Stmt) where 
     256instance Compile Val (PIL_Stmt) where 
    253257    compile = fmap PStmt . compile . Val 
    254258 
    255 instance Compile Val (PIL Expression) where 
     259instance Compile Val (PIL_Expr) where 
    256260    compile = compile . Val 
    257261 
    258 instance Compile Exp (PIL Stmt) where 
     262instance Compile Exp (PIL_Stmt) where 
    259263    compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
    260264    compile (Cxt cxt rest) = enter cxt $ compile rest 
    … …  
    299303    compile exp = fmap PStmt $ compile exp 
    300304 
    301 pBlock :: PIL [Stmt] -> PIL Expression 
     305pBlock :: PIL_Stmts -> PIL_Expr 
    302306pBlock = PCode SubBlock [] 
    303307 
    … …  
    330334    compile x = compError x 
    331335 
    332 instance Compile Exp (PIL LValue) where 
    333     compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
     336instance Compile Exp (PIL_LValue) where 
     337    compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
    334338    compile (Cxt cxt rest) = enter cxt $ compile rest 
    335339    compile (Var name) = return $ PVar name 
    … …  
    391395    compile exp = compError exp 
    392396 
    393 compLoop :: Exp -> Comp (PIL Stmt) 
     397compLoop :: Exp -> Comp (PIL_Stmt) 
    394398compLoop (Syn name [cond, body]) = do 
    395399    cxt     <- askTCxt 
    … …  
    403407    appropriate function call (@&statement_control:if@ or 
    404408    @&statement_control:unless@). -} 
    405 compConditional :: Exp -> Comp (PIL LValue) 
     409compConditional :: Exp -> Comp (PIL_LValue) 
    406410compConditional (Syn name exps) = do 
    407411    [condC, trueC, falseC] <- compile exps 
    … …  
    411415compConditional exp = compError exp 
    412416 
    413 {-| Compiles various 'Exp's to 'PIL Expression's. -} 
    414 instance Compile Exp (PIL Expression) where 
    415     compile (Pos pos rest) = fmap (PPos pos rest) $ compile rest 
     417{-| Compiles various 'Exp's to 'PIL_Expr's. -} 
     418instance Compile Exp (PIL_Expr) where 
     419    compile (Pos _ rest) = compile rest -- fmap (PPos pos rest) $ compile rest 
    416420    compile (Cxt cxt rest) = enter cxt $ compile rest 
    417421    compile (Var name) = return . PExp $ PVar name 
    … …  
    442446    ++ (show $ typeOf (undefined :: b)) 
    443447 
    444 {-| Compiles a 'Val' to a 'PIL Literal'. -} 
    445 instance Compile Val (PIL Literal) where 
     448{-| Compiles a 'Val' to a 'PIL_Literal'. -} 
     449instance Compile Val (PIL_Literal) where 
    446450    compile val = return $ PVal val 
    447451