packages feed

knit (empty) → 0.1.0.0

raw patch · 11 files changed

+1224/−0 lines, 11 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, deepseq, hashtables, knit, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for knit++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Philip Kamenarsky (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Philip Kamenarsky nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,111 @@+# knit++[![CircleCI](https://circleci.com/gh/pkamenarsky/knit.svg?style=svg)](https://circleci.com/gh/pkamenarsky/knit)++`knit` ties the knot on data structures that reference each other by unique keys. Above all it aims to be easy to use - boilerplate is kept to a minimum and its API is as simple as it gets.++## Example++```haskell+data Person model m = Person+  { name        :: Id model m String+  , loves       :: ForeignId model m "persons" "name" --+  , isPresident :: Bool                               --+  } deriving (Generic, KnitRecord Model)              --+                                                      -- +data Model m = Model                                  --+  { persons :: Table Model m Person -- <----------------+  } deriving (Generic, KnitTables)+```++Let's break that down: when defining a domain type, like `Person`, we'll need two additional type parameters that will determine the final shape of that type: the `model` `Person` belongs to (it may belong to multiple models), and its "mode" (`m`) - whether it's *resolved* or *unresolved*. Additionally, we need to derive `KnitRecord` for every domain type, supplying it with a concrete `model` type.++`Id model m t` will define a key this type is referenced by (multiple keys are possible).++`ForeignId` is where the magic happens - in addition to the two generic parameters from above it takes a "table" name (which is just a field in the `model`) and a field name in the referenced domain type; the final type of the `ForeignId` field (both resolved and unresolved) can then be inferred from this information alone!++To define a `model`, wrap each domain type with a `Table` and autoderive the `KnitTables` typeclass.++Let's take a look:++```haskell+alice :: Person Model 'Unresolved+alice = Person+  { name        = Id "Alice+  , loves       = ForeignId "Bob"  -- this must be a String, since Model.persons.name is a String!+  , isPresident = False+  }++bob :: Person Model 'Unresolved+bob = Person+  { name        = Id "Bob"+  , loves       = ForeignId "Alice"+  , isPresident = False+  }++model :: Model 'Unresolved+model = Model+  { persons = [alice, bob]  -- `Table` is just a regular list+  }+```++So far so good. Resolving an unresolved model is just a matter of calling `knit`:++```haskell+knitModel :: Model Resolved+knitModel = case knit model of+  Right resolved -> resolved+  Left e -> error (show e)+```++(`knit` may fail due to invalid or duplicate keys). If all goes well, we'll get the following *resolved* model, if we were to do it by hand:++```haskell+manualAlice :: Person Model 'Resolved+manualAlice = Person+  { name        = "Alice"+  , loves       = Lazy manualBob+  , isPresident = False+  }++manualBob :: Person Model 'Resolved+manualBob = Person+  { name        = "Bob"+  , loves       = Lazy manualAlice+  , isPresident = False+  }++manualModel :: Model 'Resolved+manualModel = Model+  { persons = [manualAlice, manualBob]+  }+```++`Lazy` is just a simple wrapper with a `get` field. Simplified it's just:++```+data Lazy a = { get :: a }+```++And here it is, a nicely knit model:++```haskell+name $ get $ loves (persons knitModel !! 0) -- "Bob"+```++The `test` directory contains more examples, with multiple domain types.++## Cascading deletes++By supplying a `Remove` key instead the regular `Id` a record is marked for deletion:++```+alice :: Person Model 'Unresolved+alice = Person+  { name        = Remove "Alice  -- mark the record for deletion+  , loves       = ForeignId "Bob"+  , isPresident = False+  }+```++This will remove the record from the resolved result, as well as *all other records that depend transitively on it*. Invalid keys (i.e. `ForeignId`s that reference non-existent `Id`s) will still throw an error when `knit`-ting a model.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ knit.cabal view
@@ -0,0 +1,73 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 9a018114683474c6cf3790641de1ab1452d949f9accab039ef8c9c01bc3dcf91++name:           knit+version:        0.1.0.0+synopsis:       Ties the knot on data structures that reference each other by unique keys.+description:    Please see the README on GitHub at <https://github.com/pkamenarsky/knit#readme>+category:       Data Structures+homepage:       https://github.com/pkamenarsky/knit#readme+bug-reports:    https://github.com/pkamenarsky/knit/issues+author:         Philip Kamenarsky+maintainer:     p.kamenarsky@gmail.com+copyright:      BSD3+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/pkamenarsky/knit++library+  exposed-modules:+      Knit+      Paths_knit+  autogen-modules:+      Paths_knit+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , bytestring+    , containers+    , deepseq+    , generics-eot+    , hashtables+    , vector+  default-language: Haskell2010++library generics-eot+  exposed-modules:+      Generics.Eot+      Generics.Eot.Datatype+      Generics.Eot.Eot+  other-modules:+      Paths_knit+  hs-source-dirs:+      vendor/generics-eot/src+  build-depends:+      base >=4.8 && <5+  default-language: Haskell2010++test-suite knit-test+  type: exitcode-stdio-1.0+  main-is: Example.hs+  other-modules:+      Example2+      Paths_knit+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , knit+  default-language: Haskell2010
+ src/Knit.hs view
@@ -0,0 +1,511 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Knit+  ( KnitRecord+  , KnitTables+  , Mode (..)++  , Table+  , Lazy (..)++  , Id+  , ForeignId++  , RecordId (..)+  , ForeignRecordId (..)++  , ResolveError (..)++  , knit+  )where++import           Control.DeepSeq (NFData)+import qualified Control.Monad.ST as ST++import           Data.Foldable (Foldable, toList)+import qualified Data.HashTable.Class as HC+import qualified Data.HashTable.ST.Basic as H+import qualified Data.Map as M+import qualified Data.Set as S+import           Data.Maybe (catMaybes)+import           Data.Semigroup ((<>))++import           GHC.Generics (Generic)+import           GHC.TypeLits (KnownSymbol, Symbol, TypeError, ErrorMessage(..), symbolVal)+import qualified Generics.Eot as Eot+import           Generics.Eot (Eot, HasEot, Named (Named), Void, Proxy (..), fromEot, toEot)++import           Unsafe.Coerce (unsafeCoerce)++--------------------------------------------------------------------------------++type family Fst a where+  Fst '(a, b) = a++type family Snd a where+  Snd '(a, b) = b++--------------------------------------------------------------------------------++type TableName = String+type FieldName = String+type FieldValue = String++data Mode = Resolved | Unresolved | Done++data RecordId t = Id t | Remove t+  deriving (Show, Eq, Ord, Generic)++instance NFData t => NFData (RecordId t)++type family Id (tables :: Mode -> *) (recordMode :: Mode) t where+  Id tables 'Done t = RecordId t+  Id tables 'Resolved t = t+  Id tables 'Unresolved t = RecordId t++data Lazy tables a = Lazy+  { get :: a tables 'Resolved+  }++instance Show (Lazy tables a) where+  show _ = "Lazy"++newtype ForeignRecordId (table :: Symbol) (field :: Symbol) t = ForeignId t+  deriving (Show, Eq, Ord, Num, Generic, NFData)++type family ForeignId (tables :: Mode -> *) (recordMode :: Mode) (table :: Symbol) (field :: Symbol) where+  ForeignId tables 'Done table field = ()+  ForeignId tables 'Unresolved table field = ForeignRecordId+    table+    field+    (LookupFieldType field (Snd (LookupTableType table (Eot (tables 'Unresolved)))))+  ForeignId tables 'Resolved table field = Lazy+    tables+    (Fst (LookupTableType table (Eot (tables 'Resolved))))++-- GatherIds -------------------------------------------------------------------++data EId+  = forall t. Show t => EId TableName FieldName t Dynamic+  | forall t. Show t => ERemove TableName FieldName t Dynamic+  | forall t. Show t => EForeignId TableName FieldName t++deriving instance Show EId++newtype Dynamic = Dynamic ()++instance Show Dynamic where+  show _ = "Dynamic"++toDynamic :: a -> Dynamic+toDynamic = Dynamic . unsafeCoerce++fromDynamic :: Dynamic -> a+fromDynamic (Dynamic v) = unsafeCoerce v++--------------------------------------------------------------------------------++class GGatherIds u where+  gGatherIds :: TableName -> Dynamic -> u -> [EId]++instance GGatherIds () where+  gGatherIds _ _ () = []++instance GGatherIds Void where+  gGatherIds _ _ _ = undefined++instance (GGatherIds u, GGatherIds v) => GGatherIds (Either u v) where+  gGatherIds table record (Left u) = gGatherIds table record u+  gGatherIds table record (Right v) = gGatherIds table record v++instance GGatherIds us => GGatherIds (Named field u, us) where+  gGatherIds table record (_, us) = gGatherIds table record us++instance {-# OVERLAPPING #-}+  ( Show t+  , GGatherIds us+  , KnownSymbol field+  ) =>+  GGatherIds (Named field (RecordId t), us) where+    gGatherIds table record (Named (Id k), us)+      = EId table (symbolVal (Proxy :: Proxy field)) k record:gGatherIds table record us+    gGatherIds table record (Named (Remove k), us)+      = ERemove table (symbolVal (Proxy :: Proxy field)) k record:gGatherIds table record us++instance {-# OVERLAPPING #-}+  ( Show t++  , GGatherIds us++  , KnownSymbol table+  , KnownSymbol field+  ) =>+  GGatherIds (Named field' (ForeignRecordId table field t), us) where+    gGatherIds table record (Named (ForeignId k), us)+      = EForeignId (symbolVal (Proxy :: Proxy table)) (symbolVal (Proxy :: Proxy field)) k:gGatherIds table record us++instance {-# OVERLAPPING #-}+  ( Show t++  , GGatherIds us++  , Foldable f++  , KnownSymbol field+  ) =>+  GGatherIds (Named field (f (RecordId t)), us) where+    gGatherIds table record (Named f, us) = eids <> gGatherIds table record us+      where+        eids =+          [ EId table (symbolVal (Proxy :: Proxy field)) k record+          | Id k <- toList f+          ]++instance {-# OVERLAPPING #-}+  ( Show t++  , GGatherIds us++  , Foldable f++  , KnownSymbol table+  , KnownSymbol field+  ) =>+  GGatherIds (Named field' (f (ForeignRecordId table field t)), us) where+    gGatherIds table record (Named f, us) = eids <> gGatherIds table record us+      where+        eids =+          [ EForeignId (symbolVal (Proxy :: Proxy table)) (symbolVal (Proxy :: Proxy field)) k+          | ForeignId k <- toList f+          ]++-- GatherTableIds --------------------------------------------------------------++class GGatherTableIds t where+  gGatherTableIds :: t -> [(TableName, [[EId]])]++instance GGatherTableIds () where+  gGatherTableIds () = []++instance GGatherTableIds Void where+  gGatherTableIds _ = undefined++instance (GGatherTableIds t, GGatherTableIds u) => GGatherTableIds (Either t u) where+  gGatherTableIds (Left t) = gGatherTableIds t+  gGatherTableIds (Right u) = gGatherTableIds u++instance ( GGatherTableIds ts+         , KnitRecord tables r+         , KnownSymbol table+         ) => GGatherTableIds (Named table [r tables 'Unresolved], ts) where+  gGatherTableIds (Named records, ts) = (table, eids):gGatherTableIds ts+    where+      table = symbolVal (Proxy :: Proxy table)+      eids =+        -- TODO: remove table here+        [ gatherIds table (toDynamic record) record+        | record <- records+        ]++-- Resolve ---------------------------------------------------------------------++data ResolveError+  = MissingIds [(TableName, FieldName, FieldValue)]+  | RepeatingIds [(TableName, FieldName, FieldValue)]+  deriving (Generic, Show)++instance NFData ResolveError++class GResolve u r where+  gResolve+    :: (TableName -> FieldName -> FieldValue -> Dynamic)+    -> u+    -> r++instance GResolve () () where+  gResolve _ () = ()++instance GResolve Void Void where+  gResolve _ _ = undefined++instance (GResolve u r, GResolve t s) => GResolve (Either u t) (Either r s) where+  gResolve rsvMap (Left u) = Left $ gResolve rsvMap u +  gResolve rsvMap (Right u) = Right $ gResolve rsvMap u ++instance (GResolve us rs) => GResolve (Named x u, us) (Named x u, rs) where+  gResolve rsvMap (u, us) = (u, gResolve rsvMap us)++instance (GResolve us rs) => GResolve (Named x (RecordId u), us) (Named x u, rs) where+  gResolve rsvMap (Named (Id u), us) = (Named u, gResolve rsvMap us)+  gResolve rsvMap (Named (Remove _), us) = (Named (error "gResolve: Remove: this is a bug"), gResolve rsvMap us)++instance (GResolve us rs, Functor f) => GResolve (Named x (f (RecordId u)), us) (Named x (f u), rs) where+  gResolve rsvMap (Named u', us) = (Named $ fmap (\(Id u) -> u) u', gResolve rsvMap us)++instance+  ( Show u++  , KnitRecord tables r+  , GResolve us rs++  , KnownSymbol table+  , KnownSymbol field+  ) =>+  GResolve (Named x (ForeignRecordId table field u), us) (Named x (Lazy tables r), rs) where+    gResolve rsvMap (Named (ForeignId k), us)+      = ( Named $ Lazy $ resolve rsvMap (fromDynamic $ rsvMap table field (show k))+        , gResolve rsvMap us+        )+      where+        table = symbolVal (Proxy :: Proxy table)+        field = symbolVal (Proxy :: Proxy field)++instance+  ( Show u++  , KnitRecord tables r+  , GResolve us rs++  , Functor f++  , KnownSymbol table+  , KnownSymbol field+  ) =>+  GResolve (Named x (f (ForeignRecordId table field u)), us) (Named x (f (Lazy tables r)), rs) where+    gResolve rsvMap (Named f, us)+      = ( Named $ flip fmap f $ \(ForeignId k) -> Lazy $ resolve rsvMap (fromDynamic $ rsvMap table field (show k))+        , gResolve rsvMap us+        )+      where+        table = symbolVal (Proxy :: Proxy table)+        field = symbolVal (Proxy :: Proxy field)++instance+  ( KnitRecord tables r+  , GResolve us rs+  ) =>+  GResolve (Named x (r tables 'Unresolved), us) (Named x (r tables 'Resolved), rs) where+    gResolve rsvMap (Named u, us) = (Named $ resolve rsvMap u, gResolve rsvMap us)++instance+  ( KnitRecord tables r+  , GResolve us rs+  , Functor f+  ) =>+  GResolve (Named x (f (r tables 'Unresolved)), us) (Named x (f (r tables 'Resolved)), rs) where+    gResolve rsvMap (Named u, us) = (Named $ fmap (resolve rsvMap) u, gResolve rsvMap us)++-- ResolveTables ---------------------------------------------------------------++class GResolveTables u t where+  gResolveTables :: [[Bool]] -> (TableName -> FieldName -> FieldValue -> Dynamic) -> u -> t++instance GResolveTables () () where+  gResolveTables _ _ () = ()++instance GResolveTables u t => GResolveTables (Either u Void) (Either t Void) where+  gResolveTables notRemoved rsvMap (Left u) = Left $ gResolveTables notRemoved rsvMap u+  gResolveTables _ _ _ = undefined++instance+  ( GResolveTables us ts+  , KnitRecord tables t +  ) => GResolveTables (Named table [t tables 'Unresolved], us) (Named table [t tables 'Resolved], ts) where+    gResolveTables (notRemoved:notRemoved') rsvMap (Named ts, us)+      = (Named resolved, gResolveTables notRemoved' rsvMap us)+      where+        resolved =+          [ resolve rsvMap t+          | (nr, t) <- zip notRemoved ts+          , nr+          ]+    gResolveTables [] _ _ = error "gResolveTables: [] (this is a bug)"++-- KnitRecord ------------------------------------------------------------------++class KnitRecord (tables :: Mode -> *) u where+  resolve+    :: (TableName -> FieldName -> FieldValue -> Dynamic)+    -> u tables 'Unresolved+    -> u tables 'Resolved+  default resolve+    :: HasEot (u tables 'Unresolved)+    => HasEot (u tables 'Resolved)+    => GResolve (Eot (u tables 'Unresolved)) (Eot (u tables 'Resolved))++    => (TableName -> FieldName -> FieldValue -> Dynamic)+    -> u tables 'Unresolved+    -> u tables 'Resolved+  resolve rsvMap = fromEot . gResolve rsvMap . toEot++  gatherIds :: TableName -> Dynamic -> u tables 'Unresolved -> [EId]+  default gatherIds+    :: HasEot (u tables 'Unresolved)+    => GGatherIds (Eot (u tables 'Unresolved))++    => TableName+    -> Dynamic+    -> u tables 'Unresolved+    -> [EId]+  gatherIds table record = gGatherIds table record . toEot++-- KnitTables ------------------------------------------------------------------++class KnitTables t where+  resolveTables+    :: (TableName -> FieldName -> FieldValue -> Dynamic)+    -> t 'Unresolved+    -> Either ResolveError (t 'Resolved)+  default resolveTables+    :: HasEot (t 'Unresolved)+    => HasEot (t 'Resolved)+    => GResolveTables (Eot (t 'Unresolved)) (Eot (t 'Resolved))+    => KnitTables t++    => (TableName -> FieldName -> FieldValue -> Dynamic)+    -> t 'Unresolved+    -> Either ResolveError (t 'Resolved)+  resolveTables extRsvMap u+    | not (null repeatingIds) = Left $ RepeatingIds repeatingIds+    | [] <- missingIds = Right $ fromEot $ gResolveTables notRemovedIds rsv (toEot u)+    | otherwise = Left $ MissingIds missingIds+    where+      eids = gatherTableIds u++      notRemovedIds =+        [ [ and+              [ case eid of+                  EId table field k _ -> not ((table, field, show k) `S.member` removedRecords)+                  ERemove _ _ _ _ -> False+                  _ -> True+              | eid <- record+              ]+          | record <- records+          ]+        | (_, records) <- eids+        ]++      recordMap = M.fromListWith (<>) $ mconcat+        [ mconcat+            [ case eid of+                EId table field k r -> [((table, field, show k), [(r, True, fids)])]+                ERemove table field k r -> [((table, field, show k), [(r, False, fids)])]+                _ -> []+            | eid <- record+            ]+        | (_, records) <- eids+        , record <- records+        , let fids =+                [ fid+                | fid@(EForeignId _ _ _) <- record+                ]+        ]++      reverseMap = M.fromListWith (<>) $ mconcat+        [ [ ((ftable, ffield, show fk), S.singleton (table, field, k))+          | EForeignId ftable ffield fk <- fids+          ]+        | ((table, field, k), [(_, _, fids)]) <- M.toList recordMap+        ]++      removedRecords = ST.runST $ do+        m <- H.new++        let markRemoved (table, field, k) = do+              v <- H.lookup m (table, field, k)++              case v of+                Nothing -> do+                  H.insert m (table, field, k) True++                  sequence_+                    [ markRemoved (ftable, ffield, fk)+                    | Just fids <- [ M.lookup (table, field, k) reverseMap ]+                    , (ftable, ffield, fk) <- S.toList fids+                    ]+                Just _ -> pure ()++        sequence_+          [ markRemoved k+          | (k, [(_, False, _)]) <- M.toList recordMap+          ]++        S.fromList . fmap fst <$> HC.toList m++      repeatingIds = mconcat+        [ if length records > 1+            then [(table, field, k)]+            else []+        | ((table, field, k), records) <- M.toList recordMap+        ]++      missingIds = catMaybes+        [ case M.lookup (table, field, show k) recordMap of+            Nothing -> Just (table, field, show k)+            Just _ -> Nothing+        | (_, [(_, _, fids)]) <- M.toList recordMap+        , EForeignId table field k <- fids+        ]++      rsvRecord table field value = M.lookup (table, field, value) recordMap++      rsv table field value = case rsvRecord table field value of+        Nothing -> extRsvMap table field value+        Just [(record, _, _)] -> record+        _ -> error "resolveTables: repeating ids (this is a bug, the consistency check should have caught this)"++  gatherTableIds :: t 'Unresolved -> [(TableName, [[EId]])]+  default gatherTableIds+    :: HasEot (t 'Unresolved)+    => GGatherTableIds (Eot (t 'Unresolved))+    => t 'Unresolved+    -> [(TableName, [[EId]])]+  gatherTableIds = gGatherTableIds . toEot++-- Expand ----------------------------------------------------------------------++type family ExpandRecord (parent :: Symbol) (record :: *) where+  ExpandRecord parent () = ()+  ExpandRecord parent (Either fields Eot.Void) = ExpandRecord parent fields+  ExpandRecord parent (Eot.Named name (RecordId a), fields) = (Eot.Named name a, ExpandRecord parent fields)+  ExpandRecord parent (Eot.Named name (f (RecordId a)), fields) = (Eot.Named name (f a), ExpandRecord parent fields)+  ExpandRecord parent (a, fields) = ExpandRecord parent fields++type family LookupTableType (table :: Symbol) (eot :: *) :: (((Mode -> *) -> Mode -> *), *) where+  LookupTableType name (Either records Eot.Void) = LookupTableType name records+  LookupTableType name (Eot.Named name [record tables recordMode], records)+    = '(record, ExpandRecord name (Eot (record tables 'Done)))+  LookupTableType name (Eot.Named otherName [record tables recordMode], records)+    = LookupTableType name records++  LookupTableType name eot = TypeError ('Text "Can't lookup table type")++type family LookupFieldType (field :: Symbol) (eot :: *) :: * where+  LookupFieldType name (Either records Eot.Void) = LookupFieldType name records+  LookupFieldType name (Eot.Named name (Maybe field), fields) = field+  LookupFieldType name (Eot.Named name field, fields) = field+  LookupFieldType name (Eot.Named otherName field, fields) = LookupFieldType name fields+  LookupFieldType name eot = TypeError ('Text "Can't lookup field type")++-- Table -----------------------------------------------------------------------++type family Table (tables :: Mode -> *) (c :: Mode) table where+  Table tables r table = [table tables r]++--------------------------------------------------------------------------------++knit :: KnitTables t => t 'Unresolved -> Either ResolveError (t 'Resolved)+knit = resolveTables+  (error "knit: inconsistent record (this is a bug, the consistency check should have caught this")
+ test/Example.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS -Wno-unticked-promoted-constructors #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++module Main where++import GHC.Generics+import Knit++-- Stolen from https://hackage.haskell.org/package/tie-knot-0.2/docs/Data-Knot.html++data Person tables m = Person+  { name  :: Id tables m String+  , loves :: [ForeignId tables m "persons" "name"]+  } deriving (Generic, KnitRecord Model)++deriving instance Show (Person Model Resolved)++data Model m = Model+  { persons :: Table Model m Person+  } deriving (Generic, KnitTables)++deriving instance Show (Model Resolved)++--------------------------------------------------------------------------------++model :: Model Unresolved+model = Model+  [ Person (Id "Alice") [ ForeignId "Bob", ForeignId "cat" ]+  , Person (Id "Bob") [ ForeignId "Alice" ]++  -- You may disagree, but the cat thinks of itself as Person+  , Person (Id "cat") [ ForeignId "cat" ]+  ]++knitModel :: Model Resolved+knitModel = case knit model of+  Right resolved -> resolved+  Left e -> error (show e)++manualModel :: Model Resolved+manualModel = Model+  [ alice+  , bob+  , cat+  ]+  where+    alice = Person "Alice" [ Lazy bob, Lazy cat ]+    bob = Person "Bob" [ Lazy alice ]+    cat = Person "cat" [ Lazy cat ]++--------------------------------------------------------------------------------++model2 :: Model Unresolved+model2 = Model+  [ Person (Remove "Alice") [ ForeignId "Bob", ForeignId "cat" ]+  , Person (Id "Bob") [ ForeignId "Alice" ]++  -- You may disagree, but the cat thinks of itself as Person+  , Person (Id "cat") [ ForeignId "cat" ]+  ]++knitModel2 :: Model Resolved+knitModel2 = case knit model2 of+  Right resolved -> resolved+  Left e -> error (show e)++manualModel2 :: Model Resolved+manualModel2 = Model+  [ cat+  ]+  where+    cat = Person "cat" [ Lazy cat ]++--------------------------------------------------------------------------------++whoLovesX :: Model Resolved -> String -> [String]+whoLovesX m x =+  [ lovingName+  | Person lovingName lovedPersons <- persons m+  , lovedPerson <- lovedPersons+  , name (get lovedPerson) == x+  ]++testModel :: Model Resolved -> Model Resolved -> IO ()+testModel km mm = sequence_+  [ if whoLovesX km x == whoLovesX mm x+      then putStrLn $ "  Testing " <> x <> ": passed"+      else error $ "  Testing " <> x <> ": failed"+  | x <- [ "Bob", "Alice", "cat" ]+  ]++main :: IO ()+main = do+  putStrLn "Testing model..."+  testModel knitModel manualModel++  putStrLn "Testing model2..."+  testModel knitModel2 manualModel2
+ test/Example2.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++module Example2 where++import           Data.Word (Word64)++import qualified GHC.Generics as G++import           Knit++data Person tables m = Person+  { name :: String+  , friend :: Maybe (ForeignId tables m "persons" "pid")+  , employer :: Maybe (ForeignId tables m "employers" "owner")+  , pid :: Id tables m Word64+  , pid2 :: Id tables m String+  , other :: Employer tables m+  } deriving (G.Generic, KnitRecord CompanyTables)++deriving instance Show (Person CompanyTables 'Unresolved)+deriving instance Show (Person CompanyTables 'Resolved)++data MaybeList a = MaybeList [Maybe a]+  deriving (Functor, Foldable, G.Generic, Show)++data Employer tables m = Employer+  { address :: String+  , employees :: MaybeList (ForeignId tables m "persons" "pid")+  , owner :: Id tables m String+  } deriving (G.Generic, KnitRecord CompanyTables)++deriving instance Show (Employer CompanyTables 'Unresolved)+deriving instance Show (Employer CompanyTables 'Resolved)++data CompanyTables m = CompanyTables+  { persons :: Table CompanyTables m Person+  , employers :: Table CompanyTables m Employer+  } deriving (G.Generic, KnitTables)++deriving instance Show (CompanyTables 'Resolved)
+ vendor/generics-eot/src/Generics/Eot.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | @generics-eot@ tries to be a library for datatype generic programming+-- that is easy to understand. "eot" stands for "eithers of tuples".+--+-- A tutorial on how to use @generics-eot@ can be found here:+-- https://generics-eot.readthedocs.io/.+module Generics.Eot (+  HasEot(..),+  Named(..),++  -- * Meta Information+  Datatype(..),+  Constructor(..),+  Fields(..),++  -- * Useful Re-exports+  Generic,+  Proxy(..),+  Void,+  absurd,+  ) where++import           Data.Proxy+import           Data.Void+import           GHC.Exts (Constraint)+import           GHC.Generics hiding (Datatype, Constructor)++import           Generics.Eot.Datatype+import           Generics.Eot.Eot++-- | An instance (@'HasEot' a@) allows us to+--+-- - convert values of an arbitrary algebraic datatype @a@ to and from a generic+--   representation (@'Eot' a@) (see 'toEot' and 'fromEot').+-- - extract meta information about the type @a@ (see 'datatype').+--+-- Once an algebraic datatype has an instance for 'GHC.Generics.Generic' it+-- automatically gets one for 'HasEot'.+class HasEot a where+  -- | 'Eot' is a type level function that maps arbitrary ADTs to isomorphic+  -- generic representations. Here's an example:+  --+  -- > data Foo = A Int Bool | B String+  --+  -- would be mapped to:+  --+  -- > Either (Int, (Bool, ())) (Either (String, ()) Void)+  --+  -- These representations follow these rules:+  --+  -- - The choice between constructors is mapped to right-nested 'Either's.+  -- - There's always a so-called end-marker 'Void'. It's an invalid choice (and+  --   'Void' is uninhabited to make sure you don't accidentally create such a value).+  --   So e.g. @data Foo = A@ would be mapped to @Either () Void@, and a type+  --   with no constructors is mapped to @Void@.+  -- - The fields of one constructor are mapped to right-nested tuples.+  -- - Again there's always an end-marker, this time of type @()@.+  --   A constructor with three fields @a@, @b@, @c@ is mapped to+  --   @(a, (b, (c, ())))@, one field @a@ is mapped to @(a, ())@, and no+  --   fields are mapped to @()@ (just the end-marker).+  --+  -- These rules (and the end-markers) are necessary to make sure generic+  -- functions know exactly which parts of the generic representation are field+  -- types and which parts belong to the generic skeleton.+  type Eot a :: *++  -- | Convert a value of type @a@ to its generic representation.+  toEot :: a -> Eot a++  -- | Convert a value in a generic representation to @a@ (inverse of 'toEot').+  fromEot :: Eot a -> a++  -- | Extract meta information about the ADT.+  datatype :: Proxy a -> Datatype++instance (Generic a, ImpliedByGeneric a c f) => HasEot a where+  type Eot a = EotG (Rep a)+  toEot = toEotG . from+  fromEot = to . fromEotG+  datatype Proxy = datatypeC (Proxy :: Proxy (Rep a))++type family ImpliedByGeneric a c f :: Constraint where+  ImpliedByGeneric a c f =+    (GenericDatatype (Rep a),+     Rep a ~ D1 c f,+     GenericConstructors f,+     HasEotG (Rep a))
+ vendor/generics-eot/src/Generics/Eot/Datatype.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Generics.Eot.Datatype where++import           Data.Maybe+import           Data.Proxy+import qualified GHC.Generics as GHC+import           GHC.Generics hiding (Datatype(..), Constructor(..))++-- | Type for meta information about ADTs.+data Datatype+  = Datatype {+    datatypeName :: String, -- ^ unqualified name of the type+    constructors :: [Constructor]+  }+  deriving (Show, Eq)++data Constructor+  = Constructor {+    constructorName :: String,+    fields :: Fields+  }+  deriving (Show, Eq)++-- | Type that represents meta information about fields of one+-- constructor.+data Fields+  = Selectors [String]+    -- ^ Record constructor, containing the list of the selector names.+  | NoSelectors Int+    -- ^ Constructor with fields, but without selector names.+    -- The argument gives the number of fields.+  | NoFields+    -- ^ Constructor without fields.+  deriving (Show, Eq)++-- * datatype++class GenericDatatype (a :: * -> *) where+  datatypeC :: Proxy a -> Datatype++instance (GHC.Datatype c, GenericConstructors f) =>+  GenericDatatype (D1 c f) where+    datatypeC Proxy = Datatype n constructors+      where+        n = GHC.datatypeName (undefined :: D1 c f x)+        constructors = getConstructors (Proxy :: Proxy f)++-- * constructors++class GenericConstructors (a :: * -> *) where+  getConstructors :: Proxy a -> [Constructor]++instance (GenericConstructors a, GenericConstructors b) =>+  GenericConstructors (a :+: b) where+    getConstructors Proxy = getConstructors a ++ getConstructors b+      where+        a :: Proxy a = Proxy+        b :: Proxy b = Proxy++instance (GHC.Constructor c, GenericFields f) =>+  GenericConstructors (C1 c f) where+    getConstructors Proxy = [Constructor n (getFields f)]+      where+        n = GHC.conName (undefined :: (C1 c f x))+        f :: Proxy f = Proxy++instance GenericConstructors V1 where+  getConstructors Proxy = []++-- * fields++getFields :: GenericFields a => Proxy a -> Fields+getFields proxy = case getFieldsC proxy of+  [] -> NoFields+  l@(Nothing : _) -> NoSelectors (length l)+  l@(Just _ : _) -> Selectors (catMaybes l)++class GenericFields (a :: * -> *) where+  getFieldsC :: Proxy a -> [Maybe String]++instance (GenericFields a, GenericFields b) =>+  GenericFields (a :*: b) where+    getFieldsC Proxy = getFieldsC a ++ getFieldsC b+      where+        a :: Proxy a = Proxy+        b :: Proxy b = Proxy++instance Selector c => GenericFields (S1 c (Rec0 f)) where+  getFieldsC proxy = [getField proxy]++getField :: forall c f . Selector c =>+  Proxy (S1 c (Rec0 f)) -> Maybe String+getField Proxy = case selName (undefined :: S1 c (Rec0 f) x) of+  "" -> Nothing+  s -> Just s++instance GenericFields U1 where+  getFieldsC Proxy = []
+ vendor/generics-eot/src/Generics/Eot/Eot.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Generics.Eot.Eot (+  HasEotG(..),+  Named(..)+  ) where++import           Data.Proxy+import           Data.Void+import           GHC.Generics+import           GHC.TypeLits++-- * datatype++class HasEotG (a :: * -> *) where+  type EotG a :: *+  toEotG :: a x -> EotG a+  fromEotG :: EotG a -> a x++instance HasConstructorsG f => HasEotG (D1 c f) where+  type EotG (D1 c f) = Constructors f+  toEotG (M1 x) = toEotConstructors x+  fromEotG x = M1 $ fromEotConstructors x++-- * constructors++class HasConstructorsG (a :: * -> *) where+  type Constructors a :: *+  toEotConstructors :: a x -> Constructors a+  fromEotConstructors :: Constructors a -> a x++instance (HasConstructorsG a, HasConstructorsG b, Normalize (Constructors a) (Constructors b)) =>+  HasConstructorsG (a :+: b) where+    type Constructors (a :+: b) = GEither (Constructors a) (Constructors b)+    toEotConstructors = \ case+      L1 a -> gLeft (toEotConstructors a) (Proxy :: Proxy (Constructors b))+      R1 b -> gRight (Proxy :: Proxy (Constructors a)) (toEotConstructors b)+    fromEotConstructors x = case gEither x of+      Left a -> L1 (fromEotConstructors a)+      Right b -> R1 (fromEotConstructors b)++instance HasFieldsG f => HasConstructorsG (C1 c f) where+  type Constructors (C1 c f) = Either (Fields f) Void+  toEotConstructors = Left . toEotFields . unM1+  fromEotConstructors = \ case+    Left fields -> M1 $ fromEotFields fields+    Right void -> absurd void++instance HasConstructorsG V1 where+  type Constructors V1 = Void+  toEotConstructors v1 = seq v1 (error "impossible")+  fromEotConstructors = absurd++-- * GEither++class Normalize a b where+  type GEither a b :: *+  gLeft :: a -> Proxy b -> GEither a b+  gRight :: Proxy a -> b -> GEither a b+  gEither :: GEither a b -> Either a b++instance Normalize b c => Normalize (Either a b) c where+  type GEither (Either a b) c = Either a (GEither b c)+  gLeft (Left a) Proxy = Left a+  gLeft (Right b) Proxy = Right $ gLeft b (Proxy :: Proxy c)+  gRight Proxy c = Right $ gRight (Proxy :: Proxy b) c+  gEither :: Either a (GEither b c) -> Either (Either a b) c+  gEither = \ case+    Left a -> Left (Left a)+    Right g -> case gEither g of+      Left b -> Left (Right b)+      Right c -> Right c++instance Normalize Void b where+  type GEither Void b = b+  gLeft void Proxy = absurd void+  gRight Proxy b = b+  gEither :: b -> Either Void b+  gEither = Right++-- * fields++class HasFieldsG (a :: * -> *) where+  type Fields a :: *+  toEotFields :: a x -> Fields a+  fromEotFields :: Fields a -> a x++instance (HasFieldsG a, HasFieldsG b, Concat (Fields a) (Fields b)) =>+  HasFieldsG (a :*: b) where+    type Fields (a :*: b) = Fields a +++ Fields b+    toEotFields (a :*: b) = toEotFields a +++ toEotFields b+    fromEotFields x = case unConcat x of+      (a, b) -> fromEotFields a :*: fromEotFields b++data Named (a :: Symbol) field = Named field deriving Show+data Unnamed field = Unnamed field deriving Show++instance KnownSymbol name => HasFieldsG (S1 ('MetaSel ('Just name) x y z) (Rec0 f)) where+  type Fields (S1 ('MetaSel ('Just name) x y z) (Rec0 f)) = (Named name f, ())+  toEotFields (M1 (K1 x)) = (Named x, ())+  fromEotFields (Named x, ()) = M1 $ K1 x++instance HasFieldsG (S1 ('MetaSel 'Nothing x y z) (Rec0 f)) where+  type Fields (S1 ('MetaSel 'Nothing x y z) (Rec0 f)) = (Unnamed f, ())+  toEotFields (M1 (K1 x)) = (Unnamed x, ())+  fromEotFields (Unnamed x, ()) = M1 $ K1 x++instance HasFieldsG U1 where+  type Fields U1 = ()+  toEotFields U1 = ()+  fromEotFields () = U1++-- * heterogenous lists++class Concat a b where+  type a +++ b :: *+  (+++) :: a -> b -> (a +++ b)+  unConcat :: (a +++ b) -> (a, b)++instance Concat as bs => Concat (a, as) bs where+  type (a, as) +++ bs = (a, as +++ bs)+  (a, as) +++ bs = (a, as +++ bs)+  unConcat :: (a, as +++ bs) -> ((a, as), bs)+  unConcat (a, rest) = case unConcat rest of+    (as, bs) -> ((a, as), bs)++instance Concat () bs where+  type () +++ bs = bs+  () +++ bs = bs+  unConcat :: bs -> ((), bs)+  unConcat bs = ((), bs)