{- Writes a binary serialized package registry for the Elm compiler to consume.

  Takes Elm upstream code from:
  - https://github.com/elm/compiler/blob/master/builder/src/Deps/Registry.hs
  - https://github.com/elm/compiler/blob/master/compiler/src/Elm/Package.hs
-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Elm2Nix.PackagesSnapshot
  ( snapshot
  ) where

import Control.Monad (liftM2, liftM3)
import qualified Data.Binary as Binary
import Data.Binary (Binary, put, get, putWord8, getWord8)
import Data.Binary.Put (putBuilder)
import Data.Binary.Get.Internal (readN)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Word (Word16)
import qualified Data.List as List
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BS

import Elm2Nix.ElmJson (readElmJson, toErrorMessage)


data Name =
  Name
    { Name -> Text
_author :: !Text
    , Name -> Text
_project :: !Text
    }
    deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
/= :: Name -> Name -> Bool
Eq, Eq Name
Eq Name =>
(Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Name -> Name -> Ordering
compare :: Name -> Name -> Ordering
$c< :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
>= :: Name -> Name -> Bool
$cmax :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
min :: Name -> Name -> Name
Ord)

parseName :: (MonadFail m) => Text -> m Name
parseName :: forall (m :: * -> *). MonadFail m => Text -> m Name
parseName Text
n =
  case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"/" Text
n of
    [Text
author, Text
package] -> Name -> m Name
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> m Name) -> Name -> m Name
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Name
Name Text
author Text
package
    [Text]
lst -> String -> m Name
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Name) -> String -> m Name
forall a b. (a -> b) -> a -> b
$ String
"wrong package name: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Text] -> String
forall a. Show a => a -> String
show [Text]
lst

data Package =
  Package
    { Package -> Name
_name :: !Name
    , Package -> Version
_version :: !Version
    }
    deriving (Package -> Package -> Bool
(Package -> Package -> Bool)
-> (Package -> Package -> Bool) -> Eq Package
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Package -> Package -> Bool
== :: Package -> Package -> Bool
$c/= :: Package -> Package -> Bool
/= :: Package -> Package -> Bool
Eq, Eq Package
Eq Package =>
(Package -> Package -> Ordering)
-> (Package -> Package -> Bool)
-> (Package -> Package -> Bool)
-> (Package -> Package -> Bool)
-> (Package -> Package -> Bool)
-> (Package -> Package -> Package)
-> (Package -> Package -> Package)
-> Ord Package
Package -> Package -> Bool
Package -> Package -> Ordering
Package -> Package -> Package
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Package -> Package -> Ordering
compare :: Package -> Package -> Ordering
$c< :: Package -> Package -> Bool
< :: Package -> Package -> Bool
$c<= :: Package -> Package -> Bool
<= :: Package -> Package -> Bool
$c> :: Package -> Package -> Bool
> :: Package -> Package -> Bool
$c>= :: Package -> Package -> Bool
>= :: Package -> Package -> Bool
$cmax :: Package -> Package -> Package
max :: Package -> Package -> Package
$cmin :: Package -> Package -> Package
min :: Package -> Package -> Package
Ord)

data Version =
  Version
    { Version -> Word16
_major :: {-# UNPACK #-} !Word16
    , Version -> Word16
_minor :: {-# UNPACK #-} !Word16
    , Version -> Word16
_patch :: {-# UNPACK #-} !Word16
    }
    deriving (Version -> Version -> Bool
(Version -> Version -> Bool)
-> (Version -> Version -> Bool) -> Eq Version
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Version -> Version -> Bool
== :: Version -> Version -> Bool
$c/= :: Version -> Version -> Bool
/= :: Version -> Version -> Bool
Eq, Eq Version
Eq Version =>
(Version -> Version -> Ordering)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Bool)
-> (Version -> Version -> Version)
-> (Version -> Version -> Version)
-> Ord Version
Version -> Version -> Bool
Version -> Version -> Ordering
Version -> Version -> Version
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Version -> Version -> Ordering
compare :: Version -> Version -> Ordering
$c< :: Version -> Version -> Bool
< :: Version -> Version -> Bool
$c<= :: Version -> Version -> Bool
<= :: Version -> Version -> Bool
$c> :: Version -> Version -> Bool
> :: Version -> Version -> Bool
$c>= :: Version -> Version -> Bool
>= :: Version -> Version -> Bool
$cmax :: Version -> Version -> Version
max :: Version -> Version -> Version
$cmin :: Version -> Version -> Version
min :: Version -> Version -> Version
Ord)

parseVersion :: (MonadFail m) => Text -> m Version
parseVersion :: forall (m :: * -> *). MonadFail m => Text -> m Version
parseVersion Text
x =
    case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"." Text
x of
      [Text
major, Text
minor, Text
patch] ->
        Version -> m Version
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version -> m Version) -> Version -> m Version
forall a b. (a -> b) -> a -> b
$ Word16 -> Word16 -> Word16 -> Version
Version
                  (String -> Word16
forall a. Read a => String -> a
read (Text -> String
Text.unpack Text
major))
                  (String -> Word16
forall a. Read a => String -> a
read (Text -> String
Text.unpack Text
minor))
                  (String -> Word16
forall a. Read a => String -> a
read (Text -> String
Text.unpack Text
patch))
      [Text]
_ ->
        String -> m Version
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failure parsing version"

data KnownVersions =
  KnownVersions
    { KnownVersions -> Version
_newest :: Version
    , KnownVersions -> [Version]
_previous :: ![Version]
    }

data Registry =
  Registry
    { Registry -> Int
_count :: !Int
    , Registry -> Map Name KnownVersions
_versions :: !(Map Name KnownVersions)
    }

putUnder256 :: BS.ByteString -> Binary.Put
putUnder256 :: ByteString -> Put
putUnder256 ByteString
bs =
  do  Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs))
      Builder -> Put
putBuilder (ByteString -> Builder
BS.byteString ByteString
bs)

getUnder256 :: Binary.Get (BS.ByteString)
getUnder256 :: Get ByteString
getUnder256 =
  do  Word8
word <- Get Word8
getWord8
      let !n :: Int
n = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
word
      Int -> (ByteString -> ByteString) -> Get ByteString
forall a. Int -> (ByteString -> a) -> Get a
readN Int
n ByteString -> ByteString
forall a. a -> a
id

instance Binary Name where
  get :: Get Name
get =
    (Text -> Text -> Name) -> Get Text -> Get Text -> Get Name
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Text -> Text -> Name
Name
      ((ByteString -> Text) -> Get ByteString -> Get Text
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
Text.decodeUtf8 Get ByteString
getUnder256)
      ((ByteString -> Text) -> Get ByteString -> Get Text
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
Text.decodeUtf8 Get ByteString
getUnder256)

  put :: Name -> Put
put (Name Text
author Text
project) =
    do ByteString -> Put
putUnder256 (Text -> ByteString
Text.encodeUtf8 Text
author)
       ByteString -> Put
putUnder256 (Text -> ByteString
Text.encodeUtf8 Text
project)

instance Binary Package where
  get :: Get Package
get =
    (Name -> Version -> Package)
-> Get Name -> Get Version -> Get Package
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Name -> Version -> Package
Package Get Name
forall t. Binary t => Get t
get Get Version
forall t. Binary t => Get t
get

  put :: Package -> Put
put (Package Name
name Version
version) =
    do  Name -> Put
forall t. Binary t => t -> Put
put Name
name
        Version -> Put
forall t. Binary t => t -> Put
put Version
version

instance Binary Version where
  get :: Get Version
get =
    do  Word8
word <- Get Word8
getWord8
        if Word8
word Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
255
          then (Word16 -> Word16 -> Word16 -> Version)
-> Get Word16 -> Get Word16 -> Get Word16 -> Get Version
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 Word16 -> Word16 -> Word16 -> Version
Version Get Word16
forall t. Binary t => Get t
get Get Word16
forall t. Binary t => Get t
get Get Word16
forall t. Binary t => Get t
get
          else
            do  Word16
minor <- (Word8 -> Word16) -> Get Word8 -> Get Word16
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word8
getWord8
                Word16
patch <- (Word8 -> Word16) -> Get Word8 -> Get Word16
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Get Word8
getWord8
                Version -> Get Version
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> Word16 -> Word16 -> Version
Version (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
word) Word16
minor Word16
patch)

  put :: Version -> Put
put (Version Word16
major Word16
minor Word16
patch) =
    if Word16
major Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
256 Bool -> Bool -> Bool
&& Word16
minor Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
256 Bool -> Bool -> Bool
&& Word16
patch Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
256 then
      do  Word8 -> Put
putWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
major)
          Word8 -> Put
putWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
minor)
          Word8 -> Put
putWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
patch)
    else
      do  Word8 -> Put
putWord8 Word8
255
          Word16 -> Put
forall t. Binary t => t -> Put
put Word16
major
          Word16 -> Put
forall t. Binary t => t -> Put
put Word16
minor
          Word16 -> Put
forall t. Binary t => t -> Put
put Word16
patch

instance Binary KnownVersions where
  get :: Get KnownVersions
