GMapKey.daml

-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
daml 1.2
module Main where

import DA.Generics
import DA.Next.Map
import DA.List
import DA.Text

data Test = Test
   { field1 : Int
   , field2 : Text
   } deriving (Eq, Generic, Show)

data A
  = C1 Int
  | C2 Text
  deriving (Eq, Generic, Show)

class GMapKey (f : * -> *) where
    gKeyToText : f a -> Text
    gKeyFromText : Text -> f a

instance MapKey c => GMapKey (K1 i c) where
    gKeyToText (K1 x) = keyToText x
    gKeyFromText t = K1 (keyFromText t)

instance GMapKey f => GMapKey (M1 i t f) where
    gKeyToText (M1 x) = gKeyToText x
    gKeyFromText t = M1 (gKeyFromText t)

gKeyToText' : (Generic a rep, GMapKey rep) => a -> Text
gKeyToText' = gKeyToText . from

gKeyFromText' : (Generic a rep, GMapKey rep) => Text -> a
gKeyFromText' = to . gKeyFromText

instance (GMapKey f, GMapKey g) => GMapKey (f :*: g) where
    gKeyToText (P1 f g) = "(" <> gKeyToText f <> ")(" <> gKeyToText g <> ")"
    gKeyFromText t = case split t of
        (a, b) -> P1 (gKeyFromText a) (gKeyFromText b)

split : Text -> (Text, Text)
split (explode -> ("(" :: r)) = go 0 "" r
split t = error $ "Failed to parse " <> t

go : Int -> Text -> [Text] -> (Text, Text)
go i l ("("::r) = go (i + 1) (l <> "(") r
go 0 l (")"::r) = (l, implode $ init (tail r))
go i l (")"::r) = go (i - 1) (l <> ")") r
go i l (c::r) = go i (l <> c) r
go i l [] = error "Unexpected end"

instance (GMapKey f, GMapKey g) => GMapKey (f :+: g) where
    gKeyToText (L1 a) = "0" <> gKeyToText a
    gKeyToText (R1 b) = "1" <> gKeyToText b
    gKeyFromText t = case explode t of
      ("0" :: t') -> L1 (gKeyFromText $ implode t')
      ("1" :: t') -> R1 (gKeyFromText $ implode t')
      _ -> error $ "Failed to parse, expected 0 or 1: " <> t


instance MapKey Test where
    keyToText = gKeyToText'
    keyFromText = gKeyFromText'

instance MapKey A where
    keyToText = gKeyToText'
    keyFromText = gKeyFromText'

test = scenario do
  debug (keyToText $ Test 1 "a")
  debug (keyFromText $ keyToText $ Test 1 "a" : Test)
  debug (keyToText $ C1 2)
  debug (keyToText $ C2 "a")
  debug (keyFromText $ keyToText $ C1 2 : A)
  debug (keyFromText $ keyToText $ C2 "a" : A)