Skip to content

Instantly share code, notes, and snippets.

@i-am-tom
Last active May 3, 2018 10:06
Show Gist options
  • Save i-am-tom/1874add1c15b5b93795527e29da7bb24 to your computer and use it in GitHub Desktop.
Save i-am-tom/1874add1c15b5b93795527e29da7bb24 to your computer and use it in GitHub Desktop.
PureScript port of Will Jones' type-indexed config "bag".
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.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment