PureScript port of Will Jones' type-indexed config "bag".

Bag.purs

module Main where

import Control.Alternative       ((<|>))
import Control.Apply             (lift2)
import Control.Monad.Eff         (Eff)
import Control.Monad.Eff.Console (CONSOLE, logShow)
import Data.Argonaut.Core        (Json)
import Data.Argonaut.Decode      (class DecodeJson, decodeJson)
import Data.Argonaut.Encode      (class EncodeJson, encodeJson)
import Data.Either               (hush)
import Data.Generic.Rep          as G
import Data.Generic.Rep.Show     (genericShow)
import Data.Maybe                (Maybe(..))
import Data.Monoid               (mempty)
import Data.Newtype              (class Newtype, wrap, unwrap)
import Data.Semigroup.Last       (Last)
import Data.StrMap               as M
import Data.Symbol               (class IsSymbol, SProxy(..), reflectSymbol)
import Type.Data.Symbol          (class AppendSymbol)
import Type.Proxy                (Proxy(..))

import Prelude                   hiding (class Field)

class IsSymbol key <= Field key value | value -> key

class IsSymbol key <= Group key (group :: Type -> Type) | group -> key

instance genericGroup
  :: ( G.Generic (group a) (G.Constructor key (G.Argument a))
     , IsSymbol key
     )
  => Group key group

instance regularField
  :: ( Newtype newtype_ value
     , G.Generic newtype_ (G.Constructor key inner)
     , IsSymbol key
     )
  => Field key newtype_

instance groupField
  :: ( Field childKey value
     , Group parentKey group
     , AppendSymbol parentKey "/" prefix
     , AppendSymbol prefix childKey key
     , IsSymbol key
     )
  => Field key (group value)

type Bag = M.StrMap (Last Json)

insert
  :: forall key value
   . Field key value
  => EncodeJson value
  => value
  -> Bag
  -> Bag

insert
  = M.insert (reflectSymbol (SProxy :: SProxy key))
  <<< wrap
  <<< encodeJson

lookup
  :: forall key value
   . Field key value
  => DecodeJson value
  => Bag
  -> Maybe value

lookup
  = hush
  <<< decodeJson
  <<< unwrap
  <=< M.lookup (reflectSymbol (SProxy :: SProxy key))

class GenericBuilder a where
  gbuild :: Bag -> Maybe a

instance genericNoConstructorsBuilder
    :: GenericBuilder G.NoConstructors where
  gbuild _ = Nothing

instance genericNoArgumentsBuilder
    :: GenericBuilder G.NoArguments where
  gbuild _ = Just G.NoArguments

instance genericSumBuilder
    :: ( GenericBuilder left
       , GenericBuilder right
       )
    => GenericBuilder (G.Sum left right) where
  gbuild bag
      = map G.Inl (gbuild bag)
    <|> map G.Inr (gbuild bag)

instance genericProductBuilder
    :: ( GenericBuilder left
       , GenericBuilder right
       )
    => GenericBuilder (G.Product left right) where
  gbuild bag = lift2 G.Product (gbuild bag) (gbuild bag)

instance genericConstructorBuilder
    :: GenericBuilder a
    => GenericBuilder (G.Constructor key a) where
  gbuild bag = map G.Constructor (gbuild bag)

instance genericArgumentBuilder
    :: ( G.Generic a rep
       , GenericBuilder rep
       )
    => GenericBuilder (G.Argument a) where
  gbuild bag = map (G.Argument <<< G.to) (gbuild bag)

instance genericRecBuilder
    :: GenericBuilder a
    => GenericBuilder (G.Rec a) where
  gbuild bag = map G.Rec (gbuild bag)

instance genericFieldBuilder
    :: ( G.Generic a rep
       , GenericBuilder rep
       )
    => GenericBuilder (G.Field key a) where
  gbuild bag = map (G.Field <<< G.to) (gbuild bag)

instance zzzGenericRegularBuilder
    :: ( Field key value
       , DecodeJson value
       )
    => GenericBuilder value where
  gbuild = lookup

build
  :: forall a rep
   . G.Generic a rep
  => GenericBuilder rep
  => Proxy a
  -> Bag
  -> Maybe a

build _
  = map G.to <<< gbuild

------------------

newtype Name = Name String
derive instance genericName :: G.Generic Name _
derive instance newtypeName :: Newtype Name _
derive newtype instance decodeJsonName :: DecodeJson Name
derive newtype instance encodeJsonName :: EncodeJson Name

instance showName :: Show Name where
  show = genericShow

newtype Age = Age Int
derive instance genericAge :: G.Generic Age _
derive instance newtypeAge :: Newtype Age _
derive newtype instance decodeJsonAge :: DecodeJson Age
derive newtype instance encodeJsonAge :: EncodeJson Age

instance showAge :: Show Age where
  show = genericShow

newtype Primary a = Primary a
derive instance genericPrimary :: G.Generic (Primary a) _
derive instance newtypePrimary :: Newtype (Primary a) _
derive newtype instance decodeJsonPrimary :: DecodeJson a => DecodeJson (Primary a)
derive newtype instance encodeJsonPrimary :: EncodeJson a => EncodeJson (Primary a)

instance showPrimary :: Show a => Show (Primary a) where
  show = genericShow

-- Example

newtype Person
  = Person
      { name :: Name
      , age  :: Age
      }

derive instance newtypePerson :: Newtype Person _
derive instance genericPerson :: G.Generic Person _

instance showPerson :: Show Person where
  show = genericShow

getPerson :: Bag -> Maybe (Primary Person)
getPerson = build (Proxy :: Proxy (Primary Person))

--[1/1 NoInstanceFound] src/Main.purs:216:13
--
--  216  getPerson = build
--                   ^^^^^
--
--  No type class instance was found for
--
--    Data.Generic.Rep.Generic t0
--                             (Constructor "Primary" (Argument Person))
--
--  The instance head contains unknown type variables. Consider adding a type annotation.
--
--  while checking that type forall a rep. Generic a rep => GenericBuilder rep => StrMap (Last Json) -> Maybe a
--    is at least as general as type StrMap (Last Json) -> Maybe (Primary Person)
--  while checking that expression build
--    has type StrMap (Last Json) -> Maybe (Primary Person)
--  in value declaration getPerson
--
--  where t0 is an unknown type

main :: Eff (console :: CONSOLE) Unit
main
  = logShow
  $ getPerson
  $ insert (Primary (Age 24))
  $ insert (Primary (Name "Tom"))
  $ mempty -- An empty bag.