{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Codec.Candid.Infer where

import qualified Data.Vector as V
import Control.Monad
import Data.Void
import Data.List
import Prettyprinter

import Codec.Candid.Types

inferTypes :: [Value] -> Either String [Type Void]
inferTypes :: [Value] -> Either String [Type Void]
inferTypes = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Either String (Type Void)
inferTyp

inferTyp :: Value -> Either String (Type Void)
inferTyp :: Value -> Either String (Type Void)
inferTyp (NumV Scientific
v) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Scientific
v forall a. Ord a => a -> a -> Bool
>= Scientific
0 then forall a. Type a
NatT else forall a. Type a
IntT
inferTyp (BoolV Bool
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
BoolT
inferTyp (NatV Natural
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
NatT
inferTyp (Nat8V Word8
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Nat8T
inferTyp (Nat16V Word16
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Nat16T
inferTyp (Nat32V Word32
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Nat32T
inferTyp (Nat64V Word64
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Nat64T
inferTyp (IntV Integer
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
IntT
inferTyp (Int8V Int8
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Int8T
inferTyp (Int16V Int16
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Int16T
inferTyp (Int32V Int32
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Int32T
inferTyp (Int64V Int64
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Int64T
inferTyp (Float32V Float
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Float32T
inferTyp (Float64V Double
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Float64T
inferTyp (TextV Text
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
TextT
inferTyp Value
NullV = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
NullT
inferTyp Value
ReservedV = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
ReservedT
inferTyp (OptV Maybe Value
Nothing) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Type a -> Type a
OptT forall a. Type a
EmptyT
inferTyp (OptV (Just Value
v)) = forall a. Type a -> Type a
OptT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String (Type Void)
inferTyp Value
v
inferTyp (VecV Vector Value
vs) = forall a. Type a -> Type a
VecT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Either String (Type Void)
inferTyp (forall a. Vector a -> [a]
V.toList Vector Value
vs) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Type Void] -> Either String (Type Void)
lubs)
inferTyp (RecV [(FieldName, Value)]
fs) = forall a. Fields a -> Type a
RecT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ (FieldName
fn,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either String (Type Void)
inferTyp Value
t | (FieldName
fn, Value
t) <- [(FieldName, Value)]
fs ]
inferTyp (VariantV FieldName
f Value
v) = do
    Type Void
t <- Value -> Either String (Type Void)
inferTyp Value
v
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Fields a -> Type a
VariantT [ (FieldName
f, Type Void
t) ]
inferTyp (TupV [Value]
vs) = forall a. [Type a] -> Type a
tupT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Either String (Type Void)
inferTyp [Value]
vs
inferTyp (FuncV Principal
_ Text
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. MethodType a -> Type a
FuncT (forall a. [Type a] -> [Type a] -> Bool -> Bool -> MethodType a
MethodType [] [] Bool
False Bool
False)) -- no principal type
inferTyp (ServiceV Principal
_) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [(Text, MethodType a)] -> Type a
ServiceT []) -- no principal type
inferTyp (PrincipalV Principal
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
PrincipalT
inferTyp Value
FutureV = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
FutureT
inferTyp (BlobV ByteString
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
BlobT
inferTyp (AnnV Value
_ Type Void
t) = forall (m :: * -> *) a. Monad m => a -> m a
return Type Void
t -- Maybe do type checking?

lubs :: [Type Void] -> Either String (Type Void)
lubs :: [Type Void] -> Either String (Type Void)
lubs = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Type Void -> Type Void -> Either String (Type Void)
lub forall a. Type a
EmptyT

lub :: Type Void -> Type Void -> Either String (Type Void)
lub :: Type Void -> Type Void -> Either String (Type Void)
lub Type Void
ReservedT Type Void
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
ReservedT
lub Type Void
_ Type Void
ReservedT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
ReservedT
lub Type Void
EmptyT Type Void
t = forall (m :: * -> *) a. Monad m => a -> m a
return Type Void
t
lub Type Void
t Type Void
EmptyT = forall (m :: * -> *) a. Monad m => a -> m a
return Type Void
t
lub Type Void
NatT Type Void
IntT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
IntT
lub Type Void
IntT Type Void
NatT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
IntT
lub Type Void
NullT (OptT Type Void
t) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Type a -> Type a
OptT Type Void
t)
lub (OptT Type Void
t) Type Void
NullT = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Type a -> Type a
OptT Type Void
t)
lub (OptT Type Void
t1) (OptT Type Void
t2) = forall a. Type a -> Type a
OptT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Void -> Type Void -> Either String (Type Void)
lub Type Void
t1 Type Void
t2
lub (VecT Type Void
t1) (VecT Type Void
t2) = forall a. Type a -> Type a
VecT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Void -> Type Void -> Either String (Type Void)
lub Type Void
t1 Type Void
t2
lub (RecT [(FieldName, Type Void)]
fs1) (RecT [(FieldName, Type Void)]
fs2) = forall a. Fields a -> Type a
RecT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {t}.
Ord t =>
[(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go (forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst [(FieldName, Type Void)]
fs1) (forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst [(FieldName, Type Void)]
fs2)
  where
    go :: [(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go [] [(t, Type Void)]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go [(t, Type Void)]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go ((t
f1, Type Void
v1):[(t, Type Void)]
fs1) ((t
f2,Type Void
v2):[(t, Type Void)]
fs2)
        | t
f1 forall a. Ord a => a -> a -> Bool
< t
f2   = [(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go [(t, Type Void)]
fs1 ((t
f2,Type Void
v2)forall a. a -> [a] -> [a]
:[(t, Type Void)]
fs2)
        | t
f1 forall a. Ord a => a -> a -> Bool
> t
f2   = [(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go ((t
f1,Type Void
v1)forall a. a -> [a] -> [a]
:[(t, Type Void)]
fs1) [(t, Type Void)]
fs2
        | Bool
otherwise = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((t
f1,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Void -> Type Void -> Either String (Type Void)
lub Type Void
v1 Type Void
v2) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go [(t, Type Void)]
fs1 [(t, Type Void)]
fs2
lub (VariantT [(FieldName, Type Void)]
fs1) (VariantT [(FieldName, Type Void)]
fs2) = forall a. Fields a -> Type a
VariantT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {t}.
Ord t =>
[(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go (forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst [(FieldName, Type Void)]
fs1) (forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst [(FieldName, Type Void)]
fs2)
  where
    go :: [(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go [] [(t, Type Void)]
fs = forall (m :: * -> *) a. Monad m => a -> m a
return [(t, Type Void)]
fs
    go [(t, Type Void)]
fs [] = forall (m :: * -> *) a. Monad m => a -> m a
return [(t, Type Void)]
fs
    go ((t
f1, Type Void
v1):[(t, Type Void)]
fs1) ((t
f2,Type Void
v2):[(t, Type Void)]
fs2)
        | t
f1 forall a. Ord a => a -> a -> Bool
< t
f2   = ((t
f1,Type Void
v1) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go [(t, Type Void)]
fs1 ((t
f2,Type Void
v2)forall a. a -> [a] -> [a]
:[(t, Type Void)]
fs2)
        | t
f1 forall a. Ord a => a -> a -> Bool
> t
f2   = ((t
f2,Type Void
v2) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go ((t
f1,Type Void
v1)forall a. a -> [a] -> [a]
:[(t, Type Void)]
fs1) [(t, Type Void)]
fs2
        | Bool
otherwise = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((t
f1,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type Void -> Type Void -> Either String (Type Void)
lub Type Void
v1 Type Void
v2) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(t, Type Void)]
-> [(t, Type Void)] -> Either String [(t, Type Void)]
go [(t, Type Void)]
fs1 [(t, Type Void)]
fs2

-- the reflexive cases
lub Type Void
NatT Type Void
NatT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
NatT
lub Type Void
Nat8T Type Void
Nat8T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Nat8T
lub Type Void
Nat16T Type Void
Nat16T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Nat16T
lub Type Void
Nat32T Type Void
Nat32T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Nat32T
lub Type Void
Nat64T Type Void
Nat64T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Nat64T
lub Type Void
IntT Type Void
IntT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
IntT
lub Type Void
Int8T Type Void
Int8T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Int8T
lub Type Void
Int16T Type Void
Int16T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Int16T
lub Type Void
Int32T Type Void
Int32T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Int32T
lub Type Void
Int64T Type Void
Int64T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Int64T
lub Type Void
Float32T Type Void
Float32T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Float32T
lub Type Void
Float64T Type Void
Float64T = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
Float64T
lub Type Void
BoolT Type Void
BoolT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
BoolT
lub Type Void
TextT Type Void
TextT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
TextT
lub Type Void
NullT Type Void
NullT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
NullT
lub Type Void
BlobT Type Void
BlobT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
BlobT
lub Type Void
PrincipalT Type Void
PrincipalT = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Type a
PrincipalT

-- The shorthands
lub Type Void
BlobT t :: Type Void
t@(VecT Type Void
_) = Type Void -> Type Void -> Either String (Type Void)
lub (forall a. Type a -> Type a
VecT forall a. Type a
Nat8T) Type Void
t
lub t :: Type Void
t@(VecT Type Void
_) Type Void
BlobT = Type Void -> Type Void -> Either String (Type Void)
lub (forall a. Type a -> Type a
VecT forall a. Type a
Nat8T) Type Void
t

-- failure
lub Type Void
t1 Type Void
t2 = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Doc Any
"Incompatible types: " forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Type Void
t1 forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc Any
" and " forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Type Void
t2