{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module U.Codebase.Sqlite.Orphans where

import Control.Applicative
import U.Codebase.Branch.Type (NamespaceStats (..))
import U.Codebase.Reference qualified as C.Reference
import U.Codebase.Referent qualified as C.Referent
import U.Codebase.Reflog qualified as Reflog
import U.Codebase.Sqlite.DbId
import U.Codebase.WatchKind (WatchKind)
import U.Codebase.WatchKind qualified as WatchKind
import U.Util.Base32Hex
import Unison.Hash qualified as Hash
import Unison.Prelude
import Unison.Sqlite

-- Newtype for avoiding orphan instances
newtype AsSqlite a = AsSqlite {forall a. AsSqlite a -> a
fromSQLite :: a}
  deriving (Int -> AsSqlite a -> ShowS
[AsSqlite a] -> ShowS
AsSqlite a -> String
(Int -> AsSqlite a -> ShowS)
-> (AsSqlite a -> String)
-> ([AsSqlite a] -> ShowS)
-> Show (AsSqlite a)
forall a. Show a => Int -> AsSqlite a -> ShowS
forall a. Show a => [AsSqlite a] -> ShowS
forall a. Show a => AsSqlite a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> AsSqlite a -> ShowS
showsPrec :: Int -> AsSqlite a -> ShowS
$cshow :: forall a. Show a => AsSqlite a -> String
show :: AsSqlite a -> String
$cshowList :: forall a. Show a => [AsSqlite a] -> ShowS
showList :: [AsSqlite a] -> ShowS
Show)

instance ToRow (AsSqlite C.Reference.Reference) where
  toRow :: AsSqlite Reference -> [SQLData]
toRow (AsSqlite Reference
ref) = case Reference
ref of
    C.Reference.ReferenceBuiltin Text
txt -> [Text -> SQLData
SQLText Text
txt, SQLData
SQLNull, SQLData
SQLNull]
    C.Reference.ReferenceDerived (C.Reference.Id Hash
h Pos
p) -> [SQLData
SQLNull, Text -> SQLData
forall a. ToField a => a -> SQLData
toField (Text -> SQLData) -> Text -> SQLData
forall a b. (a -> b) -> a -> b
$ Hash -> Text
Hash.toBase32HexText Hash
h, Pos -> SQLData
forall a. ToField a => a -> SQLData
toField Pos
p]

instance ToRow (AsSqlite C.Referent.Referent) where
  toRow :: AsSqlite Referent -> [SQLData]
toRow (AsSqlite Referent
ref) = case Referent
ref of
    C.Referent.Ref Reference
ref' -> AsSqlite Reference -> [SQLData]
forall a. ToRow a => a -> [SQLData]
toRow (Reference -> AsSqlite Reference
forall a. a -> AsSqlite a
AsSqlite Reference
ref') [SQLData] -> [SQLData] -> [SQLData]
forall a. Semigroup a => a -> a -> a
<> [SQLData
SQLNull]
    C.Referent.Con Reference
ref' Pos
conId -> AsSqlite Reference -> [SQLData]
forall a. ToRow a => a -> [SQLData]
toRow (Reference -> AsSqlite Reference
forall a. a -> AsSqlite a
AsSqlite Reference
ref') [SQLData] -> [SQLData] -> [SQLData]
forall a. Semigroup a => a -> a -> a
<> [Pos -> SQLData
forall a. ToField a => a -> SQLData
toField Pos
conId]

instance FromRow (AsSqlite C.Referent.Referent) where
  fromRow :: RowParser (AsSqlite Referent)
fromRow = do
    AsSqlite Reference
reference <- RowParser (AsSqlite Reference)
forall a. FromRow a => RowParser a
fromRow
    RowParser (Maybe Pos)
forall a. FromField a => RowParser a
field RowParser (Maybe Pos)
-> (Maybe Pos -> RowParser (AsSqlite Referent))
-> RowParser (AsSqlite Referent)
forall a b. RowParser a -> (a -> RowParser b) -> RowParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Pos
Nothing -> AsSqlite Referent -> RowParser (AsSqlite Referent)
forall a. a -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AsSqlite Referent -> RowParser (AsSqlite Referent))
-> AsSqlite Referent -> RowParser (AsSqlite Referent)
forall a b. (a -> b) -> a -> b
$ Referent -> AsSqlite Referent
forall a. a -> AsSqlite a
AsSqlite (Reference -> Referent
forall termRef typeRef. termRef -> Referent' termRef typeRef
C.Referent.Ref Reference
reference)
      Just Pos
conId -> AsSqlite Referent -> RowParser (AsSqlite Referent)
forall a. a -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AsSqlite Referent -> RowParser (AsSqlite Referent))
-> AsSqlite Referent -> RowParser (AsSqlite Referent)
forall a b. (a -> b) -> a -> b
$ Referent -> AsSqlite Referent
forall a. a -> AsSqlite a
AsSqlite (Reference -> Pos -> Referent
forall termRef typeRef. typeRef -> Pos -> Referent' termRef typeRef
C.Referent.Con Reference
reference Pos
conId)

instance FromRow (AsSqlite C.Reference.Reference) where
  fromRow :: RowParser (AsSqlite Reference)
fromRow = do
    (Maybe Text
 -> Maybe (AsSqlite Hash)
 -> Maybe Pos
 -> (Maybe Text, Maybe (AsSqlite Hash), Maybe Pos))
-> RowParser (Maybe Text)
-> RowParser (Maybe (AsSqlite Hash))
-> RowParser (Maybe Pos)
-> RowParser (Maybe Text, Maybe (AsSqlite Hash), Maybe Pos)
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 (,,) RowParser (Maybe Text)
forall a. FromField a => RowParser a
field RowParser (Maybe (AsSqlite Hash))
forall a. FromField a => RowParser a
field RowParser (Maybe Pos)
forall a. FromField a => RowParser a
field RowParser (Maybe Text, Maybe (AsSqlite Hash), Maybe Pos)
-> ((Maybe Text, Maybe (AsSqlite Hash), Maybe Pos)
    -> RowParser (AsSqlite Reference))
-> RowParser (AsSqlite Reference)
forall a b. RowParser a -> (a -> RowParser b) -> RowParser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Just Text
builtin, Maybe (AsSqlite Hash)
Nothing, Maybe Pos
Nothing) -> AsSqlite Reference -> RowParser (AsSqlite Reference)
forall a. a -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AsSqlite Reference -> RowParser (AsSqlite Reference))
-> (Reference -> AsSqlite Reference)
-> Reference
-> RowParser (AsSqlite Reference)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> AsSqlite Reference
forall a. a -> AsSqlite a
AsSqlite (Reference -> RowParser (AsSqlite Reference))
-> Reference -> RowParser (AsSqlite Reference)
forall a b. (a -> b) -> a -> b
$ (Text -> Reference
forall t h. t -> Reference' t h
C.Reference.ReferenceBuiltin Text
builtin)
      (Maybe Text
Nothing, Just (AsSqlite Hash
hash), Just Pos
pos) -> AsSqlite Reference -> RowParser (AsSqlite Reference)
forall a. a -> RowParser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AsSqlite Reference -> RowParser (AsSqlite Reference))
-> (Reference -> AsSqlite Reference)
-> Reference
-> RowParser (AsSqlite Reference)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> AsSqlite Reference
forall a. a -> AsSqlite a
AsSqlite (Reference -> RowParser (AsSqlite Reference))
-> Reference -> RowParser (AsSqlite Reference)
forall a b. (a -> b) -> a -> b
$ Id' Hash -> Reference
forall t h. Id' h -> Reference' t h
C.Reference.ReferenceDerived (Hash -> Pos -> Id' Hash
forall h. h -> Pos -> Id' h
C.Reference.Id Hash
hash Pos
pos)
      (Maybe Text, Maybe (AsSqlite Hash), Maybe Pos)
