{-# LANGUAGE
    TemplateHaskell
  , UnicodeSyntax
  #-}
-- |FIXME: doc
module Data.Collections.Newtype.TH
    ( derive
    )
    where
import Control.Applicative hiding (empty)
import Control.Monad.Unicode
import Data.Collections
import Data.Collections.BaseInstances ()
import Data.Maybe
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
import Prelude hiding (concat, exp)
import Prelude.Unicode

type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec

-- |FIXME: doc
derive ∷ Q [Dec] → Q [Dec]
derive = (concat <$>) ∘ (mapM go =≪)
    where
      go ∷ Dec → Q [Dec]
      go (InstanceD c ty _) = deriveInstance c ty
      go _ = fail "derive: usage: derive [d| instance A; instance B; ... |]"

deriveInstance ∷ Cxt → Type → Q [Dec]
deriveInstance c ty
    = do (wrapperTy, deriver) ← inspectInstance ty
         (wrap     , wrapD  ) ← genWrap   wrapperTy
         (unwrap   , unwrapD) ← genUnwrap wrapperTy
         (: wrapD ⧺ unwrapD) <$> deriver (return c     )
                                         (return ty    )
                                         (return wrap  )
                                         (return unwrap)

inspectInstance ∷ Type → Q (Type, Deriver)
inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
    | classTy ≡ ''Unfoldable
        = return (wrapperTy, deriveUnfoldable)
inspectInstance ty
    = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty

genWrap ∷ Type → Q (Exp, [Dec])
genWrap wrapperTy
    = do name      ← newName "wrap"
         (con, ty) ← wrapperConTy wrapperTy
         decls     ← sequence
                     [ sigD name [t| $(return ty) → $(return wrapperTy) |]
                     , pragInlD name (inlineSpecNoPhase True True)
                     , funD name [clause [] (normalB (conE con)) []]
                     ]
         return (VarE name, decls)

genUnwrap ∷ Type → Q (Exp, [Dec])
genUnwrap wrapperTy
    = do name      ← newName "unwrap"
         i         ← newName "i"
         (con, ty) ← wrapperConTy wrapperTy
         decls     ← sequence
                     [ sigD name [t| $(return wrapperTy) → $(return ty) |]
                     , pragInlD name (inlineSpecNoPhase True True)
                     , funD name [clause [conP con [varP i]] (normalB (varE i)) []]
                     ]
         return (VarE name, decls)

wrapperConTy ∷ Type → Q (Name, Type)
wrapperConTy = (conTy =≪) ∘ tyInfo
    where
      tyInfo ∷ Type → Q Info
      tyInfo (ConT name) = reify name
      tyInfo (AppT ty _) = tyInfo ty
      tyInfo (SigT ty _) = tyInfo ty
      tyInfo ty
          = fail $ "wrapperConTy: unsupported type: " ⧺ pprint ty

      conTy ∷ Info → Q (Name, Type)
      conTy (TyConI (NewtypeD [] _ [] (NormalC con [(NotStrict, ty)]) []))
          = return (con, ty)
      conTy info
          = fail $ "wrapperConTy: unsupported type: " ⧺ pprint info

methodNames ∷ Name → Q [Name]
methodNames = (names =≪) ∘ reify
    where
      names ∷ Info → Q [Name]
      names (ClassI (ClassD _ _ _ _ decls) _)
              = return ∘ catMaybes $ map name decls
      names c = fail $ "methodNames: not a class: " ⧺ pprint c

      name ∷ Dec → Maybe Name
      name (SigD n _) = Just n
      name _          = Nothing

pointfreeMethod ∷ (Name → Q Exp) → Name → Q Dec
pointfreeMethod f name
    = funD name [clause [] (normalB (f name)) []]

deriveUnfoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
deriveUnfoldable c ty wrap unwrap
    = do names ← methodNames ''Unfoldable
         instanceD c ty $ pointfreeMethod exp <$> names
    where
      exp ∷ Name → Q Exp
      exp name
          | name ≡ 'insert
              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insert |]
          | name ≡ 'empty
              = [| $wrap empty |]
          | name ≡ 'singleton
              = [| $wrap ∘ singleton |]
          | name ≡ 'insertMany
              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertMany |]
          | name ≡ 'insertManySorted
              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertManySorted |]
          | otherwise
              = fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name

{-
instance Unfoldable MIMEParams (CIAscii, Text) where
    {-# INLINE insert #-}
    insert p (MIMEParams m)
        = MIMEParams $ insert p m
    {-# INLINE empty #-}
    empty
        = MIMEParams empty
    {-# INLINE singleton #-}
    singleton p
        = MIMEParams $ singleton p
    {-# INLINE insertMany #-}
    insertMany f (MIMEParams m)
        = MIMEParams $ insertMany f m
    {-# INLINE insertManySorted #-}
    insertManySorted f (MIMEParams m)
        = MIMEParams $ insertManySorted f m
-}