mirror of
https://github.com/google/ghc-source-gen.git
synced 2024-09-11 22:07:09 +03:00
Fix edge cases parsing qualified operators. (#32)
Also add some tests, and expose more functionality to work with names.
This commit is contained in:
parent
05937090bd
commit
18d1ca0338
12
package.yaml
12
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
|
||||
|
@ -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
|
||||
|
@ -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)`
|
||||
|
@ -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
|
||||
|
68
tests/name_test.hs
Normal file
68
tests/name_test.hs
Normal file
@ -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
|
||||
]
|
@ -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" :~
|
||||
|
Loading…
Reference in New Issue
Block a user