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

-- | 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.Category
  ( Parser
  , run
  -- * Combinators
  , arr
  , (>->)
  , fail
  , integer
  -- TODO bitString
  , octetString
  , octetStringSingleton
  , null
  , oid
  , utf8String
  , printableString
  , sequenceOf
  , sequence
  , index
  , 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 (bimap,second)
import Data.Bytes (Bytes)
import Data.Int (Int64)
import Data.Primitive (SmallArray,SmallMutableArray)
import Data.Text.Short (ShortText)
import Data.Word (Word32,Word8)

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


newtype Parser a b = P { forall a b. Parser a b -> a -> Path -> Either Path (b, Path)
unP :: a -> Path -> Either Path (b, Path) }

instance Functor (Parser a) where
  fmap :: forall a b. (a -> b) -> Parser a a -> Parser a b
fmap a -> b
f (P a -> Path -> Either Path (a, Path)
k) = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \a
v Path
p -> case a -> Path -> Either Path (a, Path)
k a
v Path
p of
    Right (a
x, Path
p') -> forall a b. b -> Either a b
Right (a -> b
f a
x, Path
p')
    Left Path
err -> forall a b. a -> Either a b
Left Path
err

instance Applicative (Parser a) where
  pure :: forall a. a -> Parser a a
pure a
x = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \a
_ Path
p -> forall a b. b -> Either a b
Right (a
x, Path
p)
  (P a -> Path -> Either Path (a -> b, Path)
g) <*> :: forall a b. Parser a (a -> b) -> Parser a a -> Parser a b
<*> (P a -> Path -> Either Path (a, Path)
h) = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \a
v Path
p -> case a -> Path -> Either Path (a -> b, Path)
g a
v Path
p of
    Right (a -> b
f, Path
_) -> case a -> Path -> Either Path (a, Path)
h a
v Path
p of
      Right (a
x, Path
p') -> forall a b. b -> Either a b
Right (a -> b
f a
x, Path
p')
      Left Path
err -> forall a b. a -> Either a b
Left Path
err
    Left Path
err -> forall a b. a -> Either a b
Left Path
err

arr :: (a -> Maybe b) -> Parser a b
arr :: forall a b. (a -> Maybe b) -> Parser a b
arr a -> Maybe b
f = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \a
v Path
p -> case a -> Maybe b
f a
v of
  Just b
v' -> forall a b. b -> Either a b
Right (b
v', Path
p)
  Maybe b
Nothing -> forall a b. a -> Either a b
Left Path
p

(>->) :: Parser a b -> Parser b c -> Parser a c
(P a -> Path -> Either Path (b, Path)
f) >-> :: forall a b c. Parser a b -> Parser b c -> Parser a c
>-> (P b -> Path -> Either Path (c, Path)
g) = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \a
v Path
p -> case a -> Path -> Either Path (b, Path)
f a
v Path
p of
  Right (b
v', Path
p') -> b -> Path -> Either Path (c, Path)
g b
v' Path
p'
  Left Path
err -> forall a b. a -> Either a b
Left Path
err

-- instance Monad Parser where
--   a >>= k = P $ \p -> unP a p >>= \x -> unP (k x) p

instance Alternative (Parser a) where
  empty :: forall a. Parser a a
empty = forall a a. Parser a a
fail
  P a -> Path -> Either Path (a, Path)
f <|> :: forall a. Parser a a -> Parser a a -> Parser a a
<|> (P a -> Path -> Either Path (a, Path)
g) = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \a
v Path
p -> case a -> Path -> Either Path (a, Path)
f a
v Path
p of
    Right (a, Path)
r -> forall a b. b -> Either a b
Right (a, Path)
r
    Left Path
err1 -> case a -> Path -> Either Path (a, Path)
g a
v Path
p of
      Right (a, Path)
r -> forall a b. b -> Either a b
Right (a, Path)
r
      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 b -> a -> Either Path b
run :: forall a b. Parser a b -> a -> Either Path b
run Parser a b
r a
v = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Path -> Path
reverse forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. Parser a b -> a -> Path -> Either Path (b, Path)
unP Parser a b
r a
v Path
Nil

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

unresolved :: (Bytes -> Either String a) -> Bytes -> Path -> Either Path (a, Path)
unresolved :: forall a.
(Bytes -> Either String a)
-> Bytes -> Path -> Either Path (a, Path)
unresolved Bytes -> Either String a
f Bytes
bs Path
p = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b. a -> b -> a
const Path
p) (,Path
p) (Bytes -> Either String a
f Bytes
bs)

integer :: Parser Value Int64
integer :: Parser Value Int64
integer = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> case Value
v of
  Value{contents :: Value -> Contents
contents=Integer Int64
n} -> forall a b. b -> Either a b
Right (Int64
n, Path
p)
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a.
(Bytes -> Either String a)
-> Bytes -> Path -> Either Path (a, Path)
unresolved Bytes -> Either String Int64
Ber.decodeInteger Bytes
bytes Path
p
  Value
_ -> forall a b. a -> Either a b
Left Path
p

octetString :: Parser Value Bytes
octetString :: Parser Value Bytes
octetString = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> case Value
v of
  Value{contents :: Value -> Contents
contents=OctetString Bytes
bs} -> forall a b. b -> Either a b
Right (Bytes
bs, Path
p)
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a.
(Bytes -> Either String a)
-> Bytes -> Path -> Either Path (a, Path)
unresolved Bytes -> Either String Bytes
Ber.decodeOctetString Bytes
bytes Path
p
  Value
_ -> forall a b. a -> Either a b
Left Path
p

-- | Variant of 'octetString' that expects the @OctetString@ to have
-- exactly one byte. Returns the value of the byte.
octetStringSingleton :: Parser Value Word8
octetStringSingleton :: Parser Value Word8
octetStringSingleton = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> case Value
v of
  Value{contents :: Value -> Contents
contents=OctetString Bytes
bs} -> case Bytes -> Int
Bytes.length Bytes
bs of
    Int
1 -> forall a b. b -> Either a b
Right (Bytes -> Int -> Word8
Bytes.unsafeIndex Bytes
bs Int
0, Path
p)
    Int
_ -> forall a b. a -> Either a b
Left Path
p
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> do
    (Bytes
bs,Path
p') <- forall a.
(Bytes -> Either String a)
-> Bytes -> Path -> Either Path (a, Path)
unresolved Bytes -> Either String Bytes
Ber.decodeOctetString Bytes
bytes Path
p
    case Bytes -> Int
Bytes.length Bytes
bs of
      Int
1 -> forall a b. b -> Either a b
Right (Bytes -> Int -> Word8
Bytes.unsafeIndex Bytes
bs Int
0, Path
p')
      Int
_ -> forall a b. a -> Either a b
Left Path
p'
  Value
_ -> forall a b. a -> Either a b
Left Path
p

null :: Parser Value ()
null :: Parser Value ()
null = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> case Value
v of
  Value{contents :: Value -> Contents
contents=Contents
Null} -> forall a b. b -> Either a b
Right ((), Path
p)
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a.
(Bytes -> Either String a)
-> Bytes -> Path -> Either Path (a, Path)
unresolved Bytes -> Either String ()
Ber.decodeNull Bytes
bytes Path
p
  Value
_ -> forall a b. a -> Either a b
Left Path
p

oid :: Parser Value Oid
oid :: Parser Value Oid
oid = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> case Value
v of
  Value{contents :: Value -> Contents
contents=ObjectIdentifier Oid
objId} -> forall a b. b -> Either a b
Right (Oid
objId, Path
p)
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a.
(Bytes -> Either String a)
-> Bytes -> Path -> Either Path (a, Path)
unresolved Bytes -> Either String Oid
Ber.decodeObjectId Bytes
bytes Path
p
  Value
_ -> forall a b. a -> Either a b
Left Path
p

utf8String :: Parser Value ShortText
utf8String :: Parser Value ShortText
utf8String = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> case Value
v of
  Value{contents :: Value -> Contents
contents=Utf8String ShortText
str} -> forall a b. b -> Either a b
Right (ShortText
str, Path
p)
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a.
(Bytes -> Either String a)
-> Bytes -> Path -> Either Path (a, Path)
unresolved Bytes -> Either String ShortText
Ber.decodeUtf8String Bytes
bytes Path
p
  Value
_ -> forall a b. a -> Either a b
Left Path
p

printableString :: Parser Value ShortText
printableString :: Parser Value ShortText
printableString = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> case Value
v of
  Value{contents :: Value -> Contents
contents=PrintableString ShortText
str} -> forall a b. b -> Either a b
Right (ShortText
str, Path
p)
  Value{contents :: Value -> Contents
contents=Unresolved Bytes
bytes} -> forall a.
(Bytes -> Either String a)
-> Bytes -> Path -> Either Path (a, Path)
unresolved Bytes -> Either String ShortText
Ber.decodePrintableString Bytes
bytes Path
p
  Value
_ -> forall a b. a -> Either a b
Left Path
p

sequenceOf :: forall a. Parser Value a -> Parser Value (SmallArray a)
sequenceOf :: forall a. Parser Value a -> Parser Value (SmallArray a)
sequenceOf Parser Value a
k = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> case Value
v of
  Value{tagNumber :: Value -> Word32
tagNumber=Word32
16, contents :: Value -> Contents
contents=Constructed SmallArray Value
vals} -> 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 (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (,Path
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 b. a -> Either a b
Left Path
p
  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 b. Parser a b -> a -> Path -> Either Path (b, Path)
unP Parser Value 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, Path
_) -> 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 :: Parser Value (SmallArray Value)
sequence :: Parser Value (SmallArray Value)
sequence = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> case Value
v of
  Value{contents :: Value -> Contents
contents=Constructed SmallArray Value
vals} -> forall a b. b -> Either a b
Right (SmallArray Value
vals, Path
p)
  Value
_ -> forall a b. a -> Either a b
Left Path
p

index :: Int -> Parser (SmallArray a) a
index :: forall a. Int -> Parser (SmallArray a) a
index Int
ix = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \SmallArray a
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 a
vals
    then forall a b. b -> Either a b
Right (forall a. SmallArray a -> Int -> a
PM.indexSmallArray SmallArray a
vals Int
ix, Path
p')
    else forall a b. a -> Either a b
Left Path
p'

withTag :: Class -> Word32 -> Parser Value Value
withTag :: Class -> Word32 -> Parser Value Value
withTag Class
cls Word32
num = forall a b. (a -> Path -> Either Path (b, Path)) -> Parser a b
P forall a b. (a -> b) -> a -> b
$ \Value
v Path
p -> 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 b. b -> Either a b
Right (Value
v, Class -> Word32 -> Path -> Path
Tag Class
cls Word32
num Path
p)
  Value
_ -> forall a b. a -> Either a b
Left Path
p

chooseTag :: [(Class, Word32, Parser Value a)] -> Parser Value a
chooseTag :: forall a. [(Class, Word32, Parser Value a)] -> Parser Value a
chooseTag [(Class, Word32, Parser Value a)]
tab = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall a a. Parser a a
fail (forall {c}. (Class, Word32, Parser Value c) -> Parser Value c
adapt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Class, Word32, Parser Value a)]
tab)
  where
  adapt :: (Class, Word32, Parser Value c) -> Parser Value c
adapt (Class
cls, Word32
num, Parser Value c
k) = Class -> Word32 -> Parser Value Value
withTag Class
cls Word32
num forall a b c. Parser a b -> Parser b c -> Parser a c
>-> Parser Value c
k


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