Network/HTTP/Lucu/Implant/Rewrite.hs

   1 {-# LANGUAGE
   2     UnicodeSyntax
   3   #-}
   4 module Network.HTTP.Lucu.Implant.Rewrite
   5     ( ModMap
   6     , rewriteNames
   7     )
   8     where
   9 import Control.Applicative
  10 import Control.Monad.State
  11 import Data.Data
  12 import Data.Generics.Aliases
  13 import Data.Generics.Schemes
  14 import Data.Map (Map)
  15 import qualified Data.Map as M
  16 import Data.Monoid.Unicode
  17 import Language.Haskell.TH.Syntax
  18 import Prelude.Unicode
  19
  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)
  23
  24 rewriteNames ∷ Data d ⇒ d → (d, ModMap)
  25 rewriteNames
  26     = flip runState (∅) ∘ gmapM (everywhereM (mkM rewriteName))
  27
  28 rewriteName ∷ (Functor m, Monad m)
  29             ⇒ Name
  30             → StateT ModMap m Name
  31 rewriteName (Name o fl) = Name o <$> rewriteNameFlavour fl
  32
  33 rewriteNameFlavour ∷ (Functor m, Monad m)
  34                    ⇒ NameFlavour
  35                    → StateT ModMap m NameFlavour
  36 rewriteNameFlavour fl
  37     = case getModName fl of
  38         Nothing → return fl
  39         Just m  → do let r = M.lookup m modules
  40                      insertIntoModMap m r
  41                      return $ setModName r fl
  42
  43 insertIntoModMap ∷ Monad m
  44                  ⇒ ModName
  45                  → Maybe RewriteTo
  46                  → StateT ModMap 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
  52
  53 getModName ∷ NameFlavour → Maybe ModName
  54 getModName (NameQ     m) = Just m
  55 getModName (NameG _ _ m) = Just m
  56 getModName _             = Nothing
  57
  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"
  66
  67 modules ∷ Map ModName RewriteTo
  68 modules
  69     = M.fromList
  70       [ ( mkModName "Codec.Compression.GZip"
  71         , Qual Nothing $ mkModName "G"
  72         )
  73       , ( mkModName "Data.Ascii"
  74         , Qual Nothing $ mkModName "A"
  75         )
  76       , ( mkModName "Data.ByteString.Char8"
  77         , Qual Nothing $ mkModName "B"
  78         )
  79       , ( mkModName "Data.ByteString.Lazy.Internal"
  80         , Qual Nothing $ mkModName "L"
  81         )
  82       , ( mkModName "Data.ByteString.Unsafe"
  83         , Qual Nothing $ mkModName "B"
  84         )
  85       , ( mkModName "Data.Map"
  86         , Qual Nothing $ mkModName "M"
  87         )
  88       , ( mkModName "Data.Maybe"
  89         , UnQual Nothing
  90         )
  91       , ( mkModName "Data.Text"
  92         , Qual Nothing $ mkModName "T"
  93         )
  94       , ( mkModName "Data.Time.Calendar.Days"
  95         , UnQual $ Just $ mkModName "Data.Time"
  96         )
  97       , ( mkModName "Data.Time.Clock.Scale"
  98         , UnQual $ Just $ mkModName "Data.Time"
  99         )
 100       , ( mkModName "Data.Time.Clock.UTC"
 101         , UnQual $ Just $ mkModName "Data.Time"
 102         )
 103       , ( mkModName "GHC.Base"
 104         , UnQual Nothing
 105         )
 106       , ( mkModName "GHC.Bool"
 107         , UnQual Nothing
 108         )
 109       , ( mkModName "GHC.IO"
 110         -- for 'unsafePerformIO', but rather problematic...
 111         , UnQual $ Just $ mkModName "System.IO.Unsafe"
 112         )
 113       , ( mkModName "GHC.Real"
 114         -- for '%', but rather problematic...
 115         , UnQual $ Just $ mkModName "Data.Ratio"
 116         )
 117       , ( mkModName "Network.HTTP.Lucu.ETag"
 118         , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
 119         )
 120       , ( mkModName "Network.HTTP.Lucu.MIMEType"
 121         , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
 122         )
 123       , ( mkModName "Network.HTTP.Lucu.Resource"
 124         , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
 125         )
 126       , ( mkModName "Network.HTTP.Lucu.Resource.Internal"
 127         , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
 128         )
 129       ]