p -> String -> RowParser (AsSqlite Reference)
forall a. HasCallStack => String -> a
error (String -> RowParser (AsSqlite Reference))
-> String -> RowParser (AsSqlite Reference)
forall a b. (a -> b) -> a -> b
$ String
"Invalid Reference parameters" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Maybe Text, Maybe (AsSqlite Hash), Maybe Pos) -> String
forall a. Show a => a -> String
show (Maybe Text, Maybe (AsSqlite Hash), Maybe Pos)
p

instance ToField (AsSqlite Hash.Hash) where
  toField :: AsSqlite Hash -> SQLData
toField (AsSqlite Hash
h) = Text -> SQLData
forall a. ToField a => a -> SQLData
toField (Hash -> Text
Hash.toBase32HexText Hash
h)

instance FromField (AsSqlite Hash.Hash) where
  fromField :: FieldParser (AsSqlite Hash)
fromField Field
f =
    forall a. FromField a => FieldParser a
fromField @Text Field
f Ok Text -> (Text -> AsSqlite Hash) -> Ok (AsSqlite Hash)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
txt ->
      Hash -> AsSqlite Hash
forall a. a -> AsSqlite a
AsSqlite (Hash -> AsSqlite Hash) -> Hash -> AsSqlite Hash
forall a b. (a -> b) -> a -> b
$ (Text -> Hash
Hash.unsafeFromBase32HexText Text
txt)

