{-# language BangPatterns #-}
{-# language DeriveFunctor #-}
{-# language DerivingStrategies #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}

-- | Transform between Haskell values and the 'Value' type. The instance you
-- write for 'ToAsn' and 'FromAsn' assume a schema. I (Eric) think this is
-- reasonable because I expect each schema to be one-to-one with data types.
module Asn.Resolve
  ( Parser
  , run
  , MemberParser
  -- * Combinators
  , fail
  , integer
  -- TODO bitString
  , octetString
  , null
  , oid
  , utf8String
  , printableString
  , sequence
  , index
  , sequenceOf
  , withTag
  , chooseTag
  -- * Error Breadcrumbs
  , Path(..)
  -- * Re-Exports
  , Value
  , Contents
  , Class(..)
  ) where

import Prelude hiding (fail,null,reverse,null,sequence)

import Asn.Ber (Value(..), Contents(..), Class(..))
import Asn.Oid (Oid)
import Control.Applicative (Alternative(..))
import Control.Monad.ST (ST, runST)
import Data.Bifunctor (first)
import Data.Bytes (Bytes)
import Data.Int (Int64)
import Data.Primitive (SmallArray,SmallMutableArray)
import Data.Text.Short (ShortText)
import Data.Word (Word32)

import qualified Data.Primitive as PM
import qualified Asn.Ber as Ber


newtype Parser a = P { forall a. Parser a -> Path -> Either Path a
unP :: Path -> Either Path a }
  deriving stock (forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Parser b -> Parser a
$c<$ :: forall a b. a -> Parser b -> Parser a
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
Functor)

instance Applicative Parser where
  pure :: forall a. a -> Parser a
pure a
x = forall a. (Path -> Either Path a) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Path
_ -> forall a b. b -> Either a b
Right a
x
  Parser (a -> b)
a <*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
<*> Parser a
b = forall a. (Path -> Either Path a) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Path
p -> forall a. Parser a -> Path -> Either Path a
unP Parser (a -> b)
a Path
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Parser a -> Path -> Either Path a
unP Parser a
b Path
p

instance Monad Parser where
  Parser a
a >>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
k = forall a. (Path -> Either Path a) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Path
p -> forall a. Parser a -> Path -> Either Path a
unP Parser a
a Path
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x -> forall a. Parser a -> Path -> Either Path a
unP (a -> Parser b
k a
x) Path
p

instance Alternative Parser where
  empty :: forall a. Parser a
empty = forall a. Parser a
fail
  Parser a
a <|> :: forall a. Parser a -> Parser a -> Parser a
<|> Parser a
b = forall a. (Path -> Either Path a) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Path
p -> case forall a. Parser a -> Path -> Either Path a
unP Parser a
a Path
p of
    Right a
val -> forall a b. b -> Either a b
Right a
val
    Left Path
err1 -> case forall a. Parser a -> Path -> Either Path a
unP Parser a
b Path
p of
      Right a
val -> forall a b. b -> Either a b
Right a
val
      Left Path
err2 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Path -> Path -> Path
longerPath Path
err1 Path
err2

run :: Parser a -> Either Path a
run :: forall a. Parser a -> Either Path a
run Parser a
r = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Path -> Path
reverse forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Path -> Either Path a
unP Parser a
r Path
Nil

newtype MemberParser a = MP
  { forall a.
MemberParser a -> SmallArray Value -> Path -> Either Path a
unMP :: SmallArray Value -> Path -> Either Path a }
  deriving stock forall a b. a -> MemberParser b -> MemberParser a
forall a b. (a -> b) -> MemberParser a -> MemberParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MemberParser b -> MemberParser a
$c<$ :: forall a b. a -> MemberParser b -> MemberParser a
fmap :: forall a b. (a -> b) -> MemberParser a -> MemberParser b
$cfmap :: forall a b. (a -> b) -> MemberParser a -> MemberParser b
Functor

instance Applicative MemberParser where
  pure :: forall a. a -> MemberParser a
pure a
a = forall a.
(SmallArray Value -> Path -> Either Path a) -> MemberParser a
MP (\SmallArray Value
_ Path
_ -> forall a b. b -> Either a b
Right a
a)
  MP SmallArray Value -> Path -> Either Path (a -> b)
f <*> :: forall a b.
MemberParser (a -> b) -> MemberParser a -> MemberParser b
<*> MP SmallArray Value -> Path -> Either Path a
g = forall a.
(SmallArray Value -> Path -> Either Path a) -> MemberParser a
MP forall a b. (a -> b) -> a -> b
$ \SmallArray Value
p Path
mbrs ->
    SmallArray Value -> Path -> Either Path (a -> b)
f SmallArray Value
p Path
mbrs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SmallArray Value -> Path -> Either Path a
g SmallArray Value
p Path
mbrs


fail :: Parser a
fail :: forall a. Parser a
fail = forall a. (Path -> Either Path a) -> Parser a
P forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left

unresolved :: (Bytes -> Either String a) -> Bytes -> Parser a
unresolved :: forall a. (Bytes -> Either String a) -> Bytes -> Parser a
unresolved Bytes -> Either String a
f Bytes
bytes = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Parser a
fail) forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Either String a
f Bytes
bytes)

integer :: Value -> Parser Int64
integer :: Value -> Parser Int64
integer = \case
  Value{contents :: Value -> Contents
contents=Integer Int64
n} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
n
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a. (Bytes -> Either String a) -> Bytes -> Parser a
unresolved Bytes -> Either String Int64
Ber.decodeInteger Bytes
bytes
  Value
_ -> forall a. Parser a
fail

octetString :: Value -> Parser Bytes
octetString :: Value -> Parser Bytes
octetString = \case
  Value{contents :: Value -> Contents
contents=OctetString Bytes
bs} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bytes
bs
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a. (Bytes -> Either String a) -> Bytes -> Parser a
unresolved Bytes -> Either String Bytes
Ber.decodeOctetString Bytes
bytes
  Value
_ -> forall a. Parser a
fail

null :: Value -> Parser ()
null :: Value -> Parser ()
null = \case
  Value{contents :: Value -> Contents
contents=Contents
Null} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a. (Bytes -> Either String a) -> Bytes -> Parser a
unresolved Bytes -> Either String ()
Ber.decodeNull Bytes
bytes
  Value
_ -> forall a. Parser a
fail

oid :: Value -> Parser Oid
oid :: Value -> Parser Oid
oid = \case
  Value{contents :: Value -> Contents
contents=ObjectIdentifier Oid
objId} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Oid
objId
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a. (Bytes -> Either String a) -> Bytes -> Parser a
unresolved Bytes -> Either String Oid
Ber.decodeObjectId Bytes
bytes
  Value
_ -> forall a. Parser a
fail

utf8String :: Value -> Parser ShortText
utf8String :: Value -> Parser ShortText
utf8String = \case
  Value{contents :: Value -> Contents
contents=Utf8String ShortText
str} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
str
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a. (Bytes -> Either String a) -> Bytes -> Parser a
unresolved Bytes -> Either String ShortText
Ber.decodeUtf8String Bytes
bytes
  Value
_ -> forall a. Parser a
fail

printableString :: Value -> Parser ShortText
printableString :: Value -> Parser ShortText
printableString = \case
  Value{contents :: Value -> Contents
contents=PrintableString ShortText
str} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
str
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a. (Bytes -> Either String a) -> Bytes -> Parser a
unresolved Bytes -> Either String ShortText
Ber.decodePrintableString Bytes
bytes
  Value
_ -> forall a. Parser a
fail

sequenceOf :: forall a. (Value -> Parser a) -> Value -> Parser (SmallArray a)
sequenceOf :: forall a. (Value -> Parser a) -> Value -> Parser (SmallArray a)
sequenceOf Value -> Parser a
k = \case
  Value{tagNumber :: Value -> Word32
tagNumber=Word32
16, contents :: Value -> Contents
contents=Constructed SmallArray Value
vals} -> forall a. (Path -> Either Path a) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Path
p -> forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    SmallMutableArray s a
dst <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray (forall a. SmallArray a -> Int
PM.sizeofSmallArray SmallArray Value
vals) forall a. HasCallStack => a
undefined
    forall s.
SmallArray Value
-> SmallMutableArray s a
-> Path
-> Int
-> ST s (Either Path (SmallArray a))
go SmallArray Value
vals SmallMutableArray s a
dst Path
p Int
0
  Value
_ -> forall a. Parser a
fail
  where
  go :: forall s.
       SmallArray Value
    -> SmallMutableArray s a
    -> Path
    -> Int
    -> ST s (Either Path (SmallArray a))
  go :: forall s.
SmallArray Value
-> SmallMutableArray s a
-> Path
-> Int
-> ST s (Either Path (SmallArray a))
go SmallArray Value
src SmallMutableArray s a
dst Path
p0 Int
ix
    | Int
ix forall a. Ord a => a -> a -> Bool
< forall a. SmallArray a -> Int
PM.sizeofSmallArray SmallArray Value
src = do
      let val :: Value
val = forall a. SmallArray a -> Int -> a
PM.indexSmallArray SmallArray Value
src Int
ix
      case forall a. Parser a -> Path -> Either Path a
unP (Value -> Parser a
k Value
val) (Int -> Path -> Path
Index Int
ix Path
p0) of
        Left Path
err -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Path
err
        Right a
rval -> do
          forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s a
dst Int
ix a
rval
          forall s.
SmallArray Value
-> SmallMutableArray s a
-> Path
-> Int
-> ST s (Either Path (SmallArray a))
go SmallArray Value
src SmallMutableArray s a
dst Path
p0 (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
    | Bool
otherwise = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray s a
dst

sequence :: MemberParser a -> Value -> Parser a
sequence :: forall a. MemberParser a -> Value -> Parser a
sequence MemberParser a
k = \case
  Value{contents :: Value -> Contents
contents=Constructed SmallArray Value
vals} -> forall a. (Path -> Either Path a) -> Parser a
P (forall a.
MemberParser a -> SmallArray Value -> Path -> Either Path a
unMP MemberParser a
k SmallArray Value
vals)
  Value
_ -> forall a. Parser a
fail

index :: Int -> (Value -> Parser a) -> MemberParser a
index :: forall a. Int -> (Value -> Parser a) -> MemberParser a
index Int
ix Value -> Parser a
k = forall a.
(SmallArray Value -> Path -> Either Path a) -> MemberParser a
MP forall a b. (a -> b) -> a -> b
$ \SmallArray Value
vals Path
p ->
  let p' :: Path
p' = Int -> Path -> Path
Index Int
ix Path
p in
  if Int
ix forall a. Ord a => a -> a -> Bool
< forall a. SmallArray a -> Int
PM.sizeofSmallArray SmallArray Value
vals
    then forall a. Parser a -> Path -> Either Path a
unP (Value -> Parser a
k forall a b. (a -> b) -> a -> b
$ forall a. SmallArray a -> Int -> a
PM.indexSmallArray SmallArray Value
vals Int
ix) Path
p'
    else forall a b. a -> Either a b
Left Path
p'

withTag :: Class -> Word32 -> (Value -> Parser a) -> Value -> Parser a
withTag :: forall a.
Class -> Word32 -> (Value -> Parser a) -> Value -> Parser a
withTag Class
cls Word32
num Value -> Parser a
k Value
v = case Value
v of
  Value{Class
tagClass :: Value -> Class
tagClass :: Class
tagClass,Word32
tagNumber :: Word32
tagNumber :: Value -> Word32
tagNumber}
    | Class
tagClass forall a. Eq a => a -> a -> Bool
== Class
cls Bool -> Bool -> Bool
&& Word32
tagNumber forall a. Eq a => a -> a -> Bool
== Word32
num ->
      forall a. (Path -> Either Path a) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Path
p -> forall a. Parser a -> Path -> Either Path a
unP (Value -> Parser a
k Value
v) (Class -> Word32 -> Path -> Path
Tag Class
cls Word32
num Path
p)
  Value
_ -> forall a. Parser a
fail

chooseTag :: [(Class, Word32, Value -> Parser a)] -> Value -> Parser a
chooseTag :: forall a. [(Class, Word32, Value -> Parser a)] -> Value -> Parser a
chooseTag [(Class, Word32, Value -> Parser a)]
tab0 v :: Value
v@Value{Class
tagClass :: Class
tagClass :: Value -> Class
tagClass,Word32
tagNumber :: Word32
tagNumber :: Value -> Word32
tagNumber} = forall {a}. [(Class, Word32, Value -> Parser a)] -> Parser a
go [(Class, Word32, Value -> Parser a)]
tab0
  where
  go :: [(Class, Word32, Value -> Parser a)] -> Parser a
go [] = forall a. Parser a
fail
  go ((Class
cls, Word32
num, Value -> Parser a
k) : [(Class, Word32, Value -> Parser a)]
rest)
    | Class
cls forall a. Eq a => a -> a -> Bool
== Class
tagClass Bool -> Bool -> Bool
&& Word32
num forall a. Eq a => a -> a -> Bool
== Word32
tagNumber
      = forall a. (Path -> Either Path a) -> Parser a
P forall a b. (a -> b) -> a -> b
$ \Path
p -> forall a. Parser a -> Path -> Either Path a
unP (Value -> Parser a
k Value
v) (Class -> Word32 -> Path -> Path
Tag Class
cls Word32
num Path
p)
    | Bool
otherwise = [(Class, Word32, Value -> Parser a)] -> Parser a
go [(Class, Word32, Value -> Parser a)]
rest

data Path
  = Nil
  | Index {-# UNPACK #-} !Int !Path
  -- ^ into the nth field of a constructed type
  | Tag !Class !Word32 !Path
  -- ^ into a specific tag
  deriving stock (Path -> Path -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq, Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Path] -> ShowS
$cshowList :: [Path] -> ShowS
show :: Path -> String
$cshow :: Path -> String
showsPrec :: Int -> Path -> ShowS
$cshowsPrec :: Int -> Path -> ShowS
Show)

longerPath :: Path -> Path -> Path
longerPath :: Path -> Path -> Path
longerPath Path
a Path
b = if Int -> Path -> Int
pathSize Int
0 Path
a forall a. Ord a => a -> a -> Bool
< Int -> Path -> Int
pathSize Int
0 Path
b then Path
b else Path
a
  where
  pathSize :: Int -> Path -> Int
  pathSize :: Int -> Path -> Int
pathSize !Int
acc Path
Nil = Int
acc
  pathSize !Int
acc (Index Int
_ Path
rest) = Int -> Path -> Int
pathSize (Int
1 forall a. Num a => a -> a -> a
+ Int
acc) Path
rest
  pathSize !Int
acc (Tag Class
_ Word32
_ Path
rest) = Int -> Path -> Int
pathSize (Int
1 forall a. Num a => a -> a -> a
+ Int
acc) Path
rest

reverse :: Path -> Path
reverse :: Path -> Path
reverse = Path -> Path -> Path
go Path
Nil
  where
  go :: Path -> Path -> Path
go !Path
acc Path
Nil = Path
acc
  go !Path
acc (Index Int
ix Path
rest) = Path -> Path -> Path
go (Int -> Path -> Path
Index Int
ix Path
acc) Path
rest
  go !Path
acc (Tag Class
cls Word32
num Path
rest) = Path -> Path -> Path
go (Class -> Word32 -> Path -> Path
Tag Class
cls Word32
num Path
acc) Path
rest