Changeset 8685

Show
Ignore:
Timestamp:
01/15/06 18:19:16 (3 years ago)
Author:
audreyt
Message:

* The extremely Syck backend to dump parse tree as YAML:

./pugs -C Parse-YAML -e '...'

Location:
src/Pugs
Files:
5 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/AST/Internals.hs

    r8670 r8685  
    1 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields #-} 
     1{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -funbox-strict-fields -fallow-undecidable-instances #-} 
     2{- Generated by DrIFT (Automatic class derivations for Haskell) -} 
     3{-# LINE 1 "src/Pugs/AST/Internals.hs-drift" #-} 
    24{-# OPTIONS_GHC -#include "../../UnicodeC.h" #-} 
    35 
    … …  
    8587import Pugs.AST.SIO 
    8688import Pugs.Embed.Perl5 
     89import DrIFT.Perl5 
     90import DrIFT.YAML 
     91import DrIFT.JSON 
    8792 
    8893#include "../Types/Array.hs" 
    … …  
    607612    , thunkType :: VType 
    608613    } 
    609     deriving (Typeable) 
     614    deriving (Typeable) {-!derive: YAML!-} 
    610615newtype VProcess = MkProcess (ProcessHandle) 
    611     deriving (Typeable) 
     616    deriving (Typeable) {-!derive: YAML!-} 
    612617 
    613618type VPair = (Val, Val) 
    614619type VType = Type 
     620 
     621 
     622{-| 
     623Representation for rules (i.e. regexes). 
     624 
     625Currently there are two types of rules: Perl 5 rules, implemented with PCRE, 
     626and Perl 6 rules, implemented with PGE. 
     627-} 
     628data VRule 
     629    -- | Perl5-compatible regular expression 
     630    = MkRulePCRE 
     631        { rxRegex     :: !Regex -- ^ The \'regular\' expression (as a PCRE 
     632                                --     'Regex' object) 
     633        , rxGlobal    :: !Bool  -- ^ Flag indicating \'global\' (match-all) 
     634        , rxNumSubs   :: !Int   -- ^ The number of subpatterns present. 
     635            , rxStringify :: !Bool 
     636        , rxRuleStr   :: !String -- ^ The rule string, for user reference. 
     637        , rxAdverbs   :: !Val 
     638        } 
     639    -- | Parrot Grammar Engine rule 
     640    | MkRulePGE 
     641        { rxRule      :: !String -- ^ The rule string 
     642        , rxGlobal    :: !Bool   -- ^ Flag indicating \'global\' (match-all) 
     643        , rxStringify :: !Bool 
     644        , rxAdverbs   :: !Val 
     645        } 
     646    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
    615647 
    616648{-| 
    … …  
    649681    | VOpaque   !VOpaque 
    650682    | PerlSV    !PerlSV 
    651     deriving (Show, Eq, Ord, Typeable) 
     683    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
    652684 
    653685{-| 
    … …  
    689721    | ControlExit  !ExitCode 
    690722    | ControlEnv   !Env 
    691     deriving (Show, Eq, Ord) 
     723    deriving (Show, Eq, Ord) {-!derive: YAML!-} 
    692724 
    693725{-| 
    … …  
    708740    --     junctions, contains the set of values that appear exactly 
    709741    --     /once/. 
    710     } deriving (Eq, Ord) 
     742    } deriving (Eq, Ord) {-!derive: YAML!-} 
    711743 
    712744-- | The combining semantics of a junction. See 'VJunc' for more info. 
    … …  
    715747              | JNone -- ^ Matches only if /no/ members match 
    716748              | JOne  -- ^ Matches if /exactly one/ member matches 
    717     deriving (Eq, Ord) 
     749    deriving (Eq, Ord) {-!derive: YAML!-} 
    718750 
    719751instance Show JuncType where 
    … …  
    746778             | SubPointy    -- ^ Pointy sub 
    747779             | SubPrim      -- ^ Built-in primitive operator (see "Pugs.Prim") 
    748     deriving (Show, Eq, Ord) 
     780    deriving (Show, Eq, Ord) {-!derive: YAML, JSON, Perl5!-} 
    749781 
    750782isSlurpy :: Param -> Bool 
    … …  
    769801                                    --     when omitted 
    770802    } 
    771     deriving (Show, Eq, Ord) 
     803    deriving (Show, Eq, Ord) {-!derive: YAML, Perl5, JSON!-} 
     804 
     805instance (Typeable a, YAML a) => YAML (TVar a) where 
     806    asYAML tv = do 
     807        v <- liftSTM (readTVar tv) 
     808        asYAML v 
    772809 
    773810-- | A list of formal parameters. 
    … …  
    818855    , subCont       :: !(Maybe (TVar VThunk)) -- ^ Coroutine re-entry point 
    819856    } 
    820     deriving (Show, Eq, Ord, Typeable) 
     857    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
    821858 
    822859{-| 
    … …  
    869906    | Pos !Pos                -- ^ Position 
    870907    | Prag ![Pragma]          -- ^ Lexical pragmas 
    871      deriving (Show, Eq, Ord, Typeable) 
     908    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
    872909 
    873910{- Expressions 
    … …  
    899936    | Var !Var                          -- ^ Variable 
    900937    | NonTerm !Pos                      -- ^ Parse error 
    901      deriving (Show, Eq, Ord, Typeable) 
     938    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
    902939 
    903940instance Value Exp where 
    … …  
    10751112    , envPragmas :: ![Pragma]            -- ^ List of pragmas in effect 
    10761113    , envInitDat :: !(TVar InitDat)      -- ^ BEGIN result information 
    1077     } deriving (Show, Eq, Ord, Typeable) 
     1114    }  
     1115    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
    10781116 
    10791117{-| 
    … …  
    10891127data InitDat = MkInitDat 
    10901128    { initPragmas :: [Pragma]            -- ^ Pragma values being installed 
    1091     } deriving (Show, Eq, Ord, Typeable) 
     1129    } deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
    10921130 
    10931131envWant :: Env -> String 
    … …  
    11211159 
    11221160data Pad = MkPad !(Map Var PadEntry) 
    1123     deriving (Eq, Ord, Typeable) 
     1161    deriving (Eq, Ord, Typeable) {-!derive: YAML!-} 
    11241162 
    11251163data PadEntry 
    11261164    = MkEntry !(TVar Bool, TVar VRef)           -- single entry 
    11271165    | MkEntryMulti ![(TVar Bool, TVar VRef)]    -- multi subs 
    1128     deriving (Eq, Ord, Typeable) 
     1166    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
     1167 
     1168data IHashEnv = MkHashEnv deriving (Show, Typeable) {-!derive: YAML!-} 
     1169data IScalarCwd = MkScalarCwd deriving (Show, Typeable) {-!derive: YAML!-} 
     1170 
     1171data VObject = MkObject 
     1172    { objType   :: !VType 
     1173    , objAttrs  :: !IHash 
     1174    , objOpaque :: !(Maybe Dynamic) 
     1175    , objId     :: !Unique 
     1176    } 
     1177    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
     1178 
     1179-- | A $/ object, the return of a rx match operation. 
     1180data VMatch = MkMatch 
     1181    { matchOk           :: !VBool   -- success? 
     1182    , matchFrom         :: !Int     -- .from 
     1183    , matchTo           :: !Int     -- .to 
     1184    , matchStr          :: !VStr    -- captured str 
     1185    , matchSubPos       :: !VList   -- positional submatches 
     1186    , matchSubNamed     :: !VHash   -- named submatches 
     1187    } 
     1188    deriving (Show, Eq, Ord, Typeable) {-!derive: YAML!-} 
     1189 
    11291190 
    11301191instance Show Pad where 
    … …  
    15521613-- Haddock doesn't seem to like data/instance declarations with a where clause. 
    15531614#ifndef HADDOCK 
     1615 
    15541616data IVar v where 
    15551617    IScalar :: ScalarClass a => !a -> IVar VScalar 
    … …  
    15641626data VOpaque where 
    15651627    MkOpaque :: Value a => !a -> VOpaque 
    1566  
    1567 data VObject = MkObject 
    1568     { objType   :: !VType 
    1569     , objAttrs  :: !IHash 
    1570     , objOpaque :: !(Maybe Dynamic) 
    1571     , objId     :: !Unique 
    1572     } 
    1573     deriving (Show, Eq, Ord, Typeable) 
    1574  
    1575 -- | A $/ object, the return of a rx match operation. 
    1576 data VMatch = MkMatch 
    1577     { matchOk           :: !VBool   -- success? 
    1578     , matchFrom         :: !Int     -- .from 
    1579     , matchTo           :: !Int     -- .to 
    1580     , matchStr          :: !VStr    -- captured str 
    1581     , matchSubPos       :: !VList   -- positional submatches 
    1582     , matchSubNamed     :: !VHash   -- named submatches 
    1583     } 
    1584     deriving (Show, Eq, Ord, Typeable) 
    15851628 
    15861629-- | An empty failed match 
    … …  
    17081751type IHandle = VHandle -- XXX maybe TVar? 
    17091752 
    1710 data IHashEnv = MkHashEnv deriving (Typeable) 
    1711 data IScalarCwd = MkScalarCwd deriving (Typeable) 
    1712  
    17131753-- GADTs, here we come! 
    17141754data VRef where 
    … …  
    17321772#endif 
    17331773 
    1734 {-| 
    1735 Representation for rules (i.e. regexes). 
    1736  
    1737 Currently there are two types of rules: Perl 5 rules, implemented with PCRE, 
    1738 and Perl 6 rules, implemented with PGE. 
    1739 -} 
    1740 data VRule 
    1741     -- | Perl5-compatible regular expression 
    1742     = MkRulePCRE 
    1743         { rxRegex     :: !Regex -- ^ The \'regular\' expression (as a PCRE 
    1744                                 --     'Regex' object) 
    1745         , rxGlobal    :: !Bool  -- ^ Flag indicating \'global\' (match-all) 
    1746         , rxNumSubs   :: !Int   -- ^ The number of subpatterns present. 
    1747             , rxStringify :: !Bool 
    1748         , rxRuleStr   :: !String -- ^ The rule string, for user reference. 
    1749         , rxAdverbs   :: !Val 
    1750         } 
    1751     -- | Parrot Grammar Engine rule 
    1752     | MkRulePGE 
    1753         { rxRule      :: !String -- ^ The rule string 
    1754         , rxGlobal    :: !Bool   -- ^ Flag indicating \'global\' (match-all) 
    1755             , rxStringify :: !Bool 
    1756         , rxAdverbs   :: !Val 
    1757         } 
    1758     deriving (Show, Eq, Ord, Typeable) 
     1774-- Move them to Pugs.AST.Instances later? 
     1775instance YAML (a -> Eval b) 
     1776instance YAML (Eval a) 
     1777instance YAML (Map String String) 
     1778instance YAML (Map VStr (IVar VScalar)) 
     1779instance YAML (Map Var PadEntry) 
     1780instance YAML (Set Val) 
     1781instance YAML (VThread Val) 
     1782instance YAML ClassTree 
     1783instance YAML Dynamic 
     1784instance YAML ExitCode 
     1785instance YAML Pragma 
     1786instance YAML ProcessHandle 
     1787instance YAML Regex 
     1788instance YAML Unique 
     1789instance YAML VComplex 
     1790instance YAML VHandle 
     1791instance YAML VHash 
     1792instance YAML VOpaque 
     1793instance YAML VRef 
     1794instance YAML VSocket 
     1795 
     1796instance Perl5 Exp where 
     1797    showPerl5 _ = "(undef)" 
     1798instance JSON Exp where 
     1799    showJSON _ = "null" 
     1800 
     1801-- Non-canonical serialization... needs work 
     1802instance (Show (TVar a)) => Perl5 (TVar a) where 
     1803    showPerl5 _ = "(warn '<ref>')" 
     1804instance (Show (TVar a)) => JSON (TVar a) where 
     1805    showJSON _ = "null" 
     1806 
     1807------------------------------------------------------------------------ 
     1808{-* Generated by DrIFT : Look, but Don't Touch. *-} 
     1809instance YAML VThunk where 
     1810    asYAML (MkThunk aa ab) = asYAMLmap "MkThunk" 
     1811           [("thunkExp", asYAML aa) , ("thunkType", asYAML ab)] 
     1812 
     1813instance YAML VProcess where 
     1814    asYAML (MkProcess aa) = asYAMLseq "MkProcess" [asYAML aa] 
     1815 
     1816instance Perl5 Val where 
     1817    showPerl5 (VUndef) = showP5Class "VUndef" 
     1818    showPerl5 (VBool aa) = showP5ArrayObj "VBool" [showPerl5 aa] 
     1819    showPerl5 (VInt aa) = showP5ArrayObj "VInt" [showPerl5 aa] 
     1820    showPerl5 (VRat aa) = showP5ArrayObj "VRat" [showPerl5 aa] 
     1821    showPerl5 (VNum aa) = showP5ArrayObj "VNum" [showPerl5 aa] 
     1822    showPerl5 (VStr aa) = showP5ArrayObj "VStr" [showPerl5 aa] 
     1823    showPerl5 (VList aa) = showP5ArrayObj "VList" [showPerl5 aa] 
     1824    showPerl5 (VType aa) = showP5ArrayObj "VType" [showPerl5 aa] 
     1825 
     1826instance JSON Val where 
     1827    showJSON (VUndef) = showJSScalar "VUndef" 
     1828    showJSON (VBool aa) = showJSArrayObj "VBool" [showJSON aa] 
     1829    showJSON (VInt aa) = showJSArrayObj "VInt" [showJSON aa] 
     1830    showJSON (VRat aa) = showJSArrayObj "VRat" [showJSON aa] 
     1831    showJSON (VNum aa) = showJSArrayObj "VNum" [showJSON aa] 
     1832    showJSON (VStr aa) = showJSArrayObj "VStr" [showJSON aa] 
     1833    showJSON (VList aa) = showJSArrayObj "VList" [showJSON aa] 
     1834    showJSON (VType aa) = showJSArrayObj "VType" [showJSON aa] 
     1835 
     1836instance YAML Scope where 
     1837    asYAML (SState) = asYAMLcls "SState" 
     1838    asYAML (SMy) = asYAMLcls "SMy" 
     1839    asYAML (SOur) = asYAMLcls "SOur" 
     1840    asYAML (SLet) = asYAMLcls "SLet" 
     1841    asYAML (STemp) = asYAMLcls "STemp" 
     1842    asYAML (SGlobal) = asYAMLcls "SGlobal" 
     1843 
     1844instance JSON Scope where 
     1845    showJSON (SState) = showJSScalar "SState" 
     1846    showJSON (SMy) = showJSScalar "SMy" 
     1847    showJSON (SOur) = showJSScalar "SOur" 
     1848    showJSON (SLet) = showJSScalar "SLet" 
     1849    showJSON (STemp) = showJSScalar "STemp" 
     1850    showJSON (SGlobal) = showJSScalar "SGlobal" 
     1851 
     1852instance Perl5 Scope where 
     1853    showPerl5 (SState) = showP5Class "SState" 
     1854    showPerl5 (SMy) = showP5Class "SMy" 
     1855    showPerl5 (SOur) = showP5Class "SOur" 
     1856    showPerl5 (SLet) = showP5Class "SLet" 
     1857    showPerl5 (STemp) = showP5Class "STemp" 
     1858    showPerl5 (SGlobal) = showP5Class "SGlobal" 
     1859 
     1860instance YAML Pos where 
     1861    asYAML (MkPos aa ab ac ad ae) = asYAMLmap "MkPos" 
     1862           [("posName", asYAML aa) , ("posBeginLine", asYAML ab) , 
     1863            ("posBeginColumn", asYAML ac) , ("posEndLine", asYAML ad) , 
     1864            ("posEndColumn", asYAML ae)] 
     1865 
     1866instance JSON Pos where 
     1867    showJSON (MkPos aa ab ac ad ae) = showJSHashObj "MkPos" 
     1868             [("posName", showJSON aa) , ("posBeginLine", showJSON ab) , 
     1869              ("posBeginColumn", showJSON ac) , ("posEndLine", showJSON ad) , 
     1870              ("posEndColumn", showJSON ae)] 
     1871 
     1872instance Perl5 Pos where 
     1873    showPerl5 (MkPos aa ab ac ad ae) = showP5HashObj "MkPos" 
     1874              [("posName", showPerl5 aa) , ("posBeginLine", showPerl5 ab) , 
     1875               ("posBeginColumn", showPerl5 ac) , ("posEndLine", showPerl5 ad) , 
     1876               ("posEndColumn", showPerl5 ae)] 
     1877 
     1878instance YAML Type where 
     1879    asYAML (MkType aa) = asYAMLseq "MkType" [asYAML aa] 
     1880    asYAML (TypeOr aa ab) = asYAMLseq "TypeOr" [asYAML aa , asYAML ab] 
     1881    asYAML (TypeAnd aa ab) = asYAMLseq "TypeAnd" 
     1882           [asYAML aa , asYAML ab] 
     1883 
     1884instance JSON Type where 
     1885    showJSON (MkType aa) = showJSArrayObj "MkType" [showJSON aa] 
     1886    showJSON (TypeOr aa ab) = showJSArrayObj "TypeOr" 
     1887             [showJSON aa , showJSON ab] 
     1888    showJSON (TypeAnd aa ab) = showJSArrayObj "TypeAnd" 
     1889             [showJSON aa , showJSON ab] 
     1890 
     1891instance Perl5 Type where 
     1892    showPerl5 (MkType aa) = showP5ArrayObj "MkType" [showPerl5 aa] 
     1893    showPerl5 (TypeOr aa ab) = showP5ArrayObj "TypeOr" 
     1894              [showPerl5 aa , showPerl5 ab] 
     1895    showPerl5 (TypeAnd aa ab) = showP5ArrayObj "TypeAnd" 
     1896              [showPerl5 aa , showPerl5 ab] 
     1897 
     1898instance YAML Cxt where 
     1899    asYAML (CxtVoid) = asYAMLcls "CxtVoid" 
     1900    asYAML (CxtItem aa) = asYAMLseq "CxtItem" [asYAML aa] 
     1901    asYAML (CxtSlurpy aa) = asYAMLseq "CxtSlurpy" [asYAML aa] 
     1902 
     1903instance JSON Cxt where 
     1904    showJSON (CxtVoid) = showJSScalar "CxtVoid" 
     1905    showJSON (CxtItem aa) = showJSArrayObj "CxtItem" [showJSON aa] 
     1906    showJSON (CxtSlurpy aa) = showJSArrayObj "CxtSlurpy" [showJSON aa] 
     1907 
     1908instance Perl5 Cxt where 
     1909    showPerl5 (CxtVoid) = showP5Class "CxtVoid" 
     1910    showPerl5 (CxtItem aa) = showP5ArrayObj "CxtItem" [showPerl5 aa] 
     1911    showPerl5 (CxtSlurpy aa) = showP5ArrayObj "CxtSlurpy" 
     1912              [showPerl5 aa] 
     1913 
     1914instance YAML VRule where 
     1915    asYAML (MkRulePCRE aa ab ac ad ae af) = asYAMLmap "MkRulePCRE" 
     1916           [("rxRegex", asYAML aa) , ("rxGlobal", asYAML ab) , 
     1917            ("rxNumSubs", asYAML ac) , ("rxStringify", asYAML ad) , 
     1918            ("rxRuleStr", asYAML ae) , ("rxAdverbs", asYAML af)] 
     1919    asYAML (MkRulePGE aa ab ac ad) = asYAMLmap "MkRulePGE" 
     1920           [("rxRule", asYAML aa) , ("rxGlobal", asYAML ab) , 
     1921            ("rxStringify", asYAML ac) , ("rxAdverbs", asYAML ad)] 
     1922 
     1923instance YAML Val where 
     1924    asYAML (VUndef) = asYAMLcls "VUndef" 
     1925    asYAML (VBool aa) = asYAMLseq "VBool" [asYAML aa] 
     1926    asYAML (VInt aa) = asYAMLseq "VInt" [asYAML aa] 
     1927    asYAML (VRat aa) = asYAMLseq "VRat" [asYAML aa] 
     1928    asYAML (VNum aa) = asYAMLseq "VNum" [asYAML aa] 
     1929    asYAML (VComplex aa) = asYAMLseq "VComplex" [asYAML aa] 
     1930    asYAML (VStr aa) = asYAMLseq "VStr" [asYAML aa] 
     1931    asYAML (VList aa) = asYAMLseq "VList" [asYAML aa] 
     1932    asYAML (VType aa) = asYAMLseq "VType" [asYAML aa] 
     1933    asYAML (VJunc aa) = asYAMLseq "VJunc" [asYAML aa] 
     1934    asYAML (VError aa ab) = asYAMLseq "VError" [asYAML aa , asYAML ab] 
     1935    asYAML (VControl aa) = asYAMLseq "VControl" [asYAML aa] 
     1936    asYAML (VRef aa) = asYAMLseq "VRef" [asYAML aa] 
     1937    asYAML (VCode aa) = asYAMLseq "VCode" [asYAML aa] 
     1938    asYAML (VBlock aa) = asYAMLseq "VBlock" [asYAML aa] 
     1939    asYAML (VHandle aa) = asYAMLseq "VHandle" [asYAML aa] 
     1940    asYAML (VSocket aa) = asYAMLseq "VSocket" [asYAML aa] 
     1941    asYAML (VThread aa) = asYAMLseq "VThread" [asYAML aa] 
     1942    asYAML (VProcess aa) = asYAMLseq "VProcess" [asYAML aa] 
     1943    asYAML (VRule aa) = asYAMLseq "VRule" [asYAML aa] 
     1944    asYAML (VSubst aa) = asYAMLseq "VSubst" [asYAML aa] 
     1945    asYAML (VMatch aa) = asYAMLseq "VMatch" [asYAML aa] 
     1946    asYAML (VObject aa) = asYAMLseq "VObject" [asYAML aa] 
     1947    asYAML (VOpaque aa) = asYAMLseq "VOpaque" [asYAML aa] 
     1948    asYAML (PerlSV aa) = asYAMLseq "PerlSV" [asYAML aa] 
     1949 
     1950instance YAML VControl where 
     1951    asYAML (ControlLeave aa ab) = asYAMLseq "ControlLeave" 
     1952           [asYAML aa , asYAML ab] 
     1953    asYAML (ControlExit aa) = asYAMLseq "ControlExit" [asYAML aa] 
     1954    asYAML (ControlEnv aa) = asYAMLseq "ControlEnv" [asYAML aa] 
     1955 
     1956instance YAML VJunc where 
     1957    asYAML (MkJunc aa ab ac) = asYAMLmap "MkJunc" 
     1958           [("juncType", asYAML aa) , ("juncDup", asYAML ab) , 
     1959            ("juncSet", asYAML ac)] 
     1960 
     1961instance YAML JuncType where 
     1962    asYAML (JAny) = asYAMLcls "JAny" 
     1963    asYAML (JAll) = asYAMLcls "JAll" 
     1964    asYAML (JNone) = asYAMLcls "JNone" 
     1965    asYAML (JOne) = asYAMLcls "JOne" 
     1966 
     1967instance YAML SubType where 
     1968    asYAML (SubMethod) = asYAMLcls "SubMethod" 
     1969    asYAML (SubCoroutine) = asYAMLcls "SubCoroutine" 
     1970    asYAML (SubMacro) = asYAMLcls "SubMacro" 
     1971    asYAML (SubRoutine) = asYAMLcls "SubRoutine" 
     1972    asYAML (SubBlock) = asYAMLcls "SubBlock" 
     1973    asYAML (SubPointy) = asYAMLcls "SubPointy" 
     1974    asYAML (SubPrim) = asYAMLcls "SubPrim" 
     1975 
     1976instance JSON SubType where 
     1977    showJSON (SubMethod) = showJSScalar "SubMethod" 
     1978    showJSON (SubCoroutine) = showJSScalar "SubCoroutine" 
     1979    showJSON (SubMacro) = showJSScalar "SubMacro" 
     1980    showJSON (SubRoutine) = showJSScalar "SubRoutine" 
     1981    showJSON (SubBlock) = showJSScalar "SubBlock" 
     1982    showJSON (SubPointy) = showJSScalar "SubPointy" 
     1983    showJSON (SubPrim) = showJSScalar "SubPrim" 
     1984 
     1985instance Perl5 SubType where 
     1986    showPerl5 (SubMethod) = showP5Class "SubMethod" 
     1987    showPerl5 (SubCoroutine) = showP5Class "SubCoroutine" 
     1988    showPerl5 (SubMacro) = showP5Class "SubMacro" 
     1989    showPerl5 (SubRoutine) = showP5Class "SubRoutine" 
     1990    showPerl5 (SubBlock) = showP5Class "SubBlock" 
     1991    showPerl5 (SubPointy) = showP5Class "SubPointy" 
     1992    showPerl5 (SubPrim) = showP5Class "SubPrim" 
     1993 
     1994instance YAML Param where 
     1995    asYAML (MkParam aa ab ac ad ae af ag ah ai) = asYAMLmap "MkParam" 
     1996           [("isInvocant", asYAML aa) , ("isOptional", asYAML ab) , 
     1997            ("isNamed", asYAML ac) , ("isLValue", asYAML ad) , 
     1998            ("isWritable", asYAML ae) , ("isLazy", asYAML af) , 
     1999            ("paramName", asYAML ag) , ("paramContext", asYAML ah) , 
     2000            ("paramDefault", asYAML ai)] 
     2001 
     2002instance Perl5 Param where 
     2003    showPerl5 (MkParam aa ab ac ad ae af ag ah ai) = 
     2004              showP5HashObj "MkParam" 
     2005              [("isInvocant", showPerl5 aa) , ("isOptional", showPerl5 ab) , 
     2006               ("isNamed", showPerl5 ac) , ("isLValue", showPerl5 ad) , 
     2007               ("isWritable", showPerl5 ae) , ("isLazy", showPerl5 af) , 
     2008               ("paramName", showPerl5 ag) , ("paramContext", showPerl5 ah) , 
     2009               ("paramDefault", showPerl5 ai)] 
     2010 
     2011instance JSON Param where 
     2012    showJSON (MkParam aa ab ac ad ae af ag ah ai) = 
     2013             showJSHashObj "MkParam" 
     2014             [("isInvocant", showJSON aa) , ("isOptional", showJSON ab) , 
     2015              ("isNamed", showJSON ac) , ("isLValue", showJSON ad) , 
     2016              ("isWritable", showJSON ae) , ("isLazy", showJSON af) , 
     2017              ("paramName", showJSON ag) , ("paramContext", showJSON ah) , 
     2018              ("paramDefault", showJSON ai)] 
     2019 
     2020instance YAML VCode where 
     2021    asYAML (MkCode aa ab ac ad ae af ag ah ai aj ak al) = 
     2022           asYAMLmap "MkCode" 
     2023           [("isMulti", asYAML aa) , ("subName", asYAML ab) , 
     2024            ("subType", asYAML ac) , ("subEnv", asYAML ad) , 
     2025            ("subAssoc", asYAML ae) , ("subParams", asYAML af) , 
     2026            ("subBindings", asYAML ag) , ("subSlurpLimit", asYAML ah) , 
     2027            ("subReturns", asYAML ai) , ("subLValue", asYAML aj) , 
     2028            ("subBody", asYAML ak) , ("subCont", asYAML al)] 
     2029 
     2030instance YAML Ann where 
     2031    asYAML (Cxt aa) = asYAMLseq "Cxt" [asYAML aa] 
     2032    asYAML (Pos aa) = asYAMLseq "Pos" [asYAML aa] 
     2033    asYAML (Prag aa) = asYAMLseq "Prag" [asYAML aa] 
     2034 
     2035instance YAML Exp where 
     2036    asYAML (Noop) = asYAMLcls "Noop" 
     2037    asYAML (App aa ab ac) = asYAMLseq "App" 
     2038           [asYAML aa , asYAML ab , asYAML ac] 
     2039    asYAML (Syn aa ab) = asYAMLseq "Syn" [asYAML aa , asYAML ab] 
     2040    asYAML (Ann aa ab) = asYAMLseq "Ann" [asYAML aa , asYAML ab] 
     2041    asYAML (Pad aa ab ac) = asYAMLseq "Pad" 
     2042           [asYAML aa , asYAML ab , asYAML ac] 
     2043    asYAML (Sym aa ab ac) = asYAMLseq "Sym" 
     2044           [asYAML aa , asYAML ab , asYAML ac] 
     2045    asYAML (Stmts aa ab) = asYAMLseq "Stmts" [asYAML aa , asYAML ab] 
     2046    asYAML (Prim aa) = asYAMLseq "Prim" [asYAML aa] 
     2047    asYAML (Val aa) = asYAMLseq "Val" [asYAML aa] 
     2048    asYAML (Var aa) = asYAMLseq "Var" [asYAML aa] 
     2049    asYAML (NonTerm aa) = asYAMLseq "NonTerm" [asYAML aa] 
     2050 
     2051instance YAML Env where 
     2052    asYAML (MkEnv aa ab ac ad ae af ag ah ai aj ak al am an ao) = 
     2053           asYAMLmap "MkEnv" 
     2054           [("envContext", asYAML aa) , ("envLValue", asYAML ab) , 
     2055            ("envLexical", asYAML ac) , ("envGlobal", asYAML ad) , 
     2056            ("envPackage", asYAML ae) , ("envClasses", asYAML af) , 
     2057            ("envEval", asYAML ag) , ("envCaller", asYAML ah) , 
     2058            ("envOuter", asYAML ai) , ("envBody", asYAML aj) , 
     2059            ("envDepth", asYAML ak) , ("envDebug", asYAML al) , 
     2060            ("envPos", asYAML am) , ("envPragmas", asYAML an) , 
     2061            ("envInitDat", asYAML ao)] 
     2062 
     2063instance YAML InitDat where 
     2064    asYAML (MkInitDat aa) = asYAMLmap "MkInitDat" 
     2065           [("initPragmas", asYAML aa)] 
     2066 
     2067instance YAML Pad where 
     2068    asYAML (MkPad aa) = asYAMLseq "MkPad" [asYAML aa] 
     2069 
     2070instance YAML PadEntry where 
     2071    asYAML (MkEntry aa) = asYAMLseq "MkEntry" [asYAML aa] 
     2072    asYAML (MkEntryMulti aa) = asYAMLseq "MkEntryMulti" [asYAML aa] 
     2073 
     2074instance YAML IHashEnv where 
     2075    asYAML (MkHashEnv) = asYAMLcls "MkHashEnv" 
     2076 
     2077instance YAML IScalarCwd where 
     2078    asYAML (MkScalarCwd) = asYAMLcls "MkScalarCwd" 
     2079 
     2080instance YAML VObject where 
     2081    asYAML (MkObject aa ab ac ad) = asYAMLmap "MkObject" 
     2082           [("objType", asYAML aa) , ("objAttrs", asYAML ab) , 
     2083            ("objOpaque", asYAML ac) , ("objId", asYAML ad)] 
     2084 
     2085instance YAML VMatch where 
     2086    asYAML (MkMatch aa ab ac ad ae af) = asYAMLmap "MkMatch" 
     2087           [("matchOk", asYAML aa) , ("matchFrom", asYAML ab) , 
     2088            ("matchTo", asYAML ac) , ("matchStr", asYAML ad) , 
     2089            ("matchSubPos", asYAML ae) , ("matchSubNamed", asYAML af)] 
     2090 
     2091--  Imported from other files :- 

  • src/Pugs/CodeGen.hs

    r8684 r8685  
    1717import Pugs.CodeGen.PIR (genPIR, genPIR_YAML) 
    1818import Pugs.CodeGen.Perl5 (genPerl5) 
    19 import Pugs.CodeGen.YAML (genYAML) 
     19import Pugs.CodeGen.YAML (genParseYAML, genYAML) 
    2020import Pugs.CodeGen.JSON (genJSON) 
    2121import Pugs.Compile.Pugs (genPugs) 
    … …  
    6666    norm' "pil2json"   = "PIL2-JSON" 
    6767    norm' "pil2yaml"   = "PIL2-YAML" 
     68    norm' "parseyaml"  = "Parse-YAML" 
    6869    norm' "pugs"   = "Pugs" 
    6970    -- norm' "xml"    = "XML" 

  • src/Pugs/CodeGen/YAML.hs

    r8675 r8685  
    22{-# OPTIONS_GHC -#include "../../UnicodeC.h" #-} 
    33 
    4 module Pugs.CodeGen.YAML (genYAML) where 
     4module Pugs.CodeGen.YAML (genYAML, genParseYAML) where 
    55import Pugs.Internals 
    66import Pugs.AST 
    … …  
    99import DrIFT.YAML 
    1010 
     11genParseYAML :: Eval Val 
     12genParseYAML = do 
     13    main    <- asks envBody 
     14    yaml    <- liftIO (showYaml main) 
     15    return (VStr yaml) 
     16 
    1117genYAML :: Eval Val 
    1218genYAML = do 
    1319    penv <- compile () :: Eval PIL_Environment 
    1420    yaml <- liftIO (showYaml penv) 
    15     return . VStr . unlines $ [yaml] 
     21    return (VStr yaml) 

  • src/Pugs/PIL1.hs

    r8682 r8685  
    2626import DrIFT.Perl5 
    2727import DrIFT.YAML 
    28 import DrIFT.Binary 
    2928import DrIFT.JSON 
    3029 
    … …  
    3231-- {-! global : Haskell2Xml !-} 
    3332 
    34 {-! global : GhcBinary, Perl5, JSON, YAML !-} 
     33{-! global : Perl5, JSON, YAML !-} 
    3534 
    3635{-| 
    … …  
    130129 
    131130------------------------------------------------------------------------ 
    132  
    133 instance Binary Exp where 
    134     put_ _ _ = return () 
    135     get  _   = return Noop 
    136 instance YAML Exp where 
    137     asYAML _ = asYAML () 
    138 instance Perl5 Exp where 
    139     showPerl5 _ = "(undef)" 
    140 instance JSON Exp where 
    141     showJSON _ = "null" 
    142  
    143 -- Non-canonical serialization... needs work 
    144 instance (Typeable a, YAML a) => YAML (TVar a) where 
    145     asYAML tv = do 
    146         v <- liftSTM (readTVar tv) 
    147         asYAML v 
    148 instance (Show (TVar a)) => Perl5 (TVar a) where 
    149     showPerl5 _ = "(warn '<ref>')" 
    150 instance (Show (TVar a)) => JSON (TVar a) where 
    151     showJSON _ = "null" 
    152  
    153131{-* Generated by DrIFT : Look, but Don't Touch. *-} 
    154 instance Binary PIL_Environment where 
    155     put_ bh (PIL_Environment aa ab) = do 
    156             put_ bh aa 
    157             put_ bh ab 
    158     get bh = do 
    159     aa <- get bh 
    160     ab <- get bh 
    161     return (PIL_Environment aa ab) 
    162  
    163132instance Perl5 PIL_Environment where 
    164133    showPerl5 (PIL_Environment aa ab) = 
    … …  
    173142    asYAML (PIL_Environment aa ab) = asYAMLmap "PIL_Environment" 
    174143           [("pilGlob", asYAML aa) , ("pilMain", asYAML ab)] 
    175  
    176 instance Binary PIL_Stmts where 
    177     put_ bh PNil = do 
    178             putByte bh 0 
    179     put_ bh (PStmts aa ab) = do 
    180             putByte bh 1 
    181             put_ bh aa 
    182             put_ bh ab 
    183     put_ bh (PPad ac ad ae) = do 
    184             putByte bh 2 
    185             put_ bh ac 
    186             put_ bh ad 
    187             put_ bh ae 
    188     get bh = do 
    189             h <- getByte bh 
    190             case h of 
    191               0 -> do 
    192                     return PNil 
    193               1 -> do 
    194                     aa <- get bh 
    195                     ab <- get bh 
    196                     return (PStmts aa ab) 
    197               2 -> do 
    198                     ac <- get bh 
    199                     ad <- get bh 
    200                     ae <- get bh 
    201                     return (PPad ac ad ae) 
    202<