deriving via Text instance ToField Base32Hex

deriving via Text instance FromField Base32Hex

instance ToField WatchKind where
  toField :: WatchKind -> SQLData
toField = \case
    WatchKind
WatchKind.RegularWatch -> Int64 -> SQLData
SQLInteger Int64
0
    WatchKind
WatchKind.TestWatch -> Int64 -> SQLData
SQLInteger Int64
1

instance FromField WatchKind where
  fromField :: FieldParser WatchKind
fromField =
    forall a. FromField a => FieldParser a
fromField @Int8 FieldParser Int8
-> (Ok Int8 -> Ok WatchKind) -> FieldParser WatchKind
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Int8 -> WatchKind) -> Ok Int8 -> Ok WatchKind
forall a b. (a -> b) -> Ok a -> Ok b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap \case
      Int8
0 -> WatchKind
WatchKind.RegularWatch
      Int8
1 -> WatchKind
WatchKind.TestWatch
      Int8
tag -> String -> WatchKind
forall a. HasCallStack => String -> a
error (String -> WatchKind) -> String -> WatchKind
forall a b. (a -> b) -> a -> b
$ String
"Unknown WatchKind id " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int8 -> String
forall a. Show a => a -> String
show Int8
tag

instance ToRow NamespaceStats where
  toRow :: NamespaceStats -> [SQLData]
toRow (NamespaceStats {Int
numContainedTerms :: Int
$sel:numContainedTerms:NamespaceStats :: NamespaceStats -> Int
numContainedTerms, Int
numContainedTypes :: Int
$sel:numContainedTypes:NamespaceStats :: NamespaceStats -> Int
numContainedTypes, Int
numContainedPatches :: Int
$sel:numContainedPatches:NamespaceStats :: NamespaceStats -> Int
numContainedPatches}) =
    (Int, Int, Int) -> [SQLData]
forall a. ToRow a => a -> [SQLData]
toRow (Int
numContainedTerms, Int
numContainedTypes, Int
numContainedPatches)

instance FromRow NamespaceStats where
  fromRow :: RowParser NamespaceStats
fromRow = do
    Int
numContainedTerms <- RowParser Int
forall a. FromField a => RowParser a
field
    Int
numContainedTypes <- RowParser Int
forall a. FromField a => RowParser a
field
    Int
numContainedPatches <- RowParser Int
forall a. FromField a => RowParser a
field
    pure $ NamespaceStats {Int
$sel:numContainedTerms:NamespaceStats :: Int
$sel:numContainedTypes:NamespaceStats :: Int
$sel:numContainedPatches:NamespaceStats :: Int
numContainedTerms :: Int
numContainedTypes :: Int
numContainedPatches :: Int
..}

instance ToRow (Reflog.Entry CausalHashId Text) where
  toRow :: Entry CausalHashId Text -> [SQLData]
toRow (Reflog.Entry UTCTime
time CausalHashId
fromRootCausalHash CausalHashId
toRootCausalHash Text
reason) =
    (UTCTime, CausalHashId, CausalHashId, Text) -> [SQLData]
forall a. ToRow a => a -> [SQLData]
toRow (UTCTime
time, CausalHashId
fromRootCausalHash, CausalHashId
toRootCausalHash, Text
reason)

instance FromRow (Reflog.Entry CausalHashId Text) where
  fromRow :: RowParser (Entry CausalHashId Text)
fromRow = do
    UTCTime
time <- RowParser UTCTime
forall a. FromField a => RowParser a
field
    CausalHashId
fromRootCausalHash <- RowParser CausalHashId
forall a. FromField a => RowParser a
field
    CausalHashId
toRootCausalHash <- RowParser CausalHashId
forall a. FromField a => RowParser a
field
    Text
reason <- RowParser Text
forall a. FromField a => RowParser a
field
    pure $ Reflog.Entry {Text
UTCTime
CausalHashId
time :: UTCTime
fromRootCausalHash :: CausalHashId
toRootCausalHash :: CausalHashId
reason :: Text
$sel:time:Entry :: UTCTime
$sel:fromRootCausalHash:Entry :: CausalHashId
$sel:toRootCausalHash:Entry :: CausalHashId
$sel:reason:Entry :: Text
..}