mirror of
https://github.com/ilyakooo0/roboservant.git
synced 2024-09-11 08:05:47 +03:00
some renaming
This commit is contained in:
parent
2498df9cd0
commit
67d88d2ef5
@ -2,8 +2,8 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
|
||||
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
@ -22,6 +22,7 @@ import Data.Map.Strict (Map)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.Typeable (TypeRep, Typeable, typeRep)
|
||||
import GHC.Generics(Generic)
|
||||
|
||||
data Provenance
|
||||
= Provenance TypeRep Int
|
||||
@ -35,9 +36,18 @@ class Typeable x => BuildFrom x where
|
||||
|
||||
|
||||
-- | Can't be built up from parts
|
||||
newtype Atomic x = Atomic x
|
||||
newtype Atom x = Atom { unAtom :: x }
|
||||
|
||||
instance Typeable x => BuildFrom (Atomic x) where
|
||||
-- | can be broken down and built up from generic pieces
|
||||
newtype Compound x = Compound { unCompound :: x }
|
||||
|
||||
instance (Typeable x, Generic x) => BuildFrom (Compound x) where
|
||||
buildFrom = error "buildfrom"
|
||||
|
||||
instance (Typeable x, Generic x) => Breakdown (Compound x) where
|
||||
breakdown = error "breakdown"
|
||||
|
||||
instance Typeable x => BuildFrom (Atom x) where
|
||||
buildFrom = Map.lookup (typeRep (Proxy @x))
|
||||
|
||||
|
||||
@ -53,13 +63,13 @@ promisedDyn :: Typeable a => Dynamic -> a
|
||||
promisedDyn = fromMaybe (error "internal error, typerep map misconstructed") . fromDynamic
|
||||
|
||||
-- instance BuildFrom Bool
|
||||
deriving via (Atomic Bool) instance BuildFrom Bool
|
||||
deriving via (Atom Bool) instance BuildFrom Bool
|
||||
|
||||
instance (Typeable x, BuildFrom x) => BuildFrom (Maybe x) where
|
||||
buildFrom dict = Just $ fmap toDyn <$> options
|
||||
where options :: NonEmpty ([Provenance], Maybe x)
|
||||
options = ([],Nothing) :|
|
||||
(maybe [] NEL.toList . fmap (fmap (fmap (Just . promisedDyn @x)))
|
||||
(maybe [] (NEL.toList . (fmap (fmap (Just . promisedDyn @x))))
|
||||
$ buildFrom @x dict)
|
||||
|
||||
class Breakdown x where
|
||||
@ -67,14 +77,11 @@ class Breakdown x where
|
||||
-- default breakdown :: Typeable x => x -> NonEmpty Dynamic
|
||||
-- breakdown = pure . toDyn
|
||||
|
||||
-- | Can't break it down any further -- stuck in your teeth, maybe.
|
||||
newtype Chewy x = Chewy { unChew :: x }
|
||||
instance Typeable a => Breakdown (Atom a) where
|
||||
breakdown = pure . toDyn . unAtom
|
||||
|
||||
instance Typeable a => Breakdown (Chewy a) where
|
||||
breakdown = pure . toDyn . unChew
|
||||
|
||||
deriving via (Chewy ()) instance Breakdown ()
|
||||
deriving via (Chewy Int) instance Breakdown Int
|
||||
deriving via (Atom ()) instance Breakdown ()
|
||||
deriving via (Atom Int) instance Breakdown Int
|
||||
|
||||
|
||||
--let d = toDyn x in Map.fromList [(dynTypeRep d, pure d)]
|
||||
|
23
test/Spec.hs
23
test/Spec.hs
@ -1,4 +1,3 @@
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
@ -14,7 +13,7 @@ import qualified Post
|
||||
|
||||
import Data.Dynamic(toDyn)
|
||||
import qualified Roboservant as RS
|
||||
import Roboservant(Chewy,Breakdown, BuildFrom, Atomic)
|
||||
import Roboservant(Breakdown, BuildFrom, Atom, Compound)
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Core.Spec
|
||||
import Data.Void
|
||||
@ -78,24 +77,24 @@ spec = do
|
||||
-- RS.prop_concurrent @UnsafeIO.UnsafeApi unsafeServer []
|
||||
|
||||
|
||||
deriving via (Chewy Foo.Foo) instance Breakdown Foo.Foo
|
||||
deriving via (Atomic Foo.Foo) instance BuildFrom Foo.Foo
|
||||
deriving via (Atom Foo.Foo) instance Breakdown Foo.Foo
|
||||
deriving via (Atom Foo.Foo) instance BuildFrom Foo.Foo
|
||||
|
||||
deriving via (Chewy Headers.Foo) instance Breakdown Headers.Foo
|
||||
deriving via (Atomic Headers.Foo) instance BuildFrom Headers.Foo
|
||||
deriving via (Atom Headers.Foo) instance Breakdown Headers.Foo
|
||||
deriving via (Atom Headers.Foo) instance BuildFrom Headers.Foo
|
||||
|
||||
deriving via (Chewy Seeded.Seed) instance Breakdown Seeded.Seed
|
||||
deriving via (Atomic Seeded.Seed) instance BuildFrom Seeded.Seed
|
||||
deriving via (Atom Seeded.Seed) instance Breakdown Seeded.Seed
|
||||
deriving via (Atom Seeded.Seed) instance BuildFrom Seeded.Seed
|
||||
|
||||
|
||||
-- instance RS.BuildFrom Seeded.Seed
|
||||
|
||||
deriving via (Atomic Void) instance RS.BuildFrom Void
|
||||
deriving via (Atom Void) instance RS.BuildFrom Void
|
||||
|
||||
deriving via (Atomic Post.FooPost) instance RS.BuildFrom Post.FooPost
|
||||
deriving via (Chewy Post.FooPost) instance RS.Breakdown Post.FooPost
|
||||
deriving via (Atom Post.FooPost) instance RS.BuildFrom Post.FooPost
|
||||
deriving via (Atom Post.FooPost) instance RS.Breakdown Post.FooPost
|
||||
|
||||
-- deriving via (Atomic Void) instance RS.BuildFrom Void
|
||||
-- deriving via (Atom Void) instance RS.BuildFrom Void
|
||||
|
||||
-- instance RS.Breakdown Post.FooPost
|
||||
-- instance RS.BuildFrom Post.FooPost
|
||||
|
Loading…
Reference in New Issue
Block a user