{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

-- | This module contains a Template Haskell helper to produce a new datatype
-- with modified field names. The initial use case is to allow for easier record
-- construction with Lumi's databases models, which have record fields prefixed
-- with an `_`, and the Stats records, which do not have this underscore. The
-- use of a naming scheme convention allows one to write the conversion function
-- as:
--
-- > convertData (Entity id Old.Record{..}) RecordStats{..} =
-- >   Entity (coerce id) New.Record
-- >     { ..
-- >     -- Some fields need massaging
-- >     , _recordClientId = coerce _recordClientId
-- >     -- Some fields don't need massaging, but need to be explicitly labeled.
-- >     , _recordStatsFoo = recordStatsFoo
-- >     }
--
-- where each field in @RecordStats@ must be repeated. This can be accomplished
-- fairly easily with a vim macro, but it's more fun and less error prone to
-- write Haskell.
--
-- With this module, we can instead write:
--
-- > wrangle ''RecordStats with { fieldLabelModifier = ('_' :) }
--
-- which generates a new type @RecordStats'@ with the same fields, but modified
-- to have different field labels. It also creates a conversion function. Now,
-- we can write (with @ViewPatterns@):
--
-- > convertData
-- >   (Entity id Old.Record{..})
-- >   (wrangleRecordStatsToRecordStats' -> RecordStats'{..})
-- >  =
-- >   Entity (coerce id) New.Record
-- >     { ..
-- >     , _recordClientId = coerce _recordClientId
-- >     }
--
-- Now, the only terms that need to be mentioned are the ones that cause
-- a compile-time error due to the types not matching up.
module RecordWrangler
    ( -- * The Wranglin One
      wrangle
      -- * The Options For Wranglin
    , WrangleOpts
    , defWrangleOpts
    , fieldLabelModifier
    , constructorModifier
    , typeNameModifier
    ) where

import           Data.Traversable
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote

-- | The options for wrangling records. The constructor is hidden so that
-- we can add new features and powers without breaking your code!
data WrangleOpts = WrangleOpts
    { fieldLabelModifier :: String -> String
    -- ^ This function will be applied to every field label in the provided
    -- record.
    --
    -- @since 0.1.0.0
    , typeNameModifier :: String -> String
    -- ^ This function will be applied to the type name.
    --
    -- @since 0.1.0.0
    , constructorModifier :: String -> String
    -- ^ This function will be applied to the constructor name.
    --
    -- @since 0.1.0.0
    }

-- | This is the default set of 'WrangleOpts'. It affixes a @'@ character to
-- the end of the fields, type, and constructor. If you want different behavior,
-- then you will want to alter the fields:
--
-- @
-- wrangle ''Record defWrangleOpts { fieldLabelModifier = ('_' :) }
-- @
--
-- @since 0.1.0.0
defWrangleOpts :: WrangleOpts
defWrangleOpts = WrangleOpts
    { fieldLabelModifier = (++ "'")
    , typeNameModifier = (++ "'")
    , constructorModifier = (++ "'")
    }

-- | Create a new datatype with altered field labels, type name, and constructor
-- names along with a conversion function.
--
-- The conversion function will have a name matching the pattern:
--
-- > wrangle + OldTypeName + To + NewTypeName
--
-- As an example, consider the following datatype and wrangling:
--
-- > data Person = Person { name :: String, age :: Int }
-- >
-- > 'wrangle' ''Person 'with'
-- >   { 'fieldLabelModifier' = ('_' :)
-- >   , 'typeNameModifier' = ("Powerful" ++)
-- >   }
--
-- This has the effect of creating this new datatype and function:
--
-- > data PowerfulPerson = Person' { _name :: String, _age :: Int }
-- >
-- > wranglePersonToPowerfulPerson :: Person -> PowerfulPerson
-- > wranglePersonToPowerfulPerson (Person x0 x1) = Person' x0 x1
--
-- @since 0.1.0.0
wrangle :: Name -> WrangleOpts -> DecsQ
wrangle tyName WrangleOpts {..} = do
    TyConI theDec <- reify tyName
    (name, tyvars, constrs) <-
        case theDec of
            DataD _ctx name tyVarBinders _mkind constructors _derivs ->
                pure (name, tyVarBinders, constructors)
            NewtypeD _ctx name tyVarBinders _mkind constructor _derivs ->
                pure (name, tyVarBinders, [constructor])
            _ ->
                fail
                  $ "Expected a data or newtype declaration, but the given name \""
                  <> show tyName
                  <> "\" is neither of these things."
    let modifyName f = mkName . f . nameBase
        newRecName = modifyName typeNameModifier name

    recConstrs <- for constrs $ \constr -> case constr of
        RecC recName fields ->
            pure (recName, fields)
        _ ->
            fail
                $ "Expected a record constructor, but got: "
                <> show constr

    let newConstrs = flip map recConstrs $ \(recName, fields) ->
          ( modifyName constructorModifier recName
          , flip map fields $ \(fieldName, bang', typ) ->
              (modifyName fieldLabelModifier fieldName, bang', typ)
          )

    let mkPatternFrom (recName, _) vars =
            ConP recName $ map VarP vars
        mkVariableNames (_, fields) =
            for fields $ \_ -> newName "x"
        mkBodyFrom (recName, _) vars =
            NormalB $ foldl AppE (ConE recName) (map VarE vars)

    convClauses <-
        for (zip recConstrs newConstrs) $ \(constr, newConstr) -> do
            vars <- mkVariableNames constr
            pure $ Clause [mkPatternFrom constr vars] (mkBodyFrom newConstr vars) []

    let convertName =
            "wrangle" <> nameBase tyName <> "To" <> nameBase newRecName
        convert =
            FunD (mkName convertName) convClauses

    sig <- [t| $(conT tyName) -> $(conT newRecName)|]

    pure
        [ DataD [] newRecName tyvars Nothing (map (uncurry RecC) newConstrs) []
        , SigD (mkName convertName) sig
        , convert
        ]