Changeset 9054

Show
Ignore:
Timestamp:
02/18/06 21:47:47 (3 years ago)
Author:
audreyt
Message:

* pugs -CParse-HsYaml? backend for yaml-node based serialization.
* slightly improved DrIFT.YAML syntax.

Location:
src
Files:
8 modified

Legend:

Unmodified
Added
Removed

  • src/DrIFT/RuleYAML.hs

    r9051 r9054  
    1212 
    1313caseHead, caseTail :: Doc 
    14 caseHead = text "fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of" 
    15 caseTail = nest 8 $ text "_ -> fail $ \"unhandled tag: \" ++ (show t)" 
     14caseHead = text "fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of" 
     15caseTail = nest 4 (text "_ -> fail $ \"unhandled tag: \" ++ show t") 
     16       $+$ text "fromYAML _ = fail \"no tag found\"" 
    1617 
    1718makeFromYAML, makeAsYAML :: IFunction 
    1819 
    1920makeFromYAML Body{constructor=constructor,labels=labels,types=types} = 
    20     nest 8 $ dqt constructor <+> match <+> makeFromYAML' $+$ extraLifts 
     21    nest 4 $ eqv <+> match <+> dot $+$ extraLifts $+$ makeFromYAML' 
    2122    where 
    2223    dqt   = doubleQuotes . text 
    2324    match = text "->" 
    2425    dot   = text "do" 
     26--  eqv   = text "| t == packFS" <+> dqt ("tag:hs:" ++ constructor) 
     27    eqv   = dqt constructor 
    2528    makeFromYAML' 
    26         | null types = text "return" <+> text constructor 
     29        | null types = nest 4 $ text "return" <+> text constructor 
    2730        | null labels = vcat 
    28             [ dot 
    29             , nest 4 $ text "let YamlSeq" <+> (list $ varNames types) <+> equals <+> text "e" 
     31            [ nest 4 $ text "let YamlSeq" <+> (list $ varNames types) <+> equals <+> text "e" 
    3032            , nest 4 $ liftNfy 
    3133            ] 
    3234        | otherwise = vcat 
    33             [ dot 
    34             , nest 4 $ text "let YamlMap assocs = e" 
     35            [ nest 4 $ text "let YamlMap assocs = e" 
    3536            , nest 4 $ text "let" <+> (list $ varNames types) <+> equals <+> text "map snd assocs" 
    3637            , nest 4 $ liftNfy 
    … …  
    4243    extraLifts 
    4344        | length types < 6 = empty 
    44         | otherwise = nest 16 $ (text "where") $+$ (hsep $ -- XXX: pull me to the level of the case? 
     45        | otherwise = nest 4 $ (text "let") <+> (hsep $ -- XXX: pull me to the level of the case? 
    4546            [ (text $ "liftM" ++ (show arity)) 
    4647            , text "f" 

  • src/DrIFT/YAML.hs

    r9051 r9054  
    2626type SeenCache = IntSet.IntSet 
    2727 
     28packFS :: String -> Str.FastString 
     29packFS = Str.pack 
     30 
     31unpackFS :: Str.FastString -> String 
     32unpackFS = Str.unpack 
     33 
     34toYamlNode :: YAML a => a -> IO YamlNode 
     35toYamlNode x = runReaderT (asYAML x) IntSet.empty  
     36 
    2837showYaml :: YAML a => a -> IO String 
    2938showYaml x = do 
    30     node    <- (`runReaderT` IntSet.empty) (asYAML x) 
     39    node    <- toYamlNode x 
    3140    rv      <- emitYaml node 
    32     case rv of 
    33         Left e  -> error e 
    34         Right s -> return s 
     41    either fail return rv 
    3542 
    3643type EmitAs = ReaderT SeenCache IO 
    … …  
    6774    mapM fromYAMLpair m 
    6875    where 
    69     fromYAMLpair ~(MkYamlNode{el=YamlStr k}, v) = do 
     76    fromYAMLpair (MkYamlNode{el=YamlStr k}, v) = do 
    7077        v' <- fromYAML v 
    7178        return (Str.unpack k, v') 
     79    fromYAMLpair _ = fail "no parse" 
    7280     
    7381 
    … …  
    92100instance YAML Int where 
    93101    asYAML x = return $ mkTagNode "int" (YamlStr $ Str.pack $ show x) 
    94     fromYAMLElem ~(YamlStr x) = return $ read $ Str.unpack x 
     102    fromYAMLElem (YamlStr x) = return $ read $ Str.unpack x 
     103    fromYAMLElem _ = fail "no parse" 
    95104 
    96105instance YAML String where 
    97106    asYAML str = return $ mkTagNode "str" (YamlStr $ Str.pack str) 
    98     fromYAMLElem ~(YamlStr str) = return $ Str.unpack str 
     107    fromYAMLElem (YamlStr str) = return $ Str.unpack str 
     108    fromYAMLElem _ = fail "no parse" 
    99109 
    100110instance YAML Bool where 
    … …  
    104114    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "bool#no"  = return False 
    105115    fromYAML MkYamlNode{el=x} = fromYAMLElem x 
    106     fromYAMLElem ~(YamlStr x) = return (x == Str.pack "0") 
     116    fromYAMLElem (YamlStr x) = return (x == Str.pack "0") 
     117    fromYAMLElem _ = fail "no parse" 
    107118 
    108119instance YAML Integer where  
    109120    asYAML x = return $ mkTagNode "int" (YamlStr $ Str.pack $ show x) 
    110     fromYAMLElem ~(YamlStr x) = return $ read $ Str.unpack x 
     121    fromYAMLElem (YamlStr x) = return $ read $ Str.unpack x 
     122    fromYAMLElem _ = fail "no parse" 
    111123 
    112124instance YAML Rational where  
    … …  
    115127        x = numerator r 
    116128        y = denominator r 
    117     fromYAMLElem ~(YamlStr str) = return $ (read x) / (read y) 
    118         where 
    119         (x,y) = break (== '/') (Str.unpack str) 
     129    fromYAMLElem (YamlStr str) = do 
     130        let (x,y) = break (== '/') (Str.unpack str) 
     131        return $ (read x) / (read y) 
     132    fromYAMLElem _ = fail "no parse" 
    120133     
    121134instance YAML Double where  
    … …  
    128141    fromYAML MkYamlNode{tag=Just s} | s == Str.pack "float#nan"    = return $  0/0 -- "NaN"  
    129142    fromYAML MkYamlNode{el=x} = fromYAMLElem x 
    130     fromYAMLElem ~(YamlStr x) = return $ read $ Str.unpack x 
     143    fromYAMLElem (YamlStr x) = return $ read $ Str.unpack x 
     144    fromYAMLElem _ = fail "no parse" 
    131145 
    132146instance (YAML a) => YAML (Maybe a) where 
    … …  
    142156        xs' <- mapM asYAML xs 
    143157        (return . mkNode . YamlSeq) xs' 
    144     fromYAMLElem ~(YamlSeq s) = mapM fromYAML s 
     158    fromYAMLElem (YamlSeq s) = mapM fromYAML s 
     159    fromYAMLElem _ = fail "no parse" 
    145160 
    146161instance (YAML a, YAML b) => YAML (a, b) where 
    … …  
    149164        y' <- asYAML y 
    150165        return $ mkNode (YamlSeq [x', y']) 
    151     fromYAMLElem ~(YamlSeq [x, y]) = do 
     166    fromYAMLElem (YamlSeq [x, y]) = do 
    152167        x' <- fromYAML x 
    153168        y' <- fromYAML y 
    154169        return (x', y') 
     170    fromYAMLElem _ = fail "no parse" 
    155171 
    156172instance (YAML a, YAML b, YAML c) => YAML (a, b, c) where 
    … …  
    160176        z' <- asYAML z 
    161177        return $ mkNode (YamlSeq [x', y', z']) 
    162     fromYAMLElem ~(YamlSeq [x, y, z]) = do 
     178    fromYAMLElem (YamlSeq [x, y, z]) = do 
    163179        x' <- fromYAML x 
    164180        y' <- fromYAML y 
    165181        z' <- fromYAML z 
    166182        return (x', y', z') 
     183    fromYAMLElem _ = fail "no parse" 
    167184 
    168185instance (Typeable a, YAML a) => YAML (TVar a) where 

  • src/Emit/PIR.hs

    r9051 r9054  
    10001000{-* Generated by DrIFT : Look, but Don't Touch. *-} 
    10011001instance YAML Decl where 
    1002     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1003             "DeclSub" -> do  let YamlMap assocs = e 
    1004                              let [aa , ab , ac] = map snd assocs 
    1005                              liftM3 DeclSub (fromYAML aa) (fromYAML ab) (fromYAML ac) 
    1006             "DeclNS" -> do  let YamlMap assocs = e 
    1007                             let [aa , ab] = map snd assocs 
    1008                             liftM2 DeclNS (fromYAML aa) (fromYAML ab) 
    1009             "DeclInc" -> do  let YamlMap assocs = e 
    1010                              let [aa] = map snd assocs 
    1011                              liftM DeclInc (fromYAML aa) 
    1012             _ -> fail $ "unhandled tag: " ++ (show t) 
     1002    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1003        "DeclSub" -> do 
     1004            let YamlMap assocs = e 
     1005            let [aa , ab , ac] = map snd assocs 
     1006            liftM3 DeclSub (fromYAML aa) (fromYAML ab) (fromYAML ac) 
     1007        "DeclNS" -> do 
     1008            let YamlMap assocs = e 
     1009            let [aa , ab] = map snd assocs 
     1010            liftM2 DeclNS (fromYAML aa) (fromYAML ab) 
     1011        "DeclInc" -> do 
     1012            let YamlMap assocs = e 
     1013            let [aa] = map snd assocs 
     1014            liftM DeclInc (fromYAML aa) 
     1015        _ -> fail $ "unhandled tag: " ++ show t 
     1016    fromYAML _ = fail "no tag found" 
    10131017    asYAML (DeclSub aa ab ac) = asYAMLmap "DeclSub" 
    10141018           [("dsName", asYAML aa) , ("dsFlags", asYAML ab) , 
    … …  
    10191023 
    10201024instance YAML Stmt where 
    1021     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1022             "StmtComment" -> do  let YamlSeq [aa] = e 
    1023                                  liftM StmtComment (fromYAML aa) 
    1024             "StmtLine" -> do  let YamlSeq [aa , ab] = e 
    1025                               liftM2 StmtLine (fromYAML aa) (fromYAML ab) 
    1026             "StmtPad" -> do  let YamlSeq [aa , ab] = e 
    1027                              liftM2 StmtPad (fromYAML aa) (fromYAML ab) 
    1028             "StmtRaw" -> do  let YamlSeq [aa] = e 
    1029                              liftM StmtRaw (fromYAML aa) 
    1030             "StmtIns" -> do  let YamlSeq [aa] = e 
    1031                              liftM StmtIns (fromYAML aa) 
    1032             "StmtSub" -> do  let YamlSeq [aa , ab] = e 
    1033                              liftM2 StmtSub (fromYAML aa) (fromYAML ab) 
    1034             _ -> fail $ "unhandled tag: " ++ (show t) 
     1025    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1026        "StmtComment" -> do 
     1027            let YamlSeq [aa] = e 
     1028            liftM StmtComment (fromYAML aa) 
     1029        "StmtLine" -> do 
     1030            let YamlSeq [aa , ab] = e 
     1031            liftM2 StmtLine (fromYAML aa) (fromYAML ab) 
     1032        "StmtPad" -> do 
     1033            let YamlSeq [aa , ab] = e 
     1034            liftM2 StmtPad (fromYAML aa) (fromYAML ab) 
     1035        "StmtRaw" -> do 
     1036            let YamlSeq [aa] = e 
     1037            liftM StmtRaw (fromYAML aa) 
     1038        "StmtIns" -> do 
     1039            let YamlSeq [aa] = e 
     1040            liftM StmtIns (fromYAML aa) 
     1041        "StmtSub" -> do 
     1042            let YamlSeq [aa , ab] = e 
     1043            liftM2 StmtSub (fromYAML aa) (fromYAML ab) 
     1044        _ -> fail $ "unhandled tag: " ++ show t 
     1045    fromYAML _ = fail "no tag found" 
    10351046    asYAML (StmtComment aa) = asYAMLseq "StmtComment" [asYAML aa] 
    10361047    asYAML (StmtLine aa ab) = asYAMLseq "StmtLine" 
    … …  
    10441055 
    10451056instance YAML Ins where 
    1046     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1047             "InsLocal" -> do  let YamlSeq [aa , ab] = e 
    1048                               liftM2 InsLocal (fromYAML aa) (fromYAML ab) 
    1049             "InsNew" -> do  let YamlSeq [aa , ab] = e 
    1050                             liftM2 InsNew (fromYAML aa) (fromYAML ab) 
    1051             "InsBind" -> do  let YamlSeq [aa , ab] = e 
    1052                              liftM2 InsBind (fromYAML aa) (fromYAML ab) 
    1053             "InsAssign" -> do  let YamlSeq [aa , ab] = e 
    1054                                liftM2 InsAssign (fromYAML aa) (fromYAML ab) 
    1055             "InsPrim" -> do  let YamlSeq [aa , ab , ac] = e 
    1056                              liftM3 InsPrim (fromYAML aa) (fromYAML ab) (fromYAML ac) 
    1057             "InsFun" -> do  let YamlSeq [aa , ab , ac] = e 
    1058                             liftM3 InsFun (fromYAML aa) (fromYAML ab) (fromYAML ac) 
    1059             "InsTailFun" -> do  let YamlSeq [aa , ab] = e 
    1060                                 liftM2 InsTailFun (fromYAML aa) (fromYAML ab) 
    1061             "InsLabel" -> do  let YamlSeq [aa] = e 
    1062                               liftM InsLabel (fromYAML aa) 
    1063             "InsComment" -> do  let YamlSeq [aa , ab] = e 
    1064                                 liftM2 InsComment (fromYAML aa) (fromYAML ab) 
    1065             "InsExp" -> do  let YamlSeq [aa] = e 
    1066                             liftM InsExp (fromYAML aa) 
    1067             "InsConst" -> do  let YamlSeq [aa , ab , ac] = e 
    1068                               liftM3 InsConst (fromYAML aa) (fromYAML ab) (fromYAML ac) 
    1069             _ -> fail $ "unhandled tag: " ++ (show t) 
     1057    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1058        "InsLocal" -> do 
     1059            let YamlSeq [aa , ab] = e 
     1060            liftM2 InsLocal (fromYAML aa) (fromYAML ab) 
     1061        "InsNew" -> do 
     1062            let YamlSeq [aa , ab] = e 
     1063            liftM2 InsNew (fromYAML aa) (fromYAML ab) 
     1064        "InsBind" -> do 
     1065            let YamlSeq [aa , ab] = e 
     1066            liftM2 InsBind (fromYAML aa) (fromYAML ab) 
     1067        "InsAssign" -> do 
     1068            let YamlSeq [aa , ab] = e 
     1069            liftM2 InsAssign (fromYAML aa) (fromYAML ab) 
     1070        "InsPrim" -> do 
     1071            let YamlSeq [aa , ab , ac] = e 
     1072            liftM3 InsPrim (fromYAML aa) (fromYAML ab) (fromYAML ac) 
     1073        "InsFun" -> do 
     1074            let YamlSeq [aa , ab , ac] = e 
     1075            liftM3 InsFun (fromYAML aa) (fromYAML ab) (fromYAML ac) 
     1076        "InsTailFun" -> do 
     1077            let YamlSeq [aa , ab] = e 
     1078            liftM2 InsTailFun (fromYAML aa) (fromYAML ab) 
     1079        "InsLabel" -> do 
     1080            let YamlSeq [aa] = e 
     1081            liftM InsLabel (fromYAML aa) 
     1082        "InsComment" -> do 
     1083            let YamlSeq [aa , ab] = e 
     1084            liftM2 InsComment (fromYAML aa) (fromYAML ab) 
     1085        "InsExp" -> do 
     1086            let YamlSeq [aa] = e 
     1087            liftM InsExp (fromYAML aa) 
     1088        "InsConst" -> do 
     1089            let YamlSeq [aa , ab , ac] = e 
     1090            liftM3 InsConst (fromYAML aa) (fromYAML ab) (fromYAML ac) 
     1091        _ -> fail $ "unhandled tag: " ++ show t 
     1092    fromYAML _ = fail "no tag found" 
    10701093    asYAML (InsLocal aa ab) = asYAMLseq "InsLocal" 
    10711094           [asYAML aa , asYAML ab] 
    … …  
    10891112 
    10901113instance YAML Expression where 
    1091     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1092             "ExpLV" -> do  let YamlSeq [aa] = e 
    1093                            liftM ExpLV (fromYAML aa) 
    1094             "ExpLit" -> do  let YamlSeq [aa] = e 
    1095                             liftM ExpLit (fromYAML aa) 
    1096             _ -> fail $ "unhandled tag: " ++ (show t) 
     1114    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1115        "ExpLV" -> do 
     1116            let YamlSeq [aa] = e 
     1117            liftM ExpLV (fromYAML aa) 
     1118        "ExpLit" -> do 
     1119            let YamlSeq [aa] = e 
     1120            liftM ExpLit (fromYAML aa) 
     1121        _ -> fail $ "unhandled tag: " ++ show t 
     1122    fromYAML _ = fail "no tag found" 
    10971123    asYAML (ExpLV aa) = asYAMLseq "ExpLV" [asYAML aa] 
    10981124    asYAML (ExpLit aa) = asYAMLseq "ExpLit" [asYAML aa] 
    10991125 
    11001126instance YAML LValue where 
    1101     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1102             "VAR" -> do  let YamlSeq [aa] = e 
    1103                          liftM VAR (fromYAML aa) 
    1104             "PMC" -> do  let YamlSeq [aa] = e 
    1105                          liftM PMC (fromYAML aa) 
    1106             "STR" -> do  let YamlSeq [aa] = e 
    1107                          liftM STR (fromYAML aa) 
    1108             "INT" -> do  let YamlSeq [aa] = e 
    1109                          liftM INT (fromYAML aa) 
    1110             "NUM" -> do  let YamlSeq [aa] = e 
    1111                          liftM NUM (fromYAML aa) 
    1112             "KEYED" -> do  let YamlSeq [aa , ab] = e 
    1113                            liftM2 KEYED (fromYAML aa) (fromYAML ab) 
    1114             _ -> fail $ "unhandled tag: " ++ (show t) 
     1127    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1128        "VAR" -> do 
     1129            let YamlSeq [aa] = e 
     1130            liftM VAR (fromYAML aa) 
     1131        "PMC" -> do 
     1132            let YamlSeq [aa] = e 
     1133            liftM PMC (fromYAML aa) 
     1134        "STR" -> do 
     1135            let YamlSeq [aa] = e 
     1136            liftM STR (fromYAML aa) 
     1137        "INT" -> do 
     1138            let YamlSeq [aa] = e 
     1139            liftM INT (fromYAML aa) 
     1140        "NUM" -> do 
     1141            let YamlSeq [aa] = e 
     1142            liftM NUM (fromYAML aa) 
     1143        "KEYED" -> do 
     1144            let YamlSeq [aa , ab] = e 
     1145            liftM2 KEYED (fromYAML aa) (fromYAML ab) 
     1146        _ -> fail $ "unhandled tag: " ++ show t 
     1147    fromYAML _ = fail "no tag found" 
    11151148    asYAML (VAR aa) = asYAMLseq "VAR" [asYAML aa] 
    11161149    asYAML (PMC aa) = asYAMLseq "PMC" [asYAML aa] 
    … …  
    11211154 
    11221155instance YAML Literal where 
    1123     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1124             "LitStr" -> do  let YamlSeq [aa] = e 
    1125                             liftM LitStr (fromYAML aa) 
    1126             "LitInt" -> do  let YamlSeq [aa] = e 
    1127                             liftM LitInt (fromYAML aa) 
    1128             "LitNum" -> do  let YamlSeq [aa] = e 
    1129                             liftM LitNum (fromYAML aa) 
    1130             _ -> fail $ "unhandled tag: " ++ (show t) 
     1156    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1157        "LitStr" -> do 
     1158            let YamlSeq [aa] = e 
     1159            liftM LitStr (fromYAML aa) 
     1160        "LitInt" -> do 
     1161            let YamlSeq [aa] = e 
     1162            liftM LitInt (fromYAML aa) 
     1163        "LitNum" -> do 
     1164            let YamlSeq [aa] = e 
     1165            liftM LitNum (fromYAML aa) 
     1166        _ -> fail $ "unhandled tag: " ++ show t 
     1167    fromYAML _ = fail "no tag found" 
    11311168    asYAML (LitStr aa) = asYAMLseq "LitStr" [asYAML aa] 
    11321169    asYAML (LitInt aa) = asYAMLseq "LitInt" [asYAML aa] 
    … …  
    11341171 
    11351172instance YAML SubFlag where 
    1136     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1137             "SubMAIN" -> return SubMAIN 
    1138             "SubLOAD" -> return SubLOAD 
    1139             "SubANON" -> return SubANON 
    1140             "SubMETHOD" -> return SubMETHOD 
    1141             "SubMULTI" -> do  let YamlSeq [aa] = e 
    1142                               liftM SubMULTI (fromYAML aa) 
    1143             "SubOUTER" -> do  let YamlSeq [aa] = e 
    1144                               liftM SubOUTER (fromYAML aa) 
    1145             _ -> fail $ "unhandled tag: " ++ (show t) 
     1173    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1174        "SubMAIN" -> do 
     1175            return SubMAIN 
     1176        "SubLOAD" -> do 
     1177            return SubLOAD 
     1178        "SubANON" -> do 
     1179            return SubANON 
     1180        "SubMETHOD" -> do 
     1181            return SubMETHOD 
     1182        "SubMULTI" -> do 
     1183            let YamlSeq [aa] = e 
     1184            liftM SubMULTI (fromYAML aa) 
     1185        "SubOUTER" -> do 
     1186            let YamlSeq [aa] = e 
     1187            liftM SubOUTER (fromYAML aa) 
     1188        _ -> fail $ "unhandled tag: " ++ show t 
     1189    fromYAML _ = fail "no tag found" 
    11461190    asYAML (SubMAIN) = asYAMLcls "SubMAIN" 
    11471191    asYAML (SubLOAD) = asYAMLcls "SubLOAD" 
    … …  
    11521196 
    11531197instance YAML RegType where 
    1154     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1155             "RegInt" -> return RegInt 
    1156             "RegNum" -> return RegNum 
    1157             "RegStr" -> return RegStr 
    1158             "RegPMC" -> return RegPMC 
    1159             _ -> fail $ "unhandled tag: " ++ (show t) 
     1198    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1199        "RegInt" -> do 
     1200            return RegInt 
     1201        "RegNum" -> do 
     1202            return RegNum 
     1203        "RegStr" -> do 
     1204            return RegStr 
     1205        "RegPMC" -> do 
     1206            return RegPMC 
     1207        _ -> fail $ "unhandled tag: " ++ show t 
     1208    fromYAML _ = fail "no tag found" 
    11601209    asYAML (RegInt) = asYAMLcls "RegInt" 
    11611210    asYAML (RegNum) = asYAMLcls "RegNum" 
    … …  
    11641213 
    11651214instance YAML ObjType where 
    1166     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1167             "PerlScalar" -> return PerlScalar 
    1168             "PerlArray" -> return PerlArray 
    1169             "PerlHash" -> return PerlHash 
    1170             "PerlInt" -> return PerlInt 
    1171             "PerlPair" -> return PerlPair 
    1172             "PerlRef" -> return PerlRef 
    1173             "PerlEnv" -> return PerlEnv 
    1174             "Sub" -> return Sub 
    1175             "Closure" -> return Closure 
    1176             "Continuation" -> return Continuation 
    1177             "BareType" -> do  let YamlSeq [aa] = e 
    1178                               liftM BareType (fromYAML aa) 
    1179             _ -> fail $ "unhandled tag: " ++ (show t) 
     1215    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1216        "PerlScalar" -> do 
     1217            return PerlScalar 
     1218        "PerlArray" -> do 
     1219            return PerlArray 
     1220        "PerlHash" -> do 
     1221            return PerlHash 
     1222        "PerlInt" -> do 
     1223            return PerlInt 
     1224        "PerlPair" -> do 
     1225            return PerlPair 
     1226        "PerlRef" -> do 
     1227            return PerlRef 
     1228        "PerlEnv" -> do 
     1229            return PerlEnv 
     1230        "Sub" -> do 
     1231            return Sub 
     1232        "Closure" -> do 
     1233            return Closure 
     1234        "Continuation" -> do 
     1235            return Continuation 
     1236        "BareType" -> do 
     1237            let YamlSeq [aa] = e 
     1238            liftM BareType (fromYAML aa) 
     1239        _ -> fail $ "unhandled tag: " ++ show t 
     1240    fromYAML _ = fail "no tag found" 
    11801241    asYAML (PerlScalar) = asYAMLcls "PerlScalar" 
    11811242    asYAML (PerlArray) = asYAMLcls "PerlArray" 
    … …  
    11911252 
    11921253instance YAML Sig where 
    1193     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1194             "MkSig" -> do  let YamlMap assocs = e 
    1195                            let [aa , ab] = map snd assocs 
    1196                            liftM2 MkSig (fromYAML aa) (fromYAML ab) 
    1197             _ -> fail $ "unhandled tag: " ++ (show t) 
     1254    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1255        "MkSig" -> do 
     1256            let YamlMap assocs = e 
     1257            let [aa , ab] = map snd assocs 
     1258            liftM2 MkSig (fromYAML aa) (fromYAML ab) 
     1259        _ -> fail $ "unhandled tag: " ++ show t 
     1260    fromYAML _ = fail "no tag found" 
    11981261    asYAML (MkSig aa ab) = asYAMLmap "MkSig" 
    11991262           [("sigFlags", asYAML aa) , ("sigIdent", asYAML ab)] 
    12001263 
    12011264instance YAML ArgFlag where 
    1202     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1203             "MkArgFlatten" -> return MkArgFlatten 
    1204             "MkArgSlurpyArray" -> return MkArgSlurpyArray 
    1205             "MkArgMaybeFlatten" -> return MkArgMaybeFlatten 
    1206             "MkArgOptional" -> return MkArgOptional 
    1207             _ -> fail $ "unhandled tag: " ++ (show t) 
     1265    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1266        "MkArgFlatten" -> do 
     1267            return MkArgFlatten 
     1268        "MkArgSlurpyArray" -> do 
     1269            return MkArgSlurpyArray 
     1270        "MkArgMaybeFlatten" -> do 
     1271            return MkArgMaybeFlatten 
     1272        "MkArgOptional" -> do 
     1273            return MkArgOptional 
     1274        _ -> fail $ "unhandled tag: " ++ show t 
     1275    fromYAML _ = fail "no tag found" 
    12081276    asYAML (MkArgFlatten) = asYAMLcls "MkArgFlatten" 
    12091277    asYAML (MkArgSlurpyArray) = asYAMLcls "MkArgSlurpyArray" 

  • src/Pugs/AST/Internals.hs

    r9051 r9054  
    19511951{-* Generated by DrIFT : Look, but Don't Touch. *-} 
    19521952instance YAML VThunk where 
    1953     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1954             "MkThunk" -> do  let YamlMap assocs = e 
    1955                              let [aa , ab] = map snd assocs 
    1956                              liftM2 MkThunk (fromYAML aa) (fromYAML ab) 
    1957             _ -> fail $ "unhandled tag: " ++ (show t) 
     1953    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1954        "MkThunk" -> do 
     1955            let YamlMap assocs = e 
     1956            let [aa , ab] = map snd assocs 
     1957            liftM2 MkThunk (fromYAML aa) (fromYAML ab) 
     1958        _ -> fail $ "unhandled tag: " ++ show t 
     1959    fromYAML _ = fail "no tag found" 
    19581960    asYAML (MkThunk aa ab) = asYAMLmap "MkThunk" 
    19591961           [("thunkExp", asYAML aa) , ("thunkType", asYAML ab)] 
    19601962 
    19611963instance YAML VProcess where 
    1962     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1963             "MkProcess" -> do  let YamlSeq [aa] = e 
    1964                                liftM MkProcess (fromYAML aa) 
    1965             _ -> fail $ "unhandled tag: " ++ (show t) 
     1964    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1965        "MkProcess" -> do 
     1966            let YamlSeq [aa] = e 
     1967            liftM MkProcess (fromYAML aa) 
     1968        _ -> fail $ "unhandled tag: " ++ show t 
     1969    fromYAML _ = fail "no tag found" 
    19661970    asYAML (MkProcess aa) = asYAMLseq "MkProcess" [asYAML aa] 
    19671971 
    19681972instance YAML VRule where 
    1969     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1970             "MkRulePCRE" -> do  let YamlMap assocs = e 
    1971                                 let [aa , ab , ac , ad , ae , af] = map snd assocs 
    1972                                 liftM6 MkRulePCRE (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af) 
    1973                             where 
    1974                             liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) } 
    1975             "MkRulePGE" -> do  let YamlMap assocs = e 
    1976                                let [aa , ab , ac , ad] = map snd assocs 
    1977                                liftM4 MkRulePGE (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) 
    1978             _ -> fail $ "unhandled tag: " ++ (show t) 
     1973    fromYAML MkYamlNode{tag=Just t, el=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackFS t = case tag of 
     1974        "MkRulePCRE" -> do 
     1975            let liftM6 f m1 m2 m3 m4 m5 m6 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; return (f x1 x2 x3 x4 x5 x6) } 
     1976            let YamlMap assocs = e 
     1977            let [aa , ab , ac , ad , ae , af] = map snd assocs 
     1978            liftM6 MkRulePCRE (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af) 
     1979        "MkRulePGE" -> do 
     1980            let YamlMap assocs = e 
     1981            let [aa , ab , ac , ad] = map snd assocs 
     1982            liftM4 MkRulePGE (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) 
     1983        _ -> fail $ "unhandled tag: " ++ show t 
     1984    fromYAML _ = fail "no tag found" 
    19791985    asYAML (MkRulePCRE aa ab ac ad ae af) = asYAMLmap "MkRulePCRE" 
    19801986           [("rxRegex", asYAML aa) , ("rxGlobal", asYAML ab) , 
    … …  
    19861992 
    19871993instance YAML Val where 
    1988     fromYAML n@MkYamlNode{tag=t, el=e} = case deTag n of 
    1989             "VUndef" -> return VUndef 
    1990             "VBool" -> do  let YamlSeq [aa] = e 
    1991                            liftM VBool (fromYAML aa) 
    1992             "VInt" -> do  let YamlSeq [aa] = e 
    1993                           liftM VInt (fromYAML aa) 
    1994             "VRat" -> do  let YamlSeq [aa] = e 
    1995                           liftM VRat (fromYAML aa) 
    1996             "VNum" -> do  let YamlSeq [aa] = e 
    1997                           liftM VNum (fromYAML aa) 
    1998             "VComplex" -> do  let YamlSeq [aa] = e 
    1999                               liftM VComplex (fromYAML aa) 
    2000             "VStr" -> do  let YamlSeq [aa] = e 
    2001                           liftM VStr (fromYAML aa) 
    2002             "VList" -> do  let YamlSeq [aa] = e 
    2003                            liftM VList (fromYAML aa) 
    2004             "VType" -> do  let YamlSeq [aa] = e 
    2005                            liftM VType (fromYAML aa) 
    2006             "VJunc" -> do  let YamlSeq [aa] = e 
    2007                            liftM VJunc (fromYAML aa) 
    2008             "VError" -> do  let YamlSeq [aa , ab] = e 
    2009                             liftM2 VError (fromYAML aa) (fromYAML ab) 
    2010             "VControl"