haskell-exp-parser 0.1.1 → 0.1.2

raw patch · 4 files changed

+54/−41 lines, 4 filesdep +sybPVP ok

version bump matches the API change (PVP)

Dependencies added: syb

API changes (from Hackage documentation)

Files

• haskell-exp-parser.cabal +3/−2
• src/Language/Haskell/ParseExp.hs +4/−4
• tests/ParseExp.hs +47/−11
• tests/Splice.hs +0/−24

@@ -1,5 +1,5 @@ name:           haskell-exp-parser-version:        0.1.1+version:        0.1.2 synopsis:       Simple parser parser from Haskell to TemplateHaskell expressions description:    This package defines a simple parser for a subset of Haskell expressions and patterns to the TemplateHaskell AST.                 .@@ -53,12 +53,13 @@    hs-source-dirs: tests -  main-is: Splice.hs+  main-is: ParseExp.hs    default-language: Haskell2010    build-depends:     base,     haskell-exp-parser,+    syb,     template-haskell 

@@ -100,8 +100,8 @@           <++ list           <++ literal first           <++ tuple-  -- Must handle lists before literals, because the "['a']" is accepted as a-  -- String literal+  -- Must handle lists before literals, because "['a']" is accepted as a string+  -- literal  -- | Expression parser expression :: ReadP Exp@@ -117,13 +117,13 @@ parseExp :: String -> Either String Exp parseExp str = case [expr | (expr,"") <- readP_to_S expression str] of     [expr] -> return expr-    _ -> fail $ "parseExp: cannot parse '" ++ str ++ "'"+    _ -> Left $ "parseExp: cannot parse '" ++ str ++ "'"              ++ " (parseExp only supports a limited subset of Haskell)"  -- | Parse a Haskell pattern (the supported subset is given above) parsePat :: String -> Either String Pat parsePat str = case [pat | (pat,"") <- readP_to_S name str] of     [pat] -> return (VarP pat)-    _ -> fail $ "parsePat: cannot parse '" ++ str ++ "'"+    _ -> Left $ "parsePat: cannot parse '" ++ str ++ "'"              ++ " (parsePat only supports a limited subset of Haskell)" 

@@ -1,22 +1,58 @@-module ParseExp where--+{-# LANGUAGE TemplateHaskell #-} +import Data.Data import Data.Either+import Data.Generics.Aliases+import Data.Generics.Schemes import Language.Haskell.TH+import System.Exit  import Language.Haskell.ParseExp   -parse :: String -> ExpQ-parse str = return $ case parseExp str of-    Right exp -> exp+fixNegLits :: Exp -> Exp+fixNegLits = everywhere (mkT trans)+  where+    trans (LitE (IntegerL l))+        | l < 0 = AppE (VarE (mkName "negate")) (LitE (IntegerL (negate l)))+    trans e = e++parse :: String -> Exp+parse str = case parseExp str of+    Right exp -> fixNegLits exp     Left msg  -> error msg -exp1 = parse "\"sdf\""-exp2 = parse "sum [1,2,3]"-exp3 = parse "min (max (negate (-34)) 888) (signum (-45))"-exp4 = parse "  min   (  max   (  negate   (  -  34  )  )   888  )   (   signum    (  - 45   )   )  "-exp5 = parse "[(1,'a'),(2,'b'),(3,'c')]"+dequalify :: Exp -> Exp+dequalify = everywhere (mkT trans)+  where+    trans (VarE v) = VarE $ mkName $ nameBase v+    trans e        = e++addWhite :: Char -> String+addWhite c+    | c `elem` cs = "   " ++ [c] ++ "   "+    | otherwise   = [c]+  where+    cs = ['(', ')', ',', '-', ' ']++test1 = ("\"sdf\"",                                      [| "sdf" |])+test2 = ("sum [1,2,3]",                                  [| sum [1,2,3] |])+test3 = ("min (max (negate (-34)) 888) (signum (-45))",  [| min (max (negate (-34)) 888) (signum (-45)) |])+test4 = ("[(1,'a',\"a\"),(2,'b',\"b\"),(-3,'c',\"c\")]", [| [(1,'a',"a"),(2,'b',"b"),(-3,'c',"c")] |])++tests = [test1,test2,test3,test4]++main = do+    es1 <- mapM (fmap dequalify . runQ . snd) tests+    let es2  = map (parse . fst) tests+        es3  = map (parse . concatMap addWhite . fst) tests+        oks2 = map (uncurry (==)) $ zip es1 es2+        oks3 = map (uncurry (==)) $ zip es1 es3+        failedTests = [i | (i,(ok2,ok3)) <- zip [1..] (zip oks2 oks3), not (ok2&&ok3)]+    if and oks2 && and oks3+    then putStrLn "All tests passed"+    else do+      putStrLn $ "Tests " ++ show failedTests ++ " failed"+      exitFailure 

@@ -1,24 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--import System.Exit--import ParseExp----tests =-    [ (show ($exp1), show "sdf")-    , (show ($exp2), show (sum [1,2,3]))-    , (show ($exp3), show (min (max (negate (-34)) 888) (signum (-45))))-    , (show ($exp4), show (  min   (  max   (  negate   (  -  34  )  )   888  )   (   signum    (  - 45   )   )  ))-    , (show ($exp5), show ([(1,'a'),(2,'b'),(3,'c')]))-    ]--main = if and oks-    then putStrLn "All tests passed"-    else do-      putStrLn $ "Tests " ++ show [i | (i,False) <- zip [1..] oks] ++ " failed"-      exitFailure-  where-    oks = map (uncurry (==)) tests-