Improve mkName, so that it correctly parses the name ^..
authorSimon Peyton Jones <simonpj@microsoft.com>
Sat, 28 Dec 2013 11:05:31 +0000 (11:05 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 30 Dec 2013 12:14:39 +0000 (12:14 +0000)
This fixes Trac #8633; thanks to aavogt for a first draft.

Language/Haskell/TH/Syntax.hs

index f3868d1..3606f9d 100644 (file)
@@ -24,7 +24,7 @@ import Data.IORef
 import System.IO.Unsafe        ( unsafePerformIO )
 import Control.Monad (liftM)
 import System.IO       ( hPutStrLn, stderr )
-import Data.Char        ( isAlpha )
+import Data.Char        ( isAlpha, isAlphaNum, isUpper )
 import Data.Word        ( Word8 )
 
 -----------------------------------------------------
@@ -758,17 +758,33 @@ mkName str
   = split [] (reverse str)
   where
     split occ []        = Name (mkOccName occ) NameS
-    split occ ('.':rev)        | not (null occ),
-                         not (null rev), head rev /= '.'
+    split occ ('.':rev)        | not (null occ)
+                       , is_rev_mod_name rev
                        = Name (mkOccName occ) (NameQ (mkModName (reverse rev)))
        -- The 'not (null occ)' guard ensures that
        --      mkName "&." = Name "&." NameS
-       -- The 'rev' guards ensure that
+       -- The 'is_rev_mod' guards ensure that
        --      mkName ".&" = Name ".&" NameS
+       --      mkName "^.." = Name "^.." NameS      -- Trac #8633
        --      mkName "Data.Bits..&" = Name ".&" (NameQ "Data.Bits")
        -- This rather bizarre case actually happened; (.&.) is in Data.Bits
     split occ (c:rev)   = split (c:occ) rev
 
+    -- Recognises a reversed module name xA.yB.C, 
+    -- with at least one component, 
+    -- and each component looks like a module name
+    --   (i.e. non-empty, starts with capital, all alpha)
+    is_rev_mod_name rev_mod_str
+      | (compt, rest) <- break (== '.') rev_mod_str
+      , not (null compt), isUpper (last compt), all is_mod_char compt
+      = case rest of
+          []             -> True
+          (_dot : rest') -> is_rev_mod_name rest'
+      | otherwise
+      = False
+
+    is_mod_char c = isAlphaNum c || c == '_' || c == '\''
+
 -- | Only used internally
 mkNameU :: String -> Uniq -> Name
 mkNameU s (I# u) = Name (mkOccName s) (NameU u)