V2 interface

[isovector]

I was using this as an example for my book Algebra Driven Design. The result is too technical to make for a good example, but here it is in its glory:

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE ExtendedDefaultRules  #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

{-# OPTIONS_GHC -Wall                                    #-}
{-# OPTIONS_GHC -Wredundant-constraints                  #-}
{-# OPTIONS_GHC -fno-warn-orphans                        #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}


-- {-# OPTIONS_GHC -ddump-splices         #-}

module Lib where

import Data.Function
import Data.Ord
import           AlgebraCheckers ()
import           Control.Lens (Lens', (^.), (?~), (.~), (&), (%~), at, (<>~))
import           Control.Lens (view)
import           Data.Barbie
import           Data.Bool
import           Data.Coerce
import           Data.Functor ((<&>))
import           Data.Generic.HKD
import           Data.Generics.Product (HasField', field')
import           Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import           Data.IntSet (IntSet)
import qualified Data.IntSet as IS
import           Data.Monoid (Endo (..))
import           Data.Proxy
import           Data.Traversable
import           Data.Witherable.Class
import           Data.Word
import           GHC.Generics
import           GHC.OverloadedLabels
import           GHC.TypeLits
import           Test.QuickCheck
import           Test.QuickCheck (Arbitrary (..))
import           Test.QuickCheck.Checkers (EqProp (..))

data Jar = Jar
  { jar    :: Word8
  , jazz   :: Word8
  , jim    :: Word8
  , jackes :: Word8
  , boop   :: Bool
  } deriving (Generic, Show, Eq, Ord)

instance Arbitrary (HKD w Maybe) => Arbitrary (Entity w) where
  arbitrary = Entity <$> arbitrary

instance Show (HKD w Maybe) => Show (Entity w) where
  show (Entity e) = show e

instance Eq (HKD w Maybe) => Eq (Entity w) where
  Entity a == Entity b = a == b

instance Ord (HKD w Maybe) => Ord (Entity w) where
  Entity a `compare` Entity b = a `compare` b

instance Arbitrary Jar where
  arbitrary = Jar <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
  shrink = genericShrink

instance EqProp Jar

instance CoArbitrary Jar where
  coarbitrary (Jar a b c d e) = coarbitrary (a, b, c, d, e)


instance Show (a -> b) where
  show _ = "<function>"

data System w = System
  { systemData  :: HKD w IntMap
  , systemAlive :: IntSet
  , systemUniq  :: Id
  } deriving (Generic)

newSystem :: Monoid (HKD w IntMap) => System w
newSystem = System mempty mempty $ Id 0

numEntities :: System w -> Int
numEntities = idToInt . systemUniq

instance
    ( Monoid (HKD w IntMap)
    , Construct Maybe w
    , Arbitrary w
    , FunctorB (HKD w)
    ) => Arbitrary (System w) where
  arbitrary = do
    n <- choose (5, 40)
    ws <- fmap (deconstruct @Maybe) <$> vectorOf n arbitrary
    ws' <- for ws $ \w -> do
      -- f <- arbitrary @(HKD w Maybe -> HKD w Maybe)
      pure $ snd . createEntity (Entity w) --(f w)
    pure $ flip appEndo newSystem $ foldMap Endo ws'
  shrink w = (IS.toList $ systemAlive w) <&> \ix ->
    w & field' @"systemData"  %~ bmap (IM.delete ix)
      & field' @"systemAlive" %~ IS.delete ix

instance
    ( Show (HKD w Maybe)
    , Eq (HKD w Maybe)
    , FunctorB (HKD w)
    , Generic w
    ) => EqProp (System w) where
  s1 =-= s2 = query everything s1 =-= query everything s2



instance Show (HKD w IntMap) => Show (System w) where
  show s = mconcat
    [ show $ systemData s
    , "/"
    , show $ numEntities s
    ]

data Query w a where
  RefineMap  :: (a -> Maybe b) -> Query w a -> Query w b
  With       :: Component w a -> Query w a
  Without    :: Component w a -> Query w ()
  Together   :: Query w a -> Query w b -> Query w (a, b)
  Const      :: a -> Query w a
  Ap         :: Query w (a -> b) -> Query w a -> Query w b
  UniqId     :: Query w Id
  Particular :: Id -> Query w Id
  Alt        :: Query w a -> Query w a -> Query w a
  Try        :: Query w a -> Query w (Maybe a)
  Subquery   :: Query w a -> Query w [a]
  Everything :: Query w (Entity w)

instance
    ( Monoid (HKD w IntMap)
    , Construct Maybe w
    , Generic w
    , Arbitrary w
    , FunctorB (HKD w)
    , EqProp a
    , Show (HKD w IntMap)
    ) => EqProp (Query w a) where
  q1 =-= q2 = property $ \s ->
    query q1 s =-= query q2 s

instance Show (Query w a) where
  show (RefineMap _ q)  = "refineMap _ (" ++ show q ++ ")"
  show (With c)         = "with " ++ show c
  show (Without c)      = "without " ++ show c
  show (Together q1 q2) = "together (" ++ show q1 ++ ") (" ++ show q2 ++ ")"
  show (Const _)        = "pure _"
  show (Ap q1 q2)       = "(" ++ show q1 ++ ") <*> (" ++ show q2 ++ ")"
  show (Alt q1 q2)      = "alt (" ++ show q1 ++ ") (" ++ show q2 ++ ")"
  show UniqId           = "uniqId"
  show (Particular a)   = "particular " ++ show a
  show (Try q)          = "try (" ++ show q ++ ")"
  show (Subquery q)     = "subquery (" ++ show q ++ ")"
  show Everything       = "everything"

instance {-# INCOHERENT #-}
    ( Generic w
    , GArbComp w Bool (Rep w)
    , GArbComp w Id (Rep w)
    , GArbComp w a (Rep w)
    , Arbitrary a
    , CoArbitrary a
    ) => Arbitrary (Query w a) where
  arbitrary = arbitrarily []

instance
    ( Generic w
    , GArbComp w Bool (Rep w)
    , GArbComp w Id (Rep w)
    , GArbComp w () (Rep w)
    ) => Arbitrary (Query w ()) where
  arbitrary = arbitrarily []

instance
    ( Generic w
    , GArbComp w Bool (Rep w)
    , GArbComp w Id (Rep w)
    ) => Arbitrary (Query w Id) where
  arbitrary = arbitrarily
    [ (10, pure uniqId)
    , (10, particular <$> arbitrary)
    ]

instance
    ( Generic w
    , GArbComp w Bool (Rep w)
    , GArbComp w Id (Rep w)
    , GArbComp w [a] (Rep w)
    , GArbComp w a (Rep w)
    , Arbitrary a
    , CoArbitrary a
    ) => Arbitrary (Query w [a]) where
  arbitrary = arbitrarily
    [ (10, subquery <$> arbitrary)
    ]

instance
    ( Generic w
    , GArbComp w Bool (Rep w)
    , GArbComp w Id (Rep w)
    , GArbComp w (Either a b) (Rep w)
    , GArbComp w a (Rep w)
    , GArbComp w b (Rep w)
    , Arbitrary a
    , CoArbitrary a
    , Arbitrary b
    , CoArbitrary b
    ) => Arbitrary (Query w (Either a b)) where
  arbitrary = arbitrarily
    [ (10, eitherQ <$> arbitrary <*> arbitrary)
    ]

instance
    ( Generic w
    , GArbComp w Bool (Rep w)
    , GArbComp w Id (Rep w)
    , GArbComp w (Maybe a) (Rep w)
    , GArbComp w a (Rep w)
    , Arbitrary a
    , CoArbitrary a
    ) => Arbitrary (Query w (Maybe a)) where
  arbitrary = arbitrarily
    [ (10, try <$> arbitrary)
    ]

arbitrarily
    :: forall w a
     . ( Generic w
       , GArbComp w Bool (Rep w)
       , GArbComp w Id (Rep w)
       , GArbComp w a (Rep w)
       , Arbitrary a
       , CoArbitrary a
       )
    => [(Int, Gen (Query w a))]
    -> Gen (Query w a)
arbitrarily more = do
  mcomps <- arbitrary
  let also =
        case mcomps of
          Actually comps -> comps
          TooBad         -> mempty
  frequency $
    [ (20, pure <$> arbitrary)
    , (1,  fmap <$> (arbitrary @(Id -> a)) <*> arbitrary @(Query w Id))
    , (1,  fmap <$> (arbitrary @(Bool -> _)) <*> arbitrary)
    , (1,  refineMap <$> (arbitrary @(Id -> _)) <*> arbitrary)
    , (1,  refineMap <$> (arbitrary @(Bool -> _)) <*> arbitrary)
    , (1,  refine <$> arbitrary <*> arbitrary)
    ] ++ more ++ fmap ((1, ) . pure . with) also

instance Functor (Query w) where
  fmap f = refineMap (Just . f)

instance Applicative (Query w) where
  pure  = Const
  (<*>) = Ap

instance Filterable (Query w) where
  mapMaybe = refineMap

data Component w a = Component
  { compName   :: String
  , compEntity :: Lens' w a
  , compSystem :: Lens' (System w) (IntMap a)
  }

instance Show (Component w a) where
  show = mappend "#" . compName

instance Eq (Component w a) where
  (==) = (==) `on` compName

instance Ord (Component w a) where
  compare = comparing compName

instance Arbitrary (PossiblyComponent w a) => Arbitrary (Component w a) where
  arbitrary = arbitrary >>= \case
    Actually zs -> elements zs
    TooBad      -> error "trying to shrink a component that never existed in the first place"


data PossiblyComponent w a
  = Actually [Component w a]
  | TooBad
  deriving (Generic)

instance (Generic w, GArbComp w a (Rep w)) => Arbitrary (PossiblyComponent w a) where
  arbitrary = pure $
    case garbComp @w @a @(Rep w) of
      Just comps -> Actually comps
      Nothing    -> TooBad

instance
    ( KnownSymbol nm
    , HasField' nm w a
    , HasField' nm (HKD w IntMap) (IntMap a)
    ) => IsLabel nm (Component w a) where
  fromLabel =
    Component
      (symbolVal $ Proxy @nm)
      (field' @nm)
      (field' @"systemData" . field' @nm)


class GArbComp w a (f :: * -> *) where
  garbComp :: Maybe [Component w a]

instance {-# OVERLAPPING #-}
    ( KnownSymbol nm
    , HasField' nm w a
    , HasField' nm (HKD w IntMap) (IntMap a)
    ) => GArbComp w a (S1 (MetaSel (Just nm) _1 _2 _3) (K1 _4 a)) where
  garbComp = Just [fromLabel @nm]

instance {-# INCOHERENT #-} GArbComp w a (S1 _1 (K1 _2 b)) where
  garbComp = Nothing

instance
    ( GArbComp w a f
    , GArbComp w a g
    ) => GArbComp w a (f :*: g) where
  garbComp = garbComp @w @a @f <> garbComp @w @a @g

instance
    ( GArbComp w a f
    ) => GArbComp w a (M1 _1 _2 f) where
  garbComp = garbComp @w @a @f

data Setter w where
  Set       :: Component w a -> a -> Setter w
  Unchanged :: Setter w
  Unset     :: Component w a -> Setter w
  Delete    :: Setter w
  Both      :: Setter w -> Setter w -> Setter w

instance Show (Setter w) where
  show (Set c _)  = "Set " ++ show c
  show Unchanged  = "Unchanged"
  show Delete     = "Delete"
  show (Unset c)  = "Unset " ++ show c
  show (Both a b) = "Both (" ++ show a ++ ") (" ++ show b ++ ")"

instance {-# OVERLAPPABLE #-} Arbitrary (Setter w) where
  arbitrary = oneof
    [ pure unchanged
    , pure delete
    , both <$> arbitrary <*> arbitrary
    ]
  shrink (Both a b) = [a, b] ++ fmap (flip both b) (shrink a) ++ fmap (both a) (shrink b) ++ [Unchanged, Delete]
  shrink (Set _ _) = [Unchanged, Delete]
  shrink (Unset _) = [Unchanged, Delete]
  shrink _ = []

instance Arbitrary (Setter Jar) where
  arbitrary = oneof
    [ pure unchanged
    , pure delete
    , both <$> arbitrary <*> arbitrary
    , do
        c <- arbitrary @(Component Jar Word8)
        a <- arbitrary
        pure $ set c a
    , do
        c <- arbitrary @(Component Jar Word8)
        pure $ unset c
    ]

instance
    ( Eq (HKD w Maybe)
    , Show (HKD w Maybe)
    , Monoid (HKD w IntMap)
    , Construct Maybe w
    , Generic w
    , Arbitrary w
    , FunctorB (HKD w)
    , Show (HKD w IntMap)
    ) => EqProp (Setter w) where
  s1 =-= s2 = property $ \w ->
    setEntity (Id 0) s1 w =-= setEntity (Id 0) s2 w


newtype Id = Id
  { idToInt :: Int
  } deriving (Show, Eq, Generic, Ord)

instance EqProp Id

instance Arbitrary Id where
  arbitrary = Id <$> arbitrary
  shrink = genericShrink

instance CoArbitrary Id where
  coarbitrary (Id x) = coarbitrary x

findRelevant :: System w -> Query w a -> IntSet
findRelevant sys (With    c)     = IM.keysSet $ view (compSystem c) sys
findRelevant sys (Without c)     = IS.difference (systemAlive sys) $ findRelevant sys $ With c
findRelevant sys (Together a b)  = IS.intersection (findRelevant sys a) (findRelevant sys b)
findRelevant sys (RefineMap _ q) = findRelevant sys q
findRelevant sys (Const _)       = mkAllIntSet sys
findRelevant sys UniqId          = mkAllIntSet sys
findRelevant _   (Particular ix) = IS.singleton $ idToInt ix
findRelevant sys (Try _)         = mkAllIntSet sys
findRelevant sys (Subquery _)    = mkAllIntSet sys
findRelevant sys Everything      = systemAlive sys
findRelevant sys (Ap a b)        = IS.intersection (findRelevant sys a) (findRelevant sys b)
findRelevant sys (Alt a b)       = IS.union (findRelevant sys a) (findRelevant sys b)

mkAllIntSet :: System w -> IntSet
mkAllIntSet
  = IS.fromList
  . enumFromTo 0
  . subtract 1
  . idToInt
  . systemUniq

-- constantValue
--     :: Query w a -> Either () (Maybe a)
-- constantValue (Const c) = Right $ Just c
-- constantValue (RefineMap f q) = fmap (f =<<) $ constantValue q
-- constantValue (With _) = Left ()
-- constantValue (Without _) = Left ()
-- constantValue (Together q1 q2) = liftA2 (,) <$> constantValue q1 <*> constantValue q2
-- constantValue (Ap qf qa) = (<*>) <$> constantValue qf <*> constantValue qa
-- constantValue UniqId = Left ()
-- constantValue (Particular _) = Left ()
-- constantValue (Alt q1 q2) = ((getFirst .) . (<>) `on` First) <$> constantValue q1 <*> constantValue q2
-- constantValue (Try q) = Just <$> constantValue q
-- constantValue (Subquery _) = Left ()  -- handled elsewhere
-- constantValue Everything = Left ()

---

createEntity
    :: (FunctorB (HKD w), Monoid (HKD w IntMap))
    => Entity w
    -> System w
    -> (Id, System w)
createEntity (Entity e) w =
  let ix = idToInt $ systemUniq w
      ix' = Id $ ix + 1
      e' = bmap (maybe mempty (IM.singleton ix)) e
   in ( Id ix
      , w & field' @"systemData" <>~ e'
          & field' @"systemAlive" %~ IS.insert ix
          & field' @"systemUniq" .~ ix'
      )

delEntity :: FunctorB (HKD w) => Id -> System w -> System w
delEntity ix = setEntity ix Delete

newtype Entity w = Entity (HKD w Maybe)
  deriving (Generic)

instance (Show (HKD w Maybe), Eq (HKD w Maybe)) => EqProp (Entity w) where
  Entity e1 =-= Entity e2 = e1 === e2


getEntity :: FunctorB (HKD w) => Id -> System w -> Entity w
getEntity ix w = Entity $ bmap (IM.lookup $ idToInt ix) $ systemData w

queryEntity :: (FunctorB (HKD w), Generic w) => Id -> Query w a -> System w -> Maybe a
queryEntity ix (Const a) s = bool Nothing (Just a) $ isBounded ix s
queryEntity ix (Subquery q) s = bool Nothing (Just $ query q s) $ isBounded ix s
queryEntity ix (RefineMap f q) s = f =<< queryEntity ix q s
queryEntity ix (With c) s = s ^. compAtIx c ix
-- TODO(sandy): without isn't bounded i think
queryEntity ix (Without c) s = maybe (Just ()) (const Nothing) $ s ^. compAtIx c ix
queryEntity ix (Together c1 c2) s =
  (,)
    <$> queryEntity ix c1 s
    <*> queryEntity ix c2 s
queryEntity ix (Ap c1 c2) s = queryEntity ix c1 s <*> queryEntity ix c2 s
queryEntity ix UniqId s = bool Nothing (Just ix) $ isBounded ix s
queryEntity ix (Particular ix') sys = bool Nothing (Just ix) $ ix == ix' && IS.member (idToInt ix) (systemAlive sys)
queryEntity ix Everything s = Just $ getEntity ix s
queryEntity ix (Try q) s = bool Nothing (Just $ queryEntity ix q s) $ isBounded ix s
queryEntity ix (Alt q1 q2) s = do
  a <- queryEntity ix (try q1) s
  case a of
    Just a' -> pure a'
    Nothing -> queryEntity ix q2 s
  -- b <- try $ queryEntity ix q2
  -- = maybe
  --     (Right <$> queryEntity ix q2 s)
  --     (Just . Left)
  -- $ queryEntity ix q1 s

isBounded :: Id -> System w -> Bool
isBounded ix s = idToInt ix >= 0 && idToInt ix < idToInt (systemUniq s)

compAtIx
    :: Functor f
    => Component w a
    -> Id
    -> (Maybe a -> f (Maybe a))
    -> System w -> f (System w)
compAtIx c ix = compSystem c . at (idToInt ix)
-- TODO(sandy): wtf? why doesn't this need a model to not yell?

setEntity :: FunctorB (HKD w) => Id -> Setter w -> System w -> System w
setEntity _ Unchanged sys = sys
setEntity ix _ sys | not (isBounded ix sys) = sys
setEntity ix Delete sys =
  sys
    & field' @"systemData" %~ bmap (IM.delete (idToInt ix))
    & field' @"systemAlive" %~ IS.delete (idToInt ix)
setEntity ix (Unset c) sys =
  sys
    & compAtIx c ix .~ Nothing
setEntity ix (Both s1 s2) sys =
  setEntity ix s2 $ setEntity ix s1 sys
setEntity ix (Set c a) sys =
  sys
    & compAtIx c ix ?~ a

query :: (FunctorB (HKD w), Generic w) => Query w a -> System w -> [a]
query (Subquery q) s = [query q s]
query UniqId s = coerce $ enumFromTo 0 $ numEntities s - 1
-- query q _ | Right z <- constantValue q = maybeToList z
-- TODO(sandy): need to do the same thing as in the model
query q s
  = mapMaybe (\ix -> queryEntity ix q s)
  . coerce
  . IS.toList
  $ findRelevant s q

update :: (FunctorB (HKD w), Generic w) => Query w a -> (a -> Setter w) -> System w -> System w
update q f s
  = flip appEndo s
  . foldMap (\(ix, a) -> Endo $ setEntity ix (f a))
  $ query (Together UniqId q) s

particular :: Id -> Query w Id
particular = Particular

uniqId :: Query w Id
uniqId = UniqId

with :: Component w a -> Query w a
with = With

fetch :: Component w a -> Query w (Maybe a)
fetch = try . with

without :: Component w a -> Query w ()
without = Without

refine :: (a -> Bool) -> Query w a -> Query w a
refine p = refineMap (bool Nothing . Just <*> p)

refineMap :: (a -> Maybe b) -> Query w a -> Query w b
refineMap = RefineMap

-- -- unique :: (w -> Unique a) -> Query w a
-- -- unique = undefined

together :: Query w a -> Query w b -> Query w (a, b)
-- TODO(sandy): this should be a law!
together (Const a) (Const b) = Const (a, b)
together q1 q2 = Together q1 q2

mapQ :: (a -> b) -> Query w a -> Query w b
mapQ = fmap

pureQ :: a -> Query w a
pureQ = pure

apQ :: Query w (a -> b) -> Query w a -> Query w b
apQ = (<*>)

eitherQ :: Query w a -> Query w a -> Query w a
-- eitherQ = Alt
eitherQ = Alt

try :: Query w a -> Query w (Maybe a)
try (Const c) = Const (Just c)
try q = Try q

subquery  :: Query w a -> Query w [a]
subquery = Subquery

everything :: Query w (Entity w)
everything = Everything

set :: Component w a -> a -> Setter w
set = Set

unset :: Component w a -> Setter w
unset = Unset

-- -- setUnique :: (w -> Unique a) -> a -> Setter w
-- -- setUnique = undefined

unchanged :: Setter w
unchanged = Unchanged

both :: Setter w -> Setter w  -> Setter w
both Delete _ = Delete
both _ Delete = Delete
both Unchanged a = a
both a Unchanged = a
both (Unset c) s@(Unset c')
  | compName c == compName c'
  = s
both (Unset c) s@(Set c' _)
  | compName c == compName c'
  = s
both (Set c' _) s@(Unset c)
  | compName c == compName c'
  = s
both (Set c _) s@(Set c' _)
  | compName c == compName c'
  = s
both s1 s2 = Both s1 s2

delete :: Setter w
delete = Delete

activeEntities :: System w -> [Id]
activeEntities = undefined