ImplantFile started working again.

[Lucu.git] / Network / HTTP / Lucu / Implant / Rewrite.hs

diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs
new file mode 100644 (file)
index 0000000..37fbfbb
--- /dev/null
+++ b/Network/HTTP/Lucu/Implant/Rewrite.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}
+module Network.HTTP.Lucu.Implant.Rewrite
+    ( ModMap
+    , rewriteNames
+    )
+    where
+import Control.Applicative
+import Control.Monad.State
+import Data.Data
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Monoid.Unicode
+import Language.Haskell.TH.Syntax
+import Prelude.Unicode
+
+-- FIXME: Document at least these data types.
+type ModMap    = Map ModName (Maybe ModName)
+data RewriteTo = Qual (Maybe ModName) ModName | UnQual (Maybe ModName)
+
+rewriteNames ∷ Data d ⇒ d → (d, ModMap)
+rewriteNames
+    = flip runState (∅) ∘ gmapM (everywhereM (mkM rewriteName))
+
+rewriteName ∷ (Functor m, Monad m)
+            ⇒ Name
+            → StateT ModMap m Name
+rewriteName (Name o fl) = Name o <$> rewriteNameFlavour fl
+
+rewriteNameFlavour ∷ (Functor m, Monad m)
+                   ⇒ NameFlavour
+                   → StateT ModMap m NameFlavour
+rewriteNameFlavour fl
+    = case getModName fl of
+        Nothing → return fl
+        Just m  → do let r = M.lookup m modules
+                     insertIntoModMap m r
+                     return $ setModName r fl
+
+insertIntoModMap ∷ Monad m
+                 ⇒ ModName
+                 → Maybe RewriteTo
+                 → StateT ModMap m ()
+insertIntoModMap _ (Just (Qual   (Just m) m')) = modify $ M.insert m (Just m')
+insertIntoModMap m (Just (Qual   Nothing  m')) = modify $ M.insert m (Just m')
+insertIntoModMap _ (Just (UnQual (Just m)   )) = modify $ M.insert m Nothing
+insertIntoModMap _ (Just (UnQual Nothing    )) = return ()
+insertIntoModMap m Nothing                     = modify $ M.insert m Nothing
+
+getModName ∷ NameFlavour → Maybe ModName
+getModName (NameQ     m) = Just m
+getModName (NameG _ _ m) = Just m
+getModName _             = Nothing
+
+setModName ∷ Maybe RewriteTo → NameFlavour → NameFlavour
+setModName (Just (Qual _ m)) (NameQ _    ) = NameQ m
+setModName (Just (Qual _ m)) (NameG _ _ _) = NameQ m
+setModName (Just (UnQual _)) (NameQ _    ) = NameS
+setModName (Just (UnQual _)) (NameG _ _ _) = NameS
+setModName Nothing           (NameQ _    ) = NameS
+setModName Nothing           (NameG _ _ _) = NameS
+setModName _ _ = error "setModName: internal error"
+
+modules ∷ Map ModName RewriteTo
+modules
+    = M.fromList
+      [ ( mkModName "Codec.Compression.GZip"
+        , Qual Nothing $ mkModName "G"
+        )
+      , ( mkModName "Data.Ascii"
+        , Qual Nothing $ mkModName "A"
+        )
+      , ( mkModName "Data.ByteString.Char8"
+        , Qual Nothing $ mkModName "B"
+        )
+      , ( mkModName "Data.ByteString.Lazy.Internal"
+        , Qual Nothing $ mkModName "L"
+        )
+      , ( mkModName "Data.ByteString.Unsafe"
+        , Qual Nothing $ mkModName "B"
+        )
+      , ( mkModName "Data.Map"
+        , Qual Nothing $ mkModName "M"
+        )
+      , ( mkModName "Data.Maybe"
+        , UnQual Nothing
+        )
+      , ( mkModName "Data.Text"
+        , Qual Nothing $ mkModName "T"
+        )
+      , ( mkModName "Data.Time.Calendar.Days"
+        , UnQual $ Just $ mkModName "Data.Time"
+        )
+      , ( mkModName "Data.Time.Clock.Scale"
+        , UnQual $ Just $ mkModName "Data.Time"
+        )
+      , ( mkModName "Data.Time.Clock.UTC"
+        , UnQual $ Just $ mkModName "Data.Time"
+        )
+      , ( mkModName "GHC.Base"
+        , UnQual Nothing
+        )
+      , ( mkModName "GHC.Bool"
+        , UnQual Nothing
+        )
+      , ( mkModName "GHC.IO"
+        -- for 'unsafePerformIO', but rather problematic...
+        , UnQual $ Just $ mkModName "System.IO.Unsafe"
+        )
+      , ( mkModName "GHC.Real"
+        -- for '%', but rather problematic...
+        , UnQual $ Just $ mkModName "Data.Ratio"
+        )
+      , ( mkModName "Network.HTTP.Lucu.ETag"
+        , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
+        )
+      , ( mkModName "Network.HTTP.Lucu.MIMEType"
+        , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
+        )
+      , ( mkModName "Network.HTTP.Lucu.Resource"
+        , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
+        )
+      , ( mkModName "Network.HTTP.Lucu.Resource.Internal"
+        , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
+        )
+      ]