{-# language BangPatterns #-}
{-# language DeriveFunctor #-}
{-# language DerivingStrategies #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language RankNTypes #-}
{-# language ScopedTypeVariables #-}
module Asn.Resolve
( Parser
, run
, MemberParser
, fail
, integer
, octetString
, null
, oid
, utf8String
, printableString
, sequence
, index
, sequenceOf
, withTag
, chooseTag
, Path(..)
, 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
| Tag !Class !Word32 !Path
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