4 module Network.HTTP.Lucu.Implant.Rewrite
9 import Control.Applicative
10 import Control.Monad.State
12 import Data.Generics.Aliases
13 import Data.Generics.Schemes
15 import qualified Data.Map as M
16 import Data.Monoid.Unicode
17 import Language.Haskell.TH.Syntax
18 import Prelude.Unicode
20 -- FIXME: Document at least these data types.
21 type ModMap = Map ModName (Maybe ModName)
22 data RewriteTo = Qual (Maybe ModName) ModName | UnQual (Maybe ModName)
24 rewriteNames ∷ Data d ⇒ d → (d, ModMap)
26 = flip runState (∅) ∘ gmapM (everywhereM (mkM rewriteName))
28 rewriteName ∷ (Functor m, Monad m)
30 → StateT ModMap m Name
31 rewriteName (Name o fl) = Name o <$> rewriteNameFlavour fl
33 rewriteNameFlavour ∷ (Functor m, Monad m)
35 → StateT ModMap m NameFlavour
37 = case getModName fl of
39 Just m → do let r = M.lookup m modules
41 return $ setModName r fl
43 insertIntoModMap ∷ Monad m
47 insertIntoModMap _ (Just (Qual (Just m) m')) = modify $ M.insert m (Just m')
48 insertIntoModMap m (Just (Qual Nothing m')) = modify $ M.insert m (Just m')
49 insertIntoModMap _ (Just (UnQual (Just m) )) = modify $ M.insert m Nothing
50 insertIntoModMap _ (Just (UnQual Nothing )) = return ()
51 insertIntoModMap m Nothing = modify $ M.insert m Nothing
53 getModName ∷ NameFlavour → Maybe ModName
54 getModName (NameQ m) = Just m
55 getModName (NameG _ _ m) = Just m
56 getModName _ = Nothing
58 setModName ∷ Maybe RewriteTo → NameFlavour → NameFlavour
59 setModName (Just (Qual _ m)) (NameQ _ ) = NameQ m
60 setModName (Just (Qual _ m)) (NameG _ _ _) = NameQ m
61 setModName (Just (UnQual _)) (NameQ _ ) = NameS
62 setModName (Just (UnQual _)) (NameG _ _ _) = NameS
63 setModName Nothing (NameQ _ ) = NameS
64 setModName Nothing (NameG _ _ _) = NameS
65 setModName _ _ = error "setModName: internal error"
67 modules ∷ Map ModName RewriteTo
70 [ ( mkModName "Codec.Compression.GZip"
71 , Qual Nothing $ mkModName "G"
73 , ( mkModName "Data.Ascii"
74 , Qual Nothing $ mkModName "A"
76 , ( mkModName "Data.ByteString.Char8"
77 , Qual Nothing $ mkModName "B"
79 , ( mkModName "Data.ByteString.Lazy.Internal"
80 , Qual Nothing $ mkModName "L"
82 , ( mkModName "Data.ByteString.Unsafe"
83 , Qual Nothing $ mkModName "B"
85 , ( mkModName "Data.Map"
86 , Qual Nothing $ mkModName "M"
88 , ( mkModName "Data.Maybe"
91 , ( mkModName "Data.Text"
92 , Qual Nothing $ mkModName "T"
94 , ( mkModName "Data.Time.Calendar.Days"
95 , UnQual $ Just $ mkModName "Data.Time"
97 , ( mkModName "Data.Time.Clock.Scale"
98 , UnQual $ Just $ mkModName "Data.Time"
100 , ( mkModName "Data.Time.Clock.UTC"
101 , UnQual $ Just $ mkModName "Data.Time"
103 , ( mkModName "GHC.Base"
106 , ( mkModName "GHC.Bool"
109 , ( mkModName "GHC.IO"
110 -- for 'unsafePerformIO', but rather problematic...
111 , UnQual $ Just $ mkModName "System.IO.Unsafe"
113 , ( mkModName "GHC.Real"
114 -- for '%', but rather problematic...
115 , UnQual $ Just $ mkModName "Data.Ratio"
117 , ( mkModName "Network.HTTP.Lucu.ETag"
118 , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
120 , ( mkModName "Network.HTTP.Lucu.MIMEType"
121 , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
123 , ( mkModName "Network.HTTP.Lucu.Resource"
124 , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
126 , ( mkModName "Network.HTTP.Lucu.Resource.Internal"
127 , UnQual $ Just $ mkModName "Network.HTTP.Lucu"