get = (Version -> [Version] -> KnownVersions)
-> Get Version -> Get [Version] -> Get KnownVersions
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Version -> [Version] -> KnownVersions
KnownVersions Get Version
forall t. Binary t => Get t
get Get [Version]
forall t. Binary t => Get t
get
  put :: KnownVersions -> Put
put (KnownVersions Version
a [Version]
b) = Version -> Put
forall t. Binary t => t -> Put
put Version
a Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Version] -> Put
forall t. Binary t => t -> Put
put [Version]
b

instance Binary Registry where
  get :: Get Registry
get = (Int -> Map Name KnownVersions -> Registry)
-> Get Int -> Get (Map Name KnownVersions) -> Get Registry
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Int -> Map Name KnownVersions -> Registry
Registry Get Int
forall t. Binary t => Get t
get Get (Map Name KnownVersions)
forall t. Binary t => Get t
get
  put :: Registry -> Put
put (Registry Int
a Map Name KnownVersions
b) = Int -> Put
forall t. Binary t => t -> Put
put Int
a Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Map Name KnownVersions -> Put
forall t. Binary t => t -> Put
put Map Name KnownVersions
b

snapshot :: FilePath -> FilePath -> IO ()
snapshot :: String -> String -> IO ()
snapshot String
elmJson String
writeTo = do
  [Dep]
deps <- (Elm2NixError -> [Dep])
-> ([Dep] -> [Dep]) -> Either Elm2NixError [Dep] -> [Dep]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> [Dep]
forall a. HasCallStack => String -> a
error (String -> [Dep])
-> (Elm2NixError -> String) -> Elm2NixError -> [Dep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Elm2NixError -> String
toErrorMessage) [Dep] -> [Dep]
forall a. a -> a
id (Either Elm2NixError [Dep] -> [Dep])
-> IO (Either Elm2NixError [Dep]) -> IO [Dep]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either Elm2NixError [Dep])
readElmJson String
elmJson
  let
    parseDep :: Dep -> m (Name, [Version])
parseDep (String
k, String
v) = do
      Name
name <- Text -> m Name
forall (m :: * -> *). MonadFail m => Text -> m Name
parseName (String -> Text
Text.pack String
k)
      Version
version <- Text -> m Version
forall (m :: * -> *). MonadFail m => Text -> m Version
parseVersion (String -> Text
Text.pack String
v)
      (Name, [Version]) -> m (Name, [Version])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
name, [Version
version])
  Map Name KnownVersions
packages <- Map Name [Version] -> Map Name KnownVersions
toKnownVersions (Map Name [Version] -> Map Name KnownVersions)
-> ([(Name, [Version])] -> Map Name [Version])
-> [(Name, [Version])]
-> Map Name KnownVersions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Version] -> [Version] -> [Version])
-> [(Name, [Version])] -> Map Name [Version]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Version] -> [Version] -> [Version]
forall a. Semigroup a => a -> a -> a
(<>) ([(Name, [Version])] -> Map Name KnownVersions)
-> IO [(Name, [Version])] -> IO (Map Name KnownVersions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dep -> IO (Name, [Version])) -> [Dep] -> IO [(Name, [Version])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Dep -> IO (Name, [Version])
forall {m :: * -> *}. MonadFail m => Dep -> m (Name, [Version])
parseDep [Dep]
deps
  let size :: Int
size = (KnownVersions -> Int -> Int)
-> Int -> Map Name KnownVersions -> Int
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr' KnownVersions -> Int -> Int
addEntry Int
0 Map Name KnownVersions
packages
      registry :: Registry
registry = Int -> Map Name KnownVersions -> Registry
Registry Int
size Map Name KnownVersions
packages

      addEntry :: KnownVersions -> Int -> Int
      addEntry :: KnownVersions -> Int -> Int
addEntry (KnownVersions Version
_ [Version]
vs) Int
count =
        Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Version] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Version]
vs

  String -> Registry -> IO ()
forall a. Binary a => String -> a -> IO ()
Binary.encodeFile String
writeTo Registry
registry

toKnownVersions ::  Map.Map Name [Version] -> Map.Map Name KnownVersions
toKnownVersions :: Map Name [Version] -> Map Name KnownVersions
toKnownVersions  =
  ([Version] -> KnownVersions)
-> Map Name [Version] -> Map Name KnownVersions
forall a b. (a -> b) -> Map Name a -> Map Name b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Version]
versions ->
          case (Version -> Version -> Ordering) -> [Version] -> [Version]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy ((Version -> Version -> Ordering) -> Version -> Version -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) [Version]
versions of
            Version
v:[Version]
vs -> Version -> [Version] -> KnownVersions
KnownVersions Version
v [Version]
vs
            [] -> KnownVersions
forall a. HasCallStack => a
undefined
       )