Fix edge cases parsing qualified operators. (#32)

Also add some tests, and expose more functionality to work with names.

package.yaml

@@ -54,6 +54,8 @@ tests:
     dependencies:
     - ghc-source-gen
     - ghc-paths == 0.1.*
+    - tasty
+    - tasty-hunit
 
   # TODO: Fill out this test, and use it to replace pprint_examples.
   pprint_test:
@@ -64,3 +66,13 @@ tests:
     - ghc-paths == 0.1.*
     - tasty
     - tasty-hunit
+
+  name_test:
+    main: name_test.hs
+    source-dirs: tests
+    dependencies:
+    - ghc-source-gen
+    - QuickCheck
+    - tasty
+    - tasty-hunit
+    - tasty-quickcheck

src/GHC/SourceGen/Name.hs

@@ -11,12 +11,18 @@
 -- we recommend enabling the @OverloadedStrings@ extension.
 module GHC.SourceGen.Name
     ( RdrNameStr(..)
-    , OccNameStr
+    , RawNameSpace(..)
+    , rdrNameStrToString
+    , OccNameStr(..)
+    , occNameStrToString
     , ModuleNameStr(..)
+    , moduleNameStrToString
     , qual
     , unqual
     ) where
 
+import FastString (unpackFS)
+import Module (moduleNameString)
 import GHC.SourceGen.Name.Internal
 
 unqual :: OccNameStr -> RdrNameStr
@@ -24,3 +30,14 @@ unqual = UnqualStr
 
 qual :: ModuleNameStr -> OccNameStr -> RdrNameStr
 qual = QualStr
+
+moduleNameStrToString :: ModuleNameStr -> String
+moduleNameStrToString = moduleNameString . unModuleNameStr
+
+occNameStrToString :: OccNameStr -> String
+occNameStrToString (OccNameStr _ s) = unpackFS s
+
+rdrNameStrToString :: RdrNameStr -> String
+rdrNameStrToString (UnqualStr o) = occNameStrToString o
+rdrNameStrToString (QualStr m o) =
+    moduleNameStrToString m ++ '.' : occNameStrToString o

src/GHC/SourceGen/Name/Internal.hs

@@ -6,10 +6,11 @@
 
 module GHC.SourceGen.Name.Internal where
 
-import Data.Char (isUpper)
+import Data.Char (isAlphaNum, isUpper)
+import Data.List (intercalate)
 import Data.String (IsString(..))
 import FastString (FastString, fsLit)
-import Module (mkModuleNameFS, ModuleName)
+import Module (mkModuleNameFS, ModuleName, moduleNameString)
 import RdrName
 import OccName
 import SrcLoc (Located)
@@ -28,10 +29,10 @@ import GHC.SourceGen.Syntax.Internal (builtLoc)
 -- makes it easier to implement an 'IsString' instance without the context
 -- where a name would be used.)
 data OccNameStr = OccNameStr !RawNameSpace !FastString
-    deriving (Eq, Ord)
+    deriving (Show, Eq, Ord)
 
 data RawNameSpace = Constructor | Value
-    deriving (Eq, Ord)
+    deriving (Show, Eq, Ord)
 
 -- TODO: symbols
 rawNameSpace :: String -> RawNameSpace
@@ -52,6 +53,9 @@ typeOccName (OccNameStr Value s) = mkTyVarOccFS s
 newtype ModuleNameStr = ModuleNameStr { unModuleNameStr :: ModuleName }
     deriving (Eq, Ord)
 
+instance Show ModuleNameStr where
+    show = show . moduleNameString . unModuleNameStr
+
 instance IsString ModuleNameStr where
     fromString = ModuleNameStr . mkModuleNameFS . fsLit
 
@@ -73,7 +77,7 @@ instance IsString ModuleNameStr where
 -- > fromString "A.B.c" == QualStr (fromString "A.B") (fromString "c")
 -- > fromString "c" == UnqualStr (fromString "c")
 data RdrNameStr = UnqualStr OccNameStr | QualStr ModuleNameStr OccNameStr
