named-defaults

NamedDefaults.hs

{-# LANGUAGE KindSignatures, DataKinds, FlexibleInstances, FlexibleContexts,
             FunctionalDependencies, TypeFamilies, TypeOperators,
             PatternSynonyms, UndecidableInstances, ConstraintKinds,
             TypeApplications, ScopedTypeVariables, CPP #-}

module NamedDefaults (FillDefaults, fillDefaults, (!.)) where

import Prelude (Maybe(..), id)
import Data.Kind (Type)

import Named

(!.) :: Apply name (Maybe a) fn fn' => fn -> Named a name -> fn'
fn !. a = fn ! justNamed a
  where
    justNamed :: Named a name -> Named (Maybe a) name
    justNamed (Named x) = Named (Just x)

fillDefaults :: FillDefaults fn fn' => fn -> fn'
fillDefaults = fillDefaults'

data Decision = Done | Skip Decision | Fill Decision

type family Decide (fn :: Type) :: Decision where
  Decide (Named (Maybe a) name -> r) = Fill (Decide r)
  Decide (x -> r) = Skip (Decide r)
  Decide t = Done

type FillDefaults fn = FillDefaults' (Decide fn) fn

class
  ( decision ~ Decide fn
  ) => FillDefaults' decision fn fn' | fn -> fn'
  where
    fillDefaults' :: fn -> fn'

instance
  ( Decide fn ~ Done
  , fn ~ fn'
  ) => FillDefaults' Done fn fn' where
  fillDefaults' = id

instance
  ( FillDefaults' decision r r',
    Decide fn ~ Skip decision,
    fn ~ (x -> r),
    fn' ~ (x -> r')
  ) => FillDefaults' (Skip decision) fn fn'
  where
    fillDefaults' fn = \a -> fillDefaults' (fn a)

instance
  ( FillDefaults' decision r r',
    Decide fn ~ Fill decision,
    fn ~ (Named (Maybe x) name -> r),
    fn' ~ r'
  ) => FillDefaults' (Fill decision) fn fn'
  where
    fillDefaults' fn = fillDefaults' (fn (Named Nothing))