{-# 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"
        )
      ]