-    deriving (Eq, Ord)
+    deriving (Show, Eq, Ord)
 
 -- GHC always wraps RdrName in a Located.  (Usually: 'Located (IdP pass)')
 -- So for convenience, these functions return a Located-wrapped value.
@@ -86,10 +90,22 @@ typeRdrName (QualStr (ModuleNameStr m) r) = builtLoc $ Qual m $ typeOccName r
 -- TODO: operators
 instance IsString RdrNameStr where
     -- Split "Foo.Bar.baz" into ("Foo.Bar", "baz")
-    fromString f = case span (/= '.') (reverse f) of
-        (f', '.':f'') ->
-            QualStr (fromString $ reverse f'') (fromString $ reverse f')
-        _ -> UnqualStr (fromString f)
+    fromString s = case collectModuleName s of
+        (m, n)
+            | null m -> UnqualStr (fromString n)
+            | otherwise -> QualStr (fromString $ intercalate "." m) (fromString n)
+
+collectModuleName :: String -> ([String],String)
+collectModuleName s = case span isVarChar s of
+    ("", n) -> ([], n)  -- Symbol
+    (n, "") -> ([], n)  -- Identifier
+    (m, '.' : s') -> case collectModuleName s' of
+                            (m', s'') -> (m : m', s'')
+    _ -> error $ "Unable to parse RdrNameStr: " ++ show s
+  where
+    isVarChar '\'' = True
+    isVarChar '_' = True
+    isVarChar c = isAlphaNum c
 
 -- | A RdrName suitable for an import or export list.
 -- E.g.: `import F(a, B)`

stack-8.8.yaml

@@ -46,6 +46,10 @@ extra-deps:
 - wcwidth-0.0.2@sha256:77531eb6683c505c22ab3fa11bbc43d3ce1e7dac21401d4d5a19677d348bb5f3,1998
 - tasty-1.2.3@sha256:bba67074e5326d57e8f53fc1dabcb6841daa4dc51b053506eb7f40a6f49a0497,2517
 - tasty-hunit-0.10.0.2@sha256:8e8bd5807cec650f5aebc5ada07b57620c863e69145e65249651c1b48d97bd70,1515
+- tasty-quickcheck-0.10.1@sha256:9a6cbb4767c7b339a399e3992afb89f112a92ffdc8101e318ba1a3bb05bc48d7,1555
+- QuickCheck-2.13.2@sha256:ad4e5adbd1c9dc0221a44307b992cb040c515f31095182e47aa7e974bc461df1,6952
+- random-1.1@sha256:7b67624fd76ddf97c206de0801dc7e888097e9d572974be9b9ea6551d76965df,1777
+- splitmix-0.0.2@sha256:e1c4d1202757d63cd4b4498d5fa600a792f2a315d2fdc6cf772f4679113c1819,3298
 
 ghc-options:
   "$locals": -Wall -Werror

tests/name_test.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main (main) where
+
+import GHC.SourceGen.Name
+
+import Data.List (intercalate)
+import Data.String (fromString)
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Test.Tasty.HUnit
+
+main :: IO ()
+main = defaultMain $ testGroup "Tests" [testOccName, testRdrName]
+
+testRdrName, testOccName :: TestTree
+testRdrName = testGroup "RdrName"
+    [ testCase "unqual ident" $ do
+        UnqualStr "abc" @=? "abc"
+    , testCase "qual ident" $ do
+        QualStr "Foo" "abc" @=? "Foo.abc"
+    , testCase "hierarchical qual ident" $ do
+        QualStr "Foo.Bar" "abc" @=? "Foo.Bar.abc"
+    , testCase "unqual op" $ do
+        UnqualStr "+-+" @=? "+-+"
+    , testCase "qual op" $ do
+        QualStr "Foo" "+-+" @=? "Foo.+-+"
+    , testCase "hierarchical qual op" $ do
+        QualStr "Foo.Bar" "+-+" @=? "Foo.Bar.+-+"
+    , testProperty "round tip" $ forAll genRdrName $ \r ->
+        fromString (rdrNameStrToString r) === r
+    ]
+
+testOccName = testGroup "OccName"
+    [ testProperty "constructor" $ forAll genUpperName $ \n ->
+        fromString n === OccNameStr Constructor (fromString n)
+    , testProperty "value" $ forAll genLowerName $ \n ->
+        fromString n === OccNameStr Value (fromString n)
+    , testProperty "punctuation" $ forAll genOp $ \n ->
+        fromString n === OccNameStr Value (fromString n)
+    , testProperty "round-trip" $ forAll genOccName $ \o ->
+        fromString (occNameStrToString o) === o
+    ]
+
+genUpperName, genLowerName, genOp :: Gen String
+genUpperName = (:) <$> genUpper <*> listOf genRest
+genLowerName = (:) <$> genLower <*> listOf genRest
+genOp = listOf1 $ genPunctuation
+
+genUpper, genLower, genRest, genPunctuation :: Gen Char
+genUpper = elements "ABC"
+genLower = elements "ab1_'"
+genRest = elements "Ab1_'"
+genPunctuation = elements ".-+"
+
+genOccName :: Gen OccNameStr
+genOccName = oneof
+    [ OccNameStr Constructor . fromString <$> genUpperName
+    , OccNameStr Value . fromString <$> oneof [genLowerName, genOp]
+    ]
+
+genModuleName :: Gen ModuleNameStr
+genModuleName = fromString . intercalate "." <$> listOf1 genUpperName
+
+genRdrName :: Gen RdrNameStr
+genRdrName = oneof
+    [ QualStr <$> genModuleName <*> genOccName
+    , UnqualStr <$> genOccName
+    ]

tests/pprint_test.hs

@@ -94,6 +94,7 @@ exprsTest dflags = testGroup "Expr"
     , test "app"
         [ "A x" :~ var "A" @@ var "x"
         , "(+) x" :~ var "+" @@ var "x"
+        , "(Prelude.+) x" :~ var "Prelude.+" @@ var "x"
         , "A (B x)" :~ var "A" @@ par (var "B" @@ var "x")
         , "A x (B y z)" :~ var "A" @@ var "x" @@ (var "B" @@ var "y" @@ var "z")
         , "A w (B x y) Z"
@@ -107,12 +108,17 @@ exprsTest dflags = testGroup "Expr"
         ]
     , test "op"
         [ "x + y" :~ op (var "x") "+" (var "y")
+        , "x Prelude.+ y" :~ op (var "x") "Prelude.+" (var "y")
         , "x `add` y" :~ op (var "x") "add" (var "y")
         , "x * (y + z)" :~ op (var "x") "*" (op (var "y") "+" (var "z"))
         , "x `mult` (y `add` z)" :~ op (var "x") "mult" (op (var "y") "add" (var "z"))
         , "A x * (B y + C z)" :~ op (var "A" @@ var "x") "*"
                                     (op (var "B" @@ var "y") "+" (var "C" @@ var "z"))
         ]
+    , test "period-op"
+        [ "(Prelude..) x" :~ var "Prelude.." @@ var "x"
+        , "x Prelude.. y" :~ op (var "x") "Prelude.." (var "y")
+        ]
     , test ":@@:"
         -- TODO: GHC puts extra space here.
         [ "  e :: t" :~ var "e" @::@ var "t" ]
@@ -183,6 +189,7 @@ declsTest dflags = testGroup "Decls"
                 [ var "test" `guard` int 1
                 , var "otherwise" `guard` int 2
                 ]
+        , "x = (+)" :~ valBind "x" $ var "+"
         ]
     , test "funBind"
         [ "not True = False\nnot False = True" :~