diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for knit + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/knit.cabal b/knit.cabal new file mode 100644 --- /dev/null +++ b/knit.cabal @@ -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 +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 diff --git a/src/Knit.hs b/src/Knit.hs new file mode 100644 --- /dev/null +++ b/src/Knit.hs @@ -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") diff --git a/test/Example.hs b/test/Example.hs new file mode 100644 --- /dev/null +++ b/test/Example.hs @@ -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 diff --git a/test/Example2.hs b/test/Example2.hs new file mode 100644 --- /dev/null +++ b/test/Example2.hs @@ -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) diff --git a/vendor/generics-eot/src/Generics/Eot.hs b/vendor/generics-eot/src/Generics/Eot.hs new file mode 100644 --- /dev/null +++ b/vendor/generics-eot/src/Generics/Eot.hs @@ -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)) diff --git a/vendor/generics-eot/src/Generics/Eot/Datatype.hs b/vendor/generics-eot/src/Generics/Eot/Datatype.hs new file mode 100644 --- /dev/null +++ b/vendor/generics-eot/src/Generics/Eot/Datatype.hs @@ -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 = [] diff --git a/vendor/generics-eot/src/Generics/Eot/Eot.hs b/vendor/generics-eot/src/Generics/Eot/Eot.hs new file mode 100644 --- /dev/null +++ b/vendor/generics-eot/src/Generics/Eot/Eot.hs @@ -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)