{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

{-|
Module      : Data.Partial
Description : Constructing records with default values
Copyright   : (C) mniip 2019
License     : BSD3
Maintainer  : mniip@email.com
Stability   : experimental

If you have a datatype with a lot of default-able fields, e.g.

@
data Foo =
  { fld1 :: Maybe Int
  , fld2 :: Maybe Char
  , fld3 :: Word
  }
@

and you want to avoid the the boilerplate of writing all the default values
every time you construct a record of this type, you could write a "default
value" of this type:

@
defaultFoo :: Foo
defaultFoo = Foo { fld1 = Nothing, fld2 = Nothing, fld3 = 0 }
@

You could then use record modification syntax to make necessary changes to
this value. But perhaps you can't/don't want to provide default values for
/all/ of the fields, but only some of them? You could implement a "default
smart constructor" that would take the non-optional arguments and then fill in
the optional ones like so:

@
defaultFoo :: Word -> Foo
defaultFoo x = Foo { fld1 = Nothing, fld2 = Nothing, fld3 = x }
@

But then you lose the benefit of record syntax: you can't name the fields
you're providing values for.

This package reconciles the two problems: with only a little bit of Template
Haskell it provides a way to construct a record with optional fields while
also letting you refer to the names of those fields. You make two splices:

@
'Data.Partial.TH.mkToPartial' ''Foo
  -- defines mkfld1, mkfld2, mkfld3
'Data.Partial.TH.mkFromPartial' "mkFoo" [t|Foo|] [|Foo { fld1 = Nothing, fld2 = Nothing }|]
  -- defines mkFoo
@

And then you can use them like so:

@
val :: Foo
val = mkFoo
  $ mkfld3 123
  '?' mkfld1 (Just 456)
-- val = Foo { fld1 = Just 456, fld2 = Nothing, fld3 = 123 }
@

The Template Haskell splice lets you define default values for a subset of the
fields, and those defaults will be used when you call @mkFoo@. You can list
fields in any order, but if you omit a mandatory field (one that doesn't have
a default), that would be a type error at compile time.

You can make multiple 'Data.Partial.TH.mkFromPartial' splices, this is
occasionally useful for parameterized types, for example:

@
data Bar a =
  { bar1 :: Maybe Int
  , bar2 :: a
  }
'Data.Partial.TH.mkToPartial' ''Bar
'Data.Partial.TH.mkFromPartial' "mkBar" [t|forall a. Bar a|]
  [|Bar { bar1 = Nothing }|]
  -- mkBar :: ... -> Bar a, and bar2 is a required field
'Data.Partial.TH.mkFromPartial' "mkBarMaybe" [t|forall a. Bar (Maybe a)|]
  [|Bar { bar1 = Nothing, bar2 = Nothing }|]
  -- mkBarMaybe :: ... -> Bar (Maybe a), and bar2 is an optional field
@
-}
module Data.Partial
  ( Partial
  , Graded(..)
  , KnownBool(..)
  , KnownBools
  , type (<||>)
  )
  where

import Data.Kind (Constraint)
import Data.Type.Bool

-- | @Partial T '[b1, b2, ...]@ is a partial version of the datatype @T@ where
-- the first field's presence is indicated by @b1 :: Bool@, second field's
-- presence is indicated by @b2@ and so on. Instances of this would be generated
-- by 'Data.Partial.TH.mkToPartial'.
data family Partial (a :: *) :: [Bool] -> *

-- | A "graded semigroup": if we have two partial structures with only some of
-- the fields, we can merge them to obtain a partial structure with the union of
-- the fields. Prefers to take fields from the left hand side. Instances of this
-- would be generated by 'Data.Partial.TH.mkToPartial'.
class Graded a where
  (?) :: KnownBools b1 => Partial a b1 -> Partial a b2 -> Partial a (b1 <||> b2)

class KnownBool (b :: Bool) where
  observeBool :: ((b ~ 'True) => r) -> ((b ~ 'False) => r) -> r

instance KnownBool 'True where
  {-# INLINE observeBool #-}
  observeBool x _ = x

instance KnownBool 'False where
  {-# INLINE observeBool #-}
  observeBool _ y = y

type family KnownBools (bs :: [Bool]) :: Constraint where
  KnownBools '[] = ()
  KnownBools (b ': bs) = (KnownBool b, KnownBools bs)

type family (<||>) (b1 :: [Bool]) (b2 :: [Bool]) :: [Bool] where
  '[] <||> '[] = '[]
  (x ': xs) <||> (y ': ys) = (x || y) ': (xs <||> ys)