Changeset 6250

Show
Ignore:
Timestamp:
08/14/05 19:25:02 (3 years ago)
Author:
autrijus
svk:copy_cache_prev:
8452
Message:

* JSON serialization. Deserialization for JSON and Binary

should be trivial, too.

Location:
src
Files:
3 added
6 modified

Legend:

Unmodified
Added
Removed

  • src/DrIFT/Perl5.hs

    r6248 r6250  
    3535 
    3636-- XXX - overlapping instances? 
     37instance Perl5 () where 
     38    showPerl5 _ = "undef" 
    3739 
    3840instance Perl5 Int where 

  • src/DrIFT/UserRules.hs

    r6230 r6250  
    99import UserRuleGhcBinary 
    1010import qualified RulePerl5 
     11import qualified RuleJSON 
    1112import qualified RuleUtility  
    1213import qualified RuleFunctorM 
    … …  
    1617-- add your rules to this list 
    1718userRules :: [RuleDef] 
    18 userRules = userRulesXml ++ userRulesBinary ++ userRulesGeneric ++ userRulesGhcBinary  ++ RuleUtility.rules ++ RuleFunctorM.rules ++ RuleMonoid.rules ++ RulePerl5.rules 
     19userRules = userRulesXml ++ userRulesBinary ++ userRulesGeneric ++ userRulesGhcBinary  ++ RuleUtility.rules ++ RuleFunctorM.rules ++ RuleMonoid.rules ++ RulePerl5.rules ++ RuleJSON.rules 
    1920 

  • src/Pugs/CodeGen.hs

    r6248 r6250  
    1616import Pugs.CodeGen.PIR (genPIR) 
    1717import Pugs.CodeGen.Perl5 (genPerl5) 
     18import Pugs.CodeGen.JSON (genJSON) 
    1819import Pugs.CodeGen.Binary (genBinary) 
    1920import Pugs.Compile.Pugs (genPugs) 
    … …  
    3536    , ("Pugs",        genPugs) 
    3637    , ("Binary",      genBinary) 
     38    , ("Json",        genJSON) 
    3739--  , ("Xml",         genXML) 
    3840    ] 

  • src/Pugs/CodeGen/Perl5.hs

    r6248 r6250  
    1111genPerl5 :: Eval Val 
    1212genPerl5 = do 
    13     penv <- compile () 
    14     return . VStr . unlines $ 
    15         [ "bless({" 
    16         , "    pilMain => " ++ showPerl5 (pilMain penv) ++ "," 
    17         , "    pilGlob => " ++ showPerl5 (pilGlob penv) 
    18         , "} => 'PIL::Environment')" 
    19         ] 
     13    penv <- compile () :: Eval PIL_Environment 
     14    return . VStr . unlines $ [showPerl5 penv] 

  • src/Pugs/PIL1.hs

    r6248 r6250  
    11{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields -fallow-overlapping-instances -fno-warn-orphans -fno-warn-incomplete-patterns #-} 
     2{- Generated by DrIFT (Automatic class derivations for Haskell) -} 
     3{-# LINE 1 "src/Pugs/PIL1.hs-drift" #-} 
    24 
    35module Pugs.PIL1 ( 
    … …  
    1315import DrIFT.Perl5 
    1416import DrIFT.Binary 
     17import DrIFT.JSON 
    1518 
    1619-- import DrIFT.XML 
    1720-- {-! global : Haskell2Xml !-} 
    1821 
    19 {-! global : GhcBinary, Perl5 !-} 
     22{-! global : GhcBinary, Perl5, JSON !-} 
    2023 
    2124{-| 
    … …  
    117120instance Perl5 Exp where 
    118121    showPerl5 _ = "(undef)" 
     122instance JSON Exp where 
     123    showJSON _ = "null" 
    119124 
    120125{-* Generated by DrIFT : Look, but Don't Touch. *-} 
    … …  
    132137              showP5HashObj "PIL::Environment" 
    133138              [("pilGlob", showPerl5 aa) , ("pilMain", showPerl5 ab)] 
     139 
     140instance JSON PIL_Environment where 
     141    showJSON (PIL_Environment aa ab) = showJSHashObj "PIL_Environment" 
     142             [("pilGlob", showJSON aa) , ("pilMain", showJSON ab)] 
    134143 
    135144instance Binary PIL_Stmts where 
    … …  
    168177               ("pStmts", showPerl5 ac)] 
    169178 
     179instance JSON PIL_Stmts where 
     180    showJSON (PNil) = showJSScalar "PNil" 
     181    showJSON (PStmts aa ab) = showJSHashObj "PStmts" 
     182             [("pStmt", showJSON aa) , ("pStmts", showJSON ab)] 
     183    showJSON (PPad aa ab ac) = showJSHashObj "PPad" 
     184             [("pScope", showJSON aa) , ("pSyms", showJSON ab) , 
     185              ("pStmts", showJSON ac)] 
     186 
    170187instance Binary PIL_Stmt where 
    171188    put_ bh PNoop = do 
    … …  
    200217              [("pPos", showPerl5 aa) , ("pExp", showPerl5 ab) , 
    201218               ("pNode", showPerl5 ac)] 
     219 
     220instance JSON PIL_Stmt where 
     221    showJSON (PNoop) = showJSScalar "PNoop" 
     222    showJSON (PStmt aa) = showJSHashObj "PStmt" 
     223             [("pExpr", showJSON aa)] 
     224    showJSON (PPos aa ab ac) = showJSHashObj "PPos" 
     225             [("pPos", showJSON aa) , ("pExp", showJSON ab) , 
     226              ("pNode", showJSON ac)] 
    202227 
    203228instance Binary PIL_Expr where 
    … …  
    251276               ("pBody", showPerl5 ac)] 
    252277 
     278instance JSON PIL_Expr where 
     279    showJSON (PRawName aa) = showJSHashObj "PRawName" 
     280             [("pRawName", showJSON aa)] 
     281    showJSON (PExp aa) = showJSHashObj "PExp" [("pLV", showJSON aa)] 
     282    showJSON (PLit aa) = showJSHashObj "PLit" [("pLit", showJSON aa)] 
     283    showJSON (PThunk aa) = showJSHashObj "PThunk" 
     284             [("pThunk", showJSON aa)] 
     285    showJSON (PCode aa ab ac) = showJSHashObj "PCode" 
     286             [("pType", showJSON aa) , ("pParams", showJSON ab) , 
     287              ("pBody", showJSON ac)] 
     288 
    253289instance Binary PIL_Decl where 
    254290    put_ bh (PSub aa ab ac ad) = do 
    … …  
    269305               ("pSubParams", showPerl5 ac) , ("pSubBody", showPerl5 ad)] 
    270306 
     307instance JSON PIL_Decl where 
     308    showJSON (PSub aa ab ac ad) = showJSHashObj "PSub" 
     309             [("pSubName", showJSON aa) , ("pSubType", showJSON ab) , 
     310              ("pSubParams", showJSON ac) , ("pSubBody", showJSON ad)] 
     311 
    271312instance Binary PIL_Literal where 
    272313    put_ bh (PVal aa) = do 
    … …  
    278319instance Perl5 PIL_Literal where 
    279320    showPerl5 (PVal aa) = showP5HashObj "PVal" [("pVal", showPerl5 aa)] 
     321 
     322instance JSON PIL_Literal where 
     323    showJSON (PVal aa) = showJSHashObj "PVal" [("pVal", showJSON aa)] 
    280324 
    281325instance Binary PIL_LValue where 
    … …  
    329373              [("pLHS", showPerl5 aa) , ("pRHS", showPerl5 ab)] 
    330374 
     375instance JSON PIL_LValue where 
     376    showJSON (PVar aa) = showJSHashObj "PVar" 
     377             [("pVarName", showJSON aa)] 
     378    showJSON (PApp aa ab ac ad) = showJSHashObj "PApp" 
     379             [("pCxt", showJSON aa) , ("pFun", showJSON ab) , 
     380              ("pInv", showJSON ac) , ("pArgs", showJSON ad)] 
     381    showJSON (PAssign aa ab) = showJSHashObj "PAssign" 
     382             [("pLHS", showJSON aa) , ("pRHS", showJSON ab)] 
     383    showJSON (PBind aa ab) = showJSHashObj "PBind" 
     384             [("pLHS", showJSON aa) , ("pRHS", showJSON ab)] 
     385 
    331386instance Binary TParam where 
    332387    put_ bh (MkTParam aa ab) = do 
    … …  
    341396    showPerl5 (MkTParam aa ab) = showP5HashObj "MkTParam" 
    342397              [("tpParam", showPerl5 aa) , ("tpDefault", showPerl5 ab)] 
     398 
     399instance JSON TParam where 
     400    showJSON (MkTParam aa ab) = showJSHashObj "MkTParam" 
     401             [("tpParam", showJSON aa) , ("tpDefault", showJSON ab)] 
    343402 
    344403instance Binary TCxt where 
    … …  
    385444              [showPerl5 aa] 
    386445 
     446instance JSON TCxt where 
     447    showJSON (TCxtVoid) = showJSScalar "TCxtVoid" 
     448    showJSON (TCxtLValue aa) = showJSArrayObj "TCxtLValue" 
     449             [showJSON aa] 
     450    showJSON (TCxtItem aa) = showJSArrayObj "TCxtItem" [showJSON aa] 
     451    showJSON (TCxtSlurpy aa) = showJSArrayObj "TCxtSlurpy" 
     452             [showJSON aa] 
     453    showJSON (TTailCall aa) = showJSArrayObj "TTailCall" [showJSON aa] 
     454 
    387455instance Binary TEnv where 
    388456    put_ bh (MkTEnv aa ab ac ad ae) = do 
    … …  
    405473               ("tCxt", showPerl5 ac) , ("tReg", showPerl5 ad) , 
    406474               ("tLabel", showPerl5 ae)] 
     475 
     476instance JSON TEnv where 
     477    showJSON (MkTEnv aa ab ac ad ae) = showJSHashObj "MkTEnv" 
     478             [("tLexDepth", showJSON aa) , ("tTokDepth", showJSON ab) , 
     479              ("tCxt", showJSON ac) , ("tReg", showJSON ad) , 
     480              ("tLabel", showJSON ae)] 
    407481 
    408482instance Binary Scope where 
    … …  
    442516    showPerl5 (STemp) = showP5Class "STemp" 
    443517    showPerl5 (SGlobal) = showP5Class "SGlobal" 
     518 
     519instance JSON Scope where 
     520    showJSON (SState) = showJSScalar "SState" 
     521    showJSON (SMy) = showJSScalar "SMy" 
     522    showJSON (SOur) = showJSScalar "SOur" 
     523    showJSON (SLet) = showJSScalar "SLet" 
     524    showJSON (STemp) = showJSScalar "STemp" 
     525    showJSON (SGlobal) = showJSScalar "SGlobal" 
    444526 
    445527instance Binary SubType where 
    … …  
    484566    showPerl5 (SubPointy) = showP5Class "SubPointy" 
    485567    showPerl5 (SubPrim) = showP5Class "SubPrim" 
     568 
     569instance JSON SubType where 
     570    showJSON (SubMethod) = showJSScalar "SubMethod" 
     571    showJSON (SubCoroutine) = showJSScalar "SubCoroutine" 
     572    showJSON (SubMacro) = showJSScalar "SubMacro" 
     573    showJSON (SubRoutine) = showJSScalar "SubRoutine" 
     574    showJSON (SubBlock) = showJSScalar "SubBlock" 
     575    showJSON (SubPointy) = showJSScalar "SubPointy" 
     576    showJSON (SubPrim) = showJSScalar "SubPrim" 
    486577 
    487578instance Binary Val where 
    … …  
    546637    showPerl5 (VType aa) = showP5ArrayObj "VType" [showPerl5 aa] 
    547638 
     639instance JSON Val where 
     640    showJSON (VUndef) = showJSScalar "VUndef" 
     641    showJSON (VBool aa) = showJSArrayObj "VBool" [showJSON aa] 
     642    showJSON (VInt aa) = showJSArrayObj "VInt" [showJSON aa] 
     643    showJSON (VRat aa) = showJSArrayObj "VRat" [showJSON aa] 
     644    showJSON (VNum aa) = showJSArrayObj "VNum" [showJSON aa] 
     645    showJSON (VStr aa) = showJSArrayObj "VStr" [showJSON aa] 
     646    showJSON (VList aa) = showJSArrayObj "VList" [showJSON aa] 
     647    showJSON (VType aa) = showJSArrayObj "VType" [showJSON aa] 
     648 
    548649instance Binary Cxt where 
    549650    put_ bh CxtVoid = do 
    … …  
    572673    showPerl5 (CxtSlurpy aa) = showP5ArrayObj "CxtSlurpy" 
    573674              [showPerl5 aa] 
     675 
     676instance JSON Cxt where 
     677    showJSON (CxtVoid) = showJSScalar "CxtVoid" 
     678    showJSON (CxtItem aa) = showJSArrayObj "CxtItem" [showJSON aa] 
     679    showJSON (CxtSlurpy aa) = showJSArrayObj "CxtSlurpy" [showJSON aa] 
    574680 
    575681instance Binary Type where 
    … …  
    606712    showPerl5 (TypeAnd aa ab) = showP5ArrayObj "TypeAnd" 
    607713              [showPerl5 aa , showPerl5 ab] 
     714 
     715instance JSON Type where 
     716    showJSON (MkType aa) = showJSArrayObj "MkType" [showJSON aa] 
     717    showJSON (TypeOr aa ab) = showJSArrayObj "TypeOr" 
     718             [showJSON aa , showJSON ab] 
     719    showJSON (TypeAnd aa ab) = showJSArrayObj "TypeAnd" 
     720             [showJSON aa , showJSON ab] 
    608721 
    609722instance Binary Param where 
    … …  
    639752               ("paramDefault", showPerl5 ai)] 
    640753 
     754instance JSON Param where 
     755    showJSON (MkParam aa ab ac ad ae af ag ah ai) = 
     756             showJSHashObj "MkParam" 
     757             [("isInvocant", showJSON aa) , ("isOptional", showJSON ab) , 
     758              ("isNamed", showJSON ac) , ("isLValue", showJSON ad) , 
     759              ("isWritable", showJSON ae) , ("isLazy", showJSON af) , 
     760              ("paramName", showJSON ag) , ("paramContext", showJSON ah) , 
     761              ("paramDefault", showJSON ai)] 
     762 
    641763instance Binary Pos where 
    642764    put_ bh (MkPos aa ab ac ad ae) = do 
    … …  
    660782               ("posEndColumn", showPerl5 ae)] 
    661783 
     784instance JSON Pos where 
     785    showJSON (MkPos aa ab ac ad ae) = showJSHashObj "MkPos" 
     786             [("posName", showJSON aa) , ("posBeginLine", showJSON ab) , 
     787              ("posBeginColumn", showJSON ac) , ("posEndLine", showJSON ad) , 
     788              ("posEndColumn", showJSON ae)] 
     789 
    662790--  Imported from other files :- 

  • src/Pugs/PIL1.hs-drift

    r6248 r6250  
    1313import DrIFT.Perl5 
    1414import DrIFT.Binary 
     15import DrIFT.JSON 
    1516 
    1617-- import DrIFT.XML 
    1718-- {-! global : Haskell2Xml !-} 
    1819 
    19 {-! global : GhcBinary, Perl5 !-} 
     20{-! global : GhcBinary, Perl5, JSON !-} 
    2021 
    2122{-| 
    … …  
    117118instance Perl5 Exp where 
    118119    showPerl5 _ = "(undef)" 
     120instance JSON Exp where 
     121    showJSON _ = "null" 
    119122 
    120123=begin DRIFT