{-# LANGUAGE OverloadedStrings #-}

module Unison.Codebase.Editor.AuthorInfo where

import Crypto.Random (getRandomBytes)
import Data.ByteString (unpack)
import Data.Foldable qualified as Foldable
import Data.Map qualified as Map
import Data.Text (Text)
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.Hashing.V2.Convert qualified as H
import Unison.Prelude (MonadIO, Word8)
import Unison.Reference qualified as Reference
import Unison.Runtime.IOSource qualified as IOSource
import Unison.Term (Term)
import Unison.Term qualified as Term
import Unison.Type (Type)
import Unison.Type qualified as Type
import Unison.Var (Var)
import Unison.Var qualified as Var
import UnliftIO (liftIO)

data AuthorInfo v a = AuthorInfo
  {forall v a. AuthorInfo v a -> (Id, Term v a, Type v a)
guid, forall v a. AuthorInfo v a -> (Id, Term v a, Type v a)
author, forall v a. AuthorInfo v a -> (Id, Term v a, Type v a)
copyrightHolder :: (Reference.Id, Term v a, Type v a)}

createAuthorInfo :: forall m v a. (MonadIO m) => (Var v) => a -> Text -> m (AuthorInfo v a)
createAuthorInfo :: forall (m :: * -> *) v a.
(MonadIO m, Var v) =>
a -> Text -> m (AuthorInfo v a)
createAuthorInfo a
a Text
t = [Word8] -> AuthorInfo v a
createAuthorInfo' ([Word8] -> AuthorInfo v a)
-> (ByteString -> [Word8]) -> ByteString -> AuthorInfo v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
unpack (ByteString -> AuthorInfo v a)
-> m ByteString -> m (AuthorInfo v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ByteString
forall byteArray. ByteArray byteArray => Int -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
32)
  where
    createAuthorInfo' :: [Word8] -> AuthorInfo v a
    createAuthorInfo' :: [Word8] -> AuthorInfo v a
createAuthorInfo' [Word8]
bytes =
      let (Id
guidRef, Term v a
guidTerm) =
            Text -> Type v a -> Term v a -> (Id, Term v a)
hashAndWrangle Text
"guid" Type v a
guidType (Term v a -> (Id, Term v a)) -> Term v a -> (Id, Term v a)
forall a b. (a -> b) -> a -> b
$
              a -> Term v a -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
                a
a
                (a -> ConstructorReference -> Term v a
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor a
a (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
guidTypeRef ConstructorId
0))
                ( a -> Term v a -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.app
                    a
a
                    (a -> Text -> Term v a
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.builtin a
a Text
"Bytes.fromList")
                    (a -> [Term v a] -> Term v a
forall v a vt at ap.
Ord v =>
a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.list a
a ((Word8 -> Term v a) -> [Word8] -> [Term v a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> ConstructorId -> Term v a
forall v a vt at ap.
Ord v =>
a -> ConstructorId -> Term2 vt at ap v a
Term.nat a
a (ConstructorId -> Term v a)
-> (Word8 -> ConstructorId) -> Word8 -> Term v a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ConstructorId
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [Word8]
bytes))
                )

          (Id
authorRef, Term v a
authorTerm) =
            Text -> Type v a -> Term v a -> (Id, Term v a)
hashAndWrangle Text
"author" Type v a
authorType (Term v a -> (Id, Term v a)) -> Term v a -> (Id, Term v a)
forall a b. (a -> b) -> a -> b
$
              Term v a -> [(a, Term v a)] -> Term v a
forall v vt at ap a.
Ord v =>
Term2 vt at ap v a
-> [(a, Term2 vt at ap v a)] -> Term2 vt at ap v a
Term.apps
                (a -> ConstructorReference -> Term v a
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor a
a (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
authorTypeRef ConstructorId
0))
                [ (a
a, a -> TypeReference -> Term v a
forall v a vt at ap.
Ord v =>
a -> TypeReference -> Term2 vt at ap v a
Term.ref a
a (Id -> TypeReference
forall h t. Id' h -> Reference' t h
Reference.DerivedId Id
guidRef)),
                  (a
a, a -> Text -> Term v a
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.text a
a Text
t)
                ]

          (Id
chRef, Term v a
chTerm) =
            Text -> Type v a -> Term v a -> (Id, Term v a)
hashAndWrangle Text
"copyrightHolder" Type v a
chType (Term v a -> (Id, Term v a)) -> Term v a -> (Id, Term v a)
forall a b. (a -> b) -> a -> b
$
              Term v a -> [(a, Term v a)] -> Term v a
forall v vt at ap a.
Ord v =>
Term2 vt at ap v a
-> [(a, Term2 vt at ap v a)] -> Term2 vt at ap v a
Term.apps
                (a -> ConstructorReference -> Term v a
forall v a vt at ap.
Ord v =>
a -> ConstructorReference -> Term2 vt at ap v a
Term.constructor a
a (TypeReference -> ConstructorId -> ConstructorReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
chTypeRef ConstructorId
0))
                [ (a
a, a -> TypeReference -> Term v a
forall v a vt at ap.
Ord v =>
a -> TypeReference -> Term2 vt at ap v a
Term.ref a
a (Id -> TypeReference
forall h t. Id' h -> Reference' t h
Reference.DerivedId Id
guidRef)),
                  (a
a, a -> Text -> Term v a
forall v a vt at ap. Ord v => a -> Text -> Term2 vt at ap v a
Term.text a
a Text
t)
                ]
       in (Id, Term v a, Type v a)
-> (Id, Term v a, Type v a)
-> (Id, Term v a, Type v a)
-> AuthorInfo v a
forall v a.
(Id, Term v a, Type v a)
-> (Id, Term v a, Type v a)
-> (Id, Term v a, Type v a)
-> AuthorInfo v a
AuthorInfo
            (Id
guidRef, Term v a
guidTerm, Type v a
guidType)
            (Id
authorRef, Term v a
authorTerm, Type v a
authorType)
            (Id
chRef, Term v a
chTerm, Type v a
chType)
    hashAndWrangle ::
      Text ->
      Type v a ->
      Term v a ->
      (Reference.Id, Term v a)
    hashAndWrangle :: Text -> Type v a -> Term v a -> (Id, Term v a)
hashAndWrangle Text
v Type v a
typ Term v a
tm =
      case Map v (Id, Term v a, Type v a, ())
-> [(Id, Term v a, Type v a, ())]
forall a. Map v a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (Map v (Id, Term v a, Type v a, ())
 -> [(Id, Term v a, Type v a, ())])
-> Map v (Id, Term v a, Type v a, ())
-> [(Id, Term v a, Type v a, ())]
forall a b. (a -> b) -> a -> b
$ Map v (Term v a, Type v a, ())
-> Map v (Id, Term v a, Type v a, ())
forall v a extra.
Var v =>
Map v (Term v a, Type v a, extra)
-> Map v (Id, Term v a, Type v a, extra)
H.hashTermComponents (v -> (Term v a, Type v a, ()) -> Map v (Term v a, Type v a, ())
forall k a. k -> a -> Map k a
Map.singleton (Text -> v
forall v. Var v => Text -> v
Var.named Text
v) (Term v a
tm, Type v a
typ, ())) of
        [(Id
id, Term v a
tm, Type v a
_tp, ())] -> (Id
id, Term v a
tm)
        [(Id, Term v a, Type v a, ())]
_ -> [Char] -> (Id, Term v a)
forall a. HasCallStack => [Char] -> a
error [Char]
"hashAndWrangle: Expected a single definition."
    (Type v a
chType, TypeReference
chTypeRef) = (a -> TypeReference -> Type v a
forall v a. Ord v => a -> TypeReference -> Type v a
Type.ref a
a TypeReference
chTypeRef, TypeReference
IOSource.copyrightHolderRef)
    (Type v a
authorType, TypeReference
authorTypeRef) = (a -> TypeReference -> Type v a
forall v a. Ord v => a -> TypeReference -> Type v a
Type.ref a
a TypeReference
authorTypeRef, TypeReference
IOSource.authorRef)
    (Type v a
guidType, TypeReference
guidTypeRef) = (a -> TypeReference -> Type v a
forall v a. Ord v => a -> TypeReference -> Type v a
Type.ref a
a TypeReference
guidTypeRef, TypeReference
IOSource.guidRef)