{-# LANGUAGE CPP
, ScopedTypeVariables
, GADTs
, DataKinds
, KindSignatures
, GeneralizedNewtypeDeriving
, TypeOperators
, FlexibleContexts
, FlexibleInstances
, OverloadedStrings
, PatternGuards
, Rank2Types
#-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
module Language.Hakaru.Syntax.TypeCheck
(
TypeCheckError
, TypeCheckMonad(), runTCM, unTCM
, TypeCheckMode(..)
, inferable
, mustCheck
, TypedAST(..)
, onTypedAST, onTypedASTM, elimTypedAST
, inferType
, checkType
) where
import Prelude hiding (id, (.))
import Control.Category
import Data.Proxy (KProxy(..))
import Data.Text (pack, Text())
import Data.Either (partitionEithers)
import qualified Data.IntMap as IM
import qualified Data.Traversable as T
import qualified Data.List.NonEmpty as L
import qualified Data.Foldable as F
import qualified Data.Sequence as S
import qualified Data.Vector as V
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..), (<$>))
import Data.Monoid (Monoid(..))
#endif
import qualified Language.Hakaru.Parser.AST as U
import Data.Number.Nat (fromNat)
import Language.Hakaru.Syntax.TypeCheck.TypeCheckMonad
import Language.Hakaru.Syntax.TypeCheck.Unification
import Language.Hakaru.Syntax.IClasses
import Language.Hakaru.Types.DataKind (Hakaru(..), HData', HBool)
import Language.Hakaru.Types.Sing
import Language.Hakaru.Types.Coercion
import Language.Hakaru.Types.HClasses
( HEq, hEq_Sing, HOrd, hOrd_Sing, HSemiring, hSemiring_Sing
, hRing_Sing, sing_HRing, hFractional_Sing, sing_HFractional
, sing_NonNegative, hDiscrete_Sing
, HIntegrable(..)
, HRadical(..), HContinuous(..))
import Language.Hakaru.Syntax.ABT
import Language.Hakaru.Syntax.Datum
import Language.Hakaru.Syntax.Reducer
import Language.Hakaru.Syntax.AST
import Language.Hakaru.Syntax.AST.Sing
(sing_Literal, sing_MeasureOp)
import Language.Hakaru.Pretty.Concrete (prettyType, prettyTypeT)
import Language.Hakaru.Syntax.TypeOf (typeOf)
import Language.Hakaru.Syntax.Prelude (triv)
inferable :: U.AST -> Bool
inferable :: AST -> Bool
inferable = Bool -> Bool
not (Bool -> Bool) -> (AST -> Bool) -> AST -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AST -> Bool
mustCheck
mustCheck :: U.AST -> Bool
mustCheck :: AST -> Bool
mustCheck AST
e = AST
-> (Variable 'U -> Bool)
-> (Term (MetaABT SourceSpan Term) 'U -> Bool)
-> Bool
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) r.
ABT syn abt =>
abt '[] a -> (Variable a -> r) -> (syn abt a -> r) -> r
caseVarSyn AST
e (Bool -> Variable 'U -> Bool
forall a b. a -> b -> a
const Bool
False) Term (MetaABT SourceSpan Term) 'U -> Bool
go
where
go :: U.MetaTerm -> Bool
go :: Term (MetaABT SourceSpan Term) 'U -> Bool
go (U.Lam_ SSing
_ U_ABT '[ 'U] 'U
e2) = U_ABT '[ 'U] 'U -> Bool
mustCheck' U_ABT '[ 'U] 'U
e2
go (U.App_ AST
_ AST
_) = Bool
False
go (U.Let_ AST
_ U_ABT '[ 'U] 'U
e2) = U_ABT '[ 'U] 'U -> Bool
mustCheck' U_ABT '[ 'U] 'U
e2
go (U.Ann_ SSing
_ AST
_) = Bool
False
go (U.CoerceTo_ Some2 Coercion
_ AST
_) = Bool
False
go (U.UnsafeTo_ Some2 Coercion
_ AST
_) = Bool
False
go (U.PrimOp_ PrimOp
_ [AST]
_) = Bool
False
go (U.ArrayOp_ ArrayOp
_ [AST]
es) = (AST -> Bool) -> [AST] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all AST -> Bool
mustCheck [AST]
es
go (U.NaryOp_ NaryOp
_ [AST]
es) = (AST -> Bool) -> [AST] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all AST -> Bool
mustCheck [AST]
es
go (U.Superpose_ NonEmpty (AST, AST)
pes) = ((AST, AST) -> Bool) -> NonEmpty (AST, AST) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (AST -> Bool
mustCheck (AST -> Bool) -> ((AST, AST) -> AST) -> (AST, AST) -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (AST, AST) -> AST
forall a b. (a, b) -> b
snd) NonEmpty (AST, AST)
pes
go (U.Literal_ Some1 Literal
_) = Bool
False
go (U.Pair_ AST
e1 AST
e2) = AST -> Bool
mustCheck AST
e1 Bool -> Bool -> Bool
&& AST -> Bool
mustCheck AST
e2
go (U.Array_ AST
_ U_ABT '[ 'U] 'U
e1) = U_ABT '[ 'U] 'U -> Bool
mustCheck' U_ABT '[ 'U] 'U
e1
go (U.ArrayLiteral_ [AST]
es) = (AST -> Bool) -> [AST] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all AST -> Bool
mustCheck [AST]
es
go (U.Datum_ Datum (MetaABT SourceSpan Term)
_) = Bool
True
go (U.Case_ AST
_ [Branch_ (MetaABT SourceSpan Term)]
_) = Bool
True
go (U.Dirac_ AST
e1) = AST -> Bool
mustCheck AST
e1
go (U.MBind_ AST
_ U_ABT '[ 'U] 'U
e2) = U_ABT '[ 'U] 'U -> Bool
mustCheck' U_ABT '[ 'U] 'U
e2
go (U.Plate_ AST
_ U_ABT '[ 'U] 'U
e2) = U_ABT '[ 'U] 'U -> Bool
mustCheck' U_ABT '[ 'U] 'U
e2
go (U.Chain_ AST
_ AST
e2 U_ABT '[ 'U] 'U
e3) = AST -> Bool
mustCheck AST
e2 Bool -> Bool -> Bool
&& U_ABT '[ 'U] 'U -> Bool
mustCheck' U_ABT '[ 'U] 'U
e3
go (U.MeasureOp_ SomeOp MeasureOp
_ [AST]
_) = Bool
False
go (U.Integrate_ AST
_ AST
_ U_ABT '[ 'U] 'U
_) = Bool
False
go (U.Summate_ AST
_ AST
_ U_ABT '[ 'U] 'U
_) = Bool
False
go (U.Product_ AST
_ AST
_ U_ABT '[ 'U] 'U
_) = Bool
False
go (U.Bucket_ AST
_ AST
_ Reducer xs (MetaABT SourceSpan Term) 'U
_) = Bool
False
go Term (MetaABT SourceSpan Term) 'U
U.Reject_ = Bool
True
go (U.Transform_ Transform as x
tr SArgs (MetaABT SourceSpan Term) as
es ) =
case (Transform as x
tr, SArgs (MetaABT SourceSpan Term) as
es) of
(Transform as x
Expect , (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* (List2 ToUntyped vars varsu, U_ABT varsu 'U)
_ U.:* SArgs (MetaABT SourceSpan Term) args
U.End)
-> AST -> Bool
mustCheck U_ABT varsu 'U
AST
e1
(Transform as x
Observe , (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* (List2 ToUntyped vars varsu, U_ABT varsu 'U)
_ U.:* SArgs (MetaABT SourceSpan Term) args
U.End)
-> AST -> Bool
mustCheck U_ABT varsu 'U
AST
e1
(Transform as x
MCMC , (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e2) U.:* SArgs (MetaABT SourceSpan Term) args
U.End)
-> AST -> Bool
mustCheck U_ABT varsu 'U
AST
e1 Bool -> Bool -> Bool
&& AST -> Bool
mustCheck U_ABT varsu 'U
AST
e2
(Disint TransformImpl
_ , (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End)
-> AST -> Bool
mustCheck U_ABT varsu 'U
AST
e1
(Transform as x
Simplify , (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End)
-> AST -> Bool
mustCheck U_ABT varsu 'U
AST
e1
(Transform as x
Summarize, (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End)
-> AST -> Bool
mustCheck U_ABT varsu 'U
AST
e1
(Transform as x
Reparam , (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End)
-> AST -> Bool
mustCheck U_ABT varsu 'U
AST
e1
go U.InjTyped{} = Bool
False
mustCheck'
:: MetaABT U.SourceSpan U.Term '[ 'U.U ] 'U.U
-> Bool
mustCheck' :: U_ABT '[ 'U] 'U -> Bool
mustCheck' U_ABT '[ 'U] 'U
e = U_ABT '[ 'U] 'U -> (Variable 'U -> AST -> Bool) -> Bool
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind U_ABT '[ 'U] 'U
e ((Variable 'U -> AST -> Bool) -> Bool)
-> (Variable 'U -> AST -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \Variable 'U
_ AST
e' -> AST -> Bool
mustCheck AST
e'
inferBinder
:: (ABT Term abt)
=> Sing a
-> MetaABT U.SourceSpan U.Term '[ 'U.U ] 'U.U
-> (forall b. Sing b -> abt '[ a ] b -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinder :: Sing a
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru). Sing b -> abt '[a] b -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinder Sing a
typ U_ABT '[ 'U] 'U
e forall (b :: Hakaru). Sing b -> abt '[a] b -> TypeCheckMonad r
k =
U_ABT '[ 'U] 'U
-> (Variable 'U -> AST -> TypeCheckMonad r) -> TypeCheckMonad r
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind U_ABT '[ 'U] 'U
e ((Variable 'U -> AST -> TypeCheckMonad r) -> TypeCheckMonad r)
-> (Variable 'U -> AST -> TypeCheckMonad r) -> TypeCheckMonad r
forall a b. (a -> b) -> a -> b
$ \Variable 'U
x AST
e1 -> do
let x' :: Variable a
x' = Variable 'U
x {varType :: Sing a
varType = Sing a
typ}
TypedAST Sing b
typ1 abt '[] b
e1' <- Variable a
-> TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt)
forall (a :: Hakaru) b.
Variable a -> TypeCheckMonad b -> TypeCheckMonad b
pushCtx Variable a
x' (AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
e1)
Sing b -> abt '[a] b -> TypeCheckMonad r
forall (b :: Hakaru). Sing b -> abt '[a] b -> TypeCheckMonad r
k Sing b
typ1 (Variable a -> abt '[] b -> abt '[a] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable a
x' abt '[] b
e1')
inferBinders
:: (ABT Term abt)
=> List1 Variable xs
-> U.AST
-> (forall a. Sing a -> abt xs a -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinders :: List1 Variable xs
-> AST
-> (forall (a :: Hakaru). Sing a -> abt xs a -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinders = \List1 Variable xs
xs AST
e forall (a :: Hakaru). Sing a -> abt xs a -> TypeCheckMonad r
k -> do
TypedAST Sing b
typ abt '[] b
e' <- List1 Variable xs
-> TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt)
forall (xs :: [Hakaru]) b.
List1 Variable xs -> TypeCheckMonad b -> TypeCheckMonad b
pushesCtx List1 Variable xs
xs (AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
e)
Sing b -> abt xs b -> TypeCheckMonad r
forall (a :: Hakaru). Sing a -> abt xs a -> TypeCheckMonad r
k Sing b
typ (List1 Variable xs -> abt '[] b -> abt xs b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(xs :: [k]) (b :: k).
ABT syn abt =>
List1 Variable xs -> abt '[] b -> abt xs b
binds_ List1 Variable xs
xs abt '[] b
e')
where
pushesCtx
:: List1 Variable (xs :: [Hakaru])
-> TypeCheckMonad b
-> TypeCheckMonad b
pushesCtx :: List1 Variable xs -> TypeCheckMonad b -> TypeCheckMonad b
pushesCtx List1 Variable xs
Nil1 TypeCheckMonad b
m = TypeCheckMonad b
m
pushesCtx (Cons1 Variable x
x List1 Variable xs
xs) TypeCheckMonad b
m = List1 Variable xs -> TypeCheckMonad b -> TypeCheckMonad b
forall (xs :: [Hakaru]) b.
List1 Variable xs -> TypeCheckMonad b -> TypeCheckMonad b
pushesCtx List1 Variable xs
xs ((Ctx -> Input -> TypeCheckMode -> Either TypeCheckError b)
-> TypeCheckMonad b
forall a.
(Ctx -> Input -> TypeCheckMode -> Either TypeCheckError a)
-> TypeCheckMonad a
TCM (TypeCheckMonad b
-> Ctx -> Input -> TypeCheckMode -> Either TypeCheckError b
forall a.
TypeCheckMonad a
-> Ctx -> Input -> TypeCheckMode -> Either TypeCheckError a
unTCM TypeCheckMonad b
m (Ctx -> Input -> TypeCheckMode -> Either TypeCheckError b)
-> (Ctx -> Ctx)
-> Ctx
-> Input
-> TypeCheckMode
-> Either TypeCheckError b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Variable x -> Ctx -> Ctx
forall k (a :: k).
Variable a -> VarSet (KindOf a) -> VarSet (KindOf a)
insertVarSet Variable x
x))
checkBinder
:: (ABT Term abt)
=> Sing a
-> Sing b
-> MetaABT U.SourceSpan U.Term '[ 'U.U ] 'U.U
-> TypeCheckMonad (abt '[ a ] b)
checkBinder :: Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing a
typ Sing b
eTyp U_ABT '[ 'U] 'U
e =
U_ABT '[ 'U] 'U
-> (Variable 'U -> AST -> TypeCheckMonad (abt '[a] b))
-> TypeCheckMonad (abt '[a] b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind U_ABT '[ 'U] 'U
e ((Variable 'U -> AST -> TypeCheckMonad (abt '[a] b))
-> TypeCheckMonad (abt '[a] b))
-> (Variable 'U -> AST -> TypeCheckMonad (abt '[a] b))
-> TypeCheckMonad (abt '[a] b)
forall a b. (a -> b) -> a -> b
$ \Variable 'U
x AST
e1 -> do
let x' :: Variable a
x' = Variable 'U
x {varType :: Sing a
varType = Sing a
typ}
Variable a
-> TypeCheckMonad (abt '[a] b) -> TypeCheckMonad (abt '[a] b)
forall (a :: Hakaru) b.
Variable a -> TypeCheckMonad b -> TypeCheckMonad b
pushCtx Variable a
x' (Variable a -> abt '[] b -> abt '[a] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable a
x' (abt '[] b -> abt '[a] b)
-> TypeCheckMonad (abt '[] b) -> TypeCheckMonad (abt '[a] b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType Sing b
eTyp AST
e1)
checkBinders
:: (ABT Term abt)
=> List1 Variable xs
-> Sing a
-> U.AST
-> TypeCheckMonad (abt xs a)
checkBinders :: List1 Variable xs -> Sing a -> AST -> TypeCheckMonad (abt xs a)
checkBinders List1 Variable xs
xs Sing a
eTyp AST
e =
case List1 Variable xs
xs of
List1 Variable xs
Nil1 -> Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType Sing a
eTyp AST
e
Cons1 Variable x
x List1 Variable xs
xs' -> Variable x
-> TypeCheckMonad (abt (x : xs) a)
-> TypeCheckMonad (abt (x : xs) a)
forall (a :: Hakaru) b.
Variable a -> TypeCheckMonad b -> TypeCheckMonad b
pushCtx Variable x
x (Variable x -> abt xs a -> abt (x : xs) a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable x
x (abt xs a -> abt (x : xs) a)
-> TypeCheckMonad (abt xs a) -> TypeCheckMonad (abt (x : xs) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 Variable xs -> Sing a -> AST -> TypeCheckMonad (abt xs a)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
List1 Variable xs -> Sing a -> AST -> TypeCheckMonad (abt xs a)
checkBinders List1 Variable xs
xs' Sing a
eTyp AST
e)
inferType
:: forall abt
. (ABT Term abt)
=> U.AST
-> TypeCheckMonad (TypedAST abt)
inferType :: AST -> TypeCheckMonad (TypedAST abt)
inferType = AST -> TypeCheckMonad (TypedAST abt)
inferType_
where
checkType_ :: forall b. Sing b -> U.AST -> TypeCheckMonad (abt '[] b)
checkType_ :: Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ = Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType
inferOneCheckOthers_ ::
[U.AST] -> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers_ :: [AST] -> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers_ = [AST] -> TypeCheckMonad (TypedASTs abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
[AST] -> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers
inferVariable
:: Maybe U.SourceSpan
-> Variable 'U.U
-> TypeCheckMonad (TypedAST abt)
inferVariable :: Maybe SourceSpan -> Variable 'U -> TypeCheckMonad (TypedAST abt)
inferVariable Maybe SourceSpan
sourceSpan (Variable TypeCheckError
hintID Nat
nameID Sing 'U
_) = do
Ctx
ctx <- TypeCheckMonad Ctx
getCtx
case Key
-> IntMap (SomeVariable 'KProxy) -> Maybe (SomeVariable 'KProxy)
forall a. Key -> IntMap a -> Maybe a
IM.lookup (Nat -> Key
fromNat Nat
nameID) (Ctx -> IntMap (SomeVariable 'KProxy)
forall k (kproxy :: KProxy k).
VarSet kproxy -> IntMap (SomeVariable kproxy)
unVarSet Ctx
ctx) of
Just (SomeVariable Variable a
x') ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Sing a -> abt '[] a -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Variable a -> Sing a
forall k (a :: k). Variable a -> Sing a
varType Variable a
x') (Variable a -> abt '[] a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
Variable a -> abt '[] a
var Variable a
x')
Maybe (SomeVariable 'KProxy)
Nothing -> TypeCheckError -> Maybe SourceSpan -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckError -> Maybe SourceSpan -> TypeCheckMonad r
ambiguousFreeVariable TypeCheckError
hintID Maybe SourceSpan
sourceSpan
inferType_ :: U.AST -> TypeCheckMonad (TypedAST abt)
inferType_ :: AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e0 =
let s :: Maybe SourceSpan
s = AST -> Maybe SourceSpan
forall meta k (syn :: ([k] -> k -> *) -> k -> *) (xs :: [k])
(a :: k).
MetaABT meta syn xs a -> Maybe meta
getMetadata AST
e0 in
AST
-> (Variable 'U -> TypeCheckMonad (TypedAST abt))
-> (Term (MetaABT SourceSpan Term) 'U
-> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) r.
ABT syn abt =>
abt '[] a -> (Variable a -> r) -> (syn abt a -> r) -> r
caseVarSyn AST
e0 (Maybe SourceSpan -> Variable 'U -> TypeCheckMonad (TypedAST abt)
inferVariable Maybe SourceSpan
s) (Maybe SourceSpan
-> Term (MetaABT SourceSpan Term) 'U
-> TypeCheckMonad (TypedAST abt)
go Maybe SourceSpan
s)
where
go :: Maybe U.SourceSpan -> U.MetaTerm -> TypeCheckMonad (TypedAST abt)
go :: Maybe SourceSpan
-> Term (MetaABT SourceSpan Term) 'U
-> TypeCheckMonad (TypedAST abt)
go Maybe SourceSpan
sourceSpan Term (MetaABT SourceSpan Term) 'U
t =
case Term (MetaABT SourceSpan Term) 'U
t of
U.Lam_ (U.SSing Sing a
typ) U_ABT '[ 'U] 'U
e -> do
Sing a
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru).
Sing b -> abt '[a] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) r.
ABT Term abt =>
Sing a
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru). Sing b -> abt '[a] b -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinder Sing a
typ U_ABT '[ 'U] 'U
e ((forall (b :: Hakaru).
Sing b -> abt '[a] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (b :: Hakaru).
Sing b -> abt '[a] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing b
typ2 abt '[a] b
e2 ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] (a ':-> b) -> TypedAST abt)
-> abt '[] (a ':-> b)
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing (a ':-> b) -> abt '[] (a ':-> b) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing a -> Sing b -> Sing (a ':-> b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (a ':-> b)
SFun Sing a
typ Sing b
typ2) (abt '[] (a ':-> b) -> TypeCheckMonad (TypedAST abt))
-> abt '[] (a ':-> b) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt (a ':-> b) -> abt '[] (a ':-> b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[ '( '[a], b)] (a ':-> b)
forall (a :: Hakaru) (a :: Hakaru). SCon '[ '( '[a], a)] (a ':-> a)
Lam_ SCon '[ '( '[a], b)] (a ':-> b)
-> SArgs abt '[ '( '[a], b)] -> Term abt (a ':-> b)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[a] b
e2 abt '[a] b -> SArgs abt '[] -> SArgs abt '[ '( '[a], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.App_ AST
e1 AST
e2 -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
Unify2 (':->) (TypedAST abt) b
forall r (x :: Hakaru). Unify2 (':->) r x
unifyFun Sing b
typ1 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru) (b :: Hakaru).
(b ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru) (b :: Hakaru).
(b ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 Sing b
typ3 -> do
abt '[] a
e2' <- Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing a
typ2 AST
e2
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ3 (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[LC (a ':-> b), LC a] b
forall (a :: Hakaru) (b :: Hakaru). SCon '[LC (a ':-> b), LC a] b
App_ SCon '[LC (a ':-> b), LC a] b
-> SArgs abt '[LC (a ':-> b), LC a] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b -> SArgs abt '[LC a] -> SArgs abt '[ '( '[], b), LC a]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] a
e2' abt '[] a -> SArgs abt '[] -> SArgs abt '[LC a]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Let_ AST
e1 U_ABT '[ 'U] 'U
e2 -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
Sing b
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru).
Sing b -> abt '[b] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) r.
ABT Term abt =>
Sing a
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru). Sing b -> abt '[a] b -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinder Sing b
typ1 U_ABT '[ 'U] 'U
e2 ((forall (b :: Hakaru).
Sing b -> abt '[b] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (b :: Hakaru).
Sing b -> abt '[b] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing b
typ2 abt '[b] b
e2' ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ2 (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[LC b, '( '[b], b)] b
forall (a :: Hakaru) (b :: Hakaru). SCon '[LC a, '( '[a], b)] b
Let_ SCon '[LC b, '( '[b], b)] b
-> SArgs abt '[LC b, '( '[b], b)] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[b], b)] -> SArgs abt '[LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[b] b
e2' abt '[b] b -> SArgs abt '[] -> SArgs abt '[ '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Ann_ (U.SSing Sing a
typ1) AST
e1 -> do
Sing a -> abt '[] a -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing a
typ1 (abt '[] a -> TypedAST abt)
-> TypeCheckMonad (abt '[] a) -> TypeCheckMonad (TypedAST abt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing a
typ1 AST
e1
U.PrimOp_ PrimOp
op [AST]
es -> PrimOp -> [AST] -> TypeCheckMonad (TypedAST abt)
inferPrimOp PrimOp
op [AST]
es
U.ArrayOp_ ArrayOp
op [AST]
es -> ArrayOp -> [AST] -> TypeCheckMonad (TypedAST abt)
inferArrayOp ArrayOp
op [AST]
es
U.NaryOp_ NaryOp
op [AST]
es -> do
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
TypedASTs Sing b
typ [abt '[] b]
es' <-
case TypeCheckMode
mode of
TypeCheckMode
StrictMode -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers_ [AST]
es
TypeCheckMode
LaxMode -> Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferLubType Maybe SourceSpan
sourceSpan [AST]
es
TypeCheckMode
UnsafeMode -> Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferLubType Maybe SourceSpan
sourceSpan [AST]
es
NaryOp b
op' <- Sing b -> NaryOp -> TypeCheckMonad (NaryOp b)
forall (a :: Hakaru). Sing a -> NaryOp -> TypeCheckMonad (NaryOp a)
make_NaryOp Sing b
typ NaryOp
op
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (NaryOp b -> Seq (abt '[] b) -> Term abt b
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *).
NaryOp a -> Seq (abt '[] a) -> Term abt a
NaryOp_ NaryOp b
op' (Seq (abt '[] b) -> Term abt b) -> Seq (abt '[] b) -> Term abt b
forall a b. (a -> b) -> a -> b
$ [abt '[] b] -> Seq (abt '[] b)
forall a. [a] -> Seq a
S.fromList [abt '[] b]
es')
U.Literal_ (Some1 Literal i
v) ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] i -> TypedAST abt)
-> abt '[] i
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing i -> abt '[] i -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Literal i -> Sing i
forall (a :: Hakaru). Literal a -> Sing a
sing_Literal Literal i
v) (abt '[] i -> TypeCheckMonad (TypedAST abt))
-> abt '[] i -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt i -> abt '[] i
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Literal i -> Term abt i
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *).
Literal a -> Term abt a
Literal_ Literal i
v)
U.CoerceTo_ (Some2 Coercion i j
c) AST
e1 ->
case Coercion i j -> Maybe (Sing i, Sing j)
forall (a :: Hakaru) (b :: Hakaru).
Coercion a b -> Maybe (Sing a, Sing b)
singCoerceDomCod Coercion i j
c of
Maybe (Sing i, Sing j)
Nothing
| AST -> Bool
inferable AST
e1 -> AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
| Bool
otherwise -> Maybe SourceSpan -> TypeCheckMonad (TypedAST abt)
forall r. Maybe SourceSpan -> TypeCheckMonad r
ambiguousNullCoercion Maybe SourceSpan
sourceSpan
Just (Sing i
dom,Sing j
cod) -> do
abt '[] i
e1' <- Sing i -> AST -> TypeCheckMonad (abt '[] i)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing i
dom AST
e1
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] j -> TypedAST abt)
-> abt '[] j
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing j -> abt '[] j -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing j
cod (abt '[] j -> TypeCheckMonad (TypedAST abt))
-> abt '[] j -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt j -> abt '[] j
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Coercion i j -> SCon '[LC i] j
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> SCon '[LC a] b
CoerceTo_ Coercion i j
c SCon '[LC i] j -> SArgs abt '[LC i] -> Term abt j
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] i
e1' abt '[] i -> SArgs abt '[] -> SArgs abt '[LC i]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.UnsafeTo_ (Some2 Coercion i j
c) AST
e1 ->
case Coercion i j -> Maybe (Sing i, Sing j)
forall (a :: Hakaru) (b :: Hakaru).
Coercion a b -> Maybe (Sing a, Sing b)
singCoerceDomCod Coercion i j
c of
Maybe (Sing i, Sing j)
Nothing
| AST -> Bool
inferable AST
e1 -> AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
| Bool
otherwise -> Maybe SourceSpan -> TypeCheckMonad (TypedAST abt)
forall r. Maybe SourceSpan -> TypeCheckMonad r
ambiguousNullCoercion Maybe SourceSpan
sourceSpan
Just (Sing i
dom,Sing j
cod) -> do
abt '[] j
e1' <- Sing j -> AST -> TypeCheckMonad (abt '[] j)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing j
cod AST
e1
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] i -> TypedAST abt)
-> abt '[] i
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing i -> abt '[] i -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing i
dom (abt '[] i -> TypeCheckMonad (TypedAST abt))
-> abt '[] i -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt i -> abt '[] i
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Coercion i j -> SCon '[LC j] i
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> SCon '[LC b] a
UnsafeFrom_ Coercion i j
c SCon '[LC j] i -> SArgs abt '[LC j] -> Term abt i
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] j
e1' abt '[] j -> SArgs abt '[] -> SArgs abt '[LC j]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.MeasureOp_ (U.SomeOp MeasureOp typs a
op) [AST]
es -> do
let (List1 Sing typs
typs, Sing a
typ1) = MeasureOp typs a -> (List1 Sing typs, Sing a)
forall (typs :: [Hakaru]) (a :: Hakaru).
MeasureOp typs a -> (List1 Sing typs, Sing a)
sing_MeasureOp MeasureOp typs a
op
SArgs abt args
es' <- List1 Sing typs -> [AST] -> TypeCheckMonad (SArgs abt args)
forall (abt :: [Hakaru] -> Hakaru -> *) (typs :: [Hakaru])
(args :: [([Hakaru], Hakaru)]).
(ABT Term abt, typs ~ UnLCs args, args ~ LCs typs) =>
List1 Sing typs -> [AST] -> TypeCheckMonad (SArgs abt args)
checkSArgs List1 Sing typs
typs [AST]
es
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] ('HMeasure a) -> TypedAST abt)
-> abt '[] ('HMeasure a)
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing ('HMeasure a) -> abt '[] ('HMeasure a) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure Sing a
typ1) (abt '[] ('HMeasure a) -> TypeCheckMonad (TypedAST abt))
-> abt '[] ('HMeasure a) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (MeasureOp typs a -> SCon args ('HMeasure a)
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
MeasureOp typs a -> SCon args ('HMeasure a)
MeasureOp_ MeasureOp typs a
op SCon args ('HMeasure a) -> SArgs abt args -> Term abt ('HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ SArgs abt args
es')
U.Pair_ AST
e1 AST
e2 -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
TypedAST Sing b
typ2 abt '[] b
e2' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e2
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] (HPair b b) -> TypedAST abt)
-> abt '[] (HPair b b)
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing (HPair b b) -> abt '[] (HPair b b) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing b -> Sing b -> Sing (HPair b b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (HPair a b)
sPair Sing b
typ1 Sing b
typ2) (abt '[] (HPair b b) -> TypeCheckMonad (TypedAST abt))
-> abt '[] (HPair b b) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt (HPair b b) -> abt '[] (HPair b b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Datum (abt '[]) (HData' (('TyCon "Pair" ':@ b) ':@ b))
-> Term abt (HData' (('TyCon "Pair" ':@ b) ':@ b))
forall (abt :: [Hakaru] -> Hakaru -> *) (t :: HakaruCon).
Datum (abt '[]) (HData' t) -> Term abt (HData' t)
Datum_ (Datum (abt '[]) (HData' (('TyCon "Pair" ':@ b) ':@ b))
-> Term abt (HData' (('TyCon "Pair" ':@ b) ':@ b)))
-> Datum (abt '[]) (HData' (('TyCon "Pair" ':@ b) ':@ b))
-> Term abt (HData' (('TyCon "Pair" ':@ b) ':@ b))
forall a b. (a -> b) -> a -> b
$ Sing b
-> Sing b -> abt '[] b -> abt '[] b -> Datum (abt '[]) (HPair b b)
forall (a :: Hakaru) (b :: Hakaru) (ast :: Hakaru -> *).
Sing a -> Sing b -> ast a -> ast b -> Datum ast (HPair a b)
dPair_ Sing b
typ1 Sing b
typ2 abt '[] b
e1' abt '[] b
e2')
U.Array_ AST
e1 U_ABT '[ 'U] 'U
e2 -> do
abt '[] 'HNat
e1' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e1
Sing 'HNat
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru).
Sing b -> abt '[ 'HNat] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) r.
ABT Term abt =>
Sing a
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru). Sing b -> abt '[a] b -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinder Sing 'HNat
SNat U_ABT '[ 'U] 'U
e2 ((forall (b :: Hakaru).
Sing b -> abt '[ 'HNat] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (b :: Hakaru).
Sing b -> abt '[ 'HNat] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing b
typ2 abt '[ 'HNat] b
e2' ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] ('HArray b) -> TypedAST abt)
-> abt '[] ('HArray b)
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing ('HArray b) -> abt '[] ('HArray b) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing b -> Sing ('HArray b)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray Sing b
typ2) (abt '[] ('HArray b) -> TypeCheckMonad (TypedAST abt))
-> abt '[] ('HArray b) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt ('HArray b) -> abt '[] ('HArray b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (abt '[] 'HNat -> abt '[ 'HNat] b -> Term abt ('HArray b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] 'HNat -> abt '[ 'HNat] a -> Term abt ('HArray a)
Array_ abt '[] 'HNat
e1' abt '[ 'HNat] b
e2')
U.ArrayLiteral_ [AST]
es -> do
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
TypedASTs Sing b
typ [abt '[] b]
es' <-
case TypeCheckMode
mode of
TypeCheckMode
StrictMode -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers_ [AST]
es
TypeCheckMode
LaxMode -> Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferLubType Maybe SourceSpan
sourceSpan [AST]
es
TypeCheckMode
UnsafeMode -> Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferLubType Maybe SourceSpan
sourceSpan [AST]
es
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] ('HArray b) -> TypedAST abt)
-> abt '[] ('HArray b)
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing ('HArray b) -> abt '[] ('HArray b) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing b -> Sing ('HArray b)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray Sing b
typ) (abt '[] ('HArray b) -> TypeCheckMonad (TypedAST abt))
-> abt '[] ('HArray b) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt ('HArray b) -> abt '[] ('HArray b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn ([abt '[] b] -> Term abt ('HArray b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
[abt '[] a] -> Term abt ('HArray a)
ArrayLiteral_ [abt '[] b]
es')
U.Case_ AST
e1 [Branch_ (MetaABT SourceSpan Term)]
branches -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
case TypeCheckMode
mode of
TypeCheckMode
StrictMode -> Sing b
-> abt '[] b
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a
-> abt '[] a
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
inferCaseStrict Sing b
typ1 abt '[] b
e1' [Branch_ (MetaABT SourceSpan Term)]
branches
TypeCheckMode
LaxMode -> Maybe SourceSpan
-> Sing b
-> abt '[] b
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> Sing a
-> abt '[] a
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
inferCaseLax Maybe SourceSpan
sourceSpan Sing b
typ1 abt '[] b
e1' [Branch_ (MetaABT SourceSpan Term)]
branches
TypeCheckMode
UnsafeMode -> Maybe SourceSpan
-> Sing b
-> abt '[] b
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> Sing a
-> abt '[] a
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
inferCaseLax Maybe SourceSpan
sourceSpan Sing b
typ1 abt '[] b
e1' [Branch_ (MetaABT SourceSpan Term)]
branches
U.Dirac_ AST
e1 -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] ('HMeasure b) -> TypedAST abt)
-> abt '[] ('HMeasure b)
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing ('HMeasure b) -> abt '[] ('HMeasure b) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing b -> Sing ('HMeasure b)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure Sing b
typ1) (abt '[] ('HMeasure b) -> TypeCheckMonad (TypedAST abt))
-> abt '[] ('HMeasure b) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure b) -> abt '[] ('HMeasure b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[LC b] ('HMeasure b)
forall (a :: Hakaru). SCon '[LC a] ('HMeasure a)
Dirac SCon '[LC b] ('HMeasure b)
-> SArgs abt '[LC b] -> Term abt ('HMeasure b)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b -> SArgs abt '[] -> SArgs abt '[LC b]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.MBind_ AST
e1 U_ABT '[ 'U] 'U
e2 ->
U_ABT '[ 'U] 'U
-> (Variable 'U -> AST -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind U_ABT '[ 'U] 'U
e2 ((Variable 'U -> AST -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (Variable 'U -> AST -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Variable 'U
x AST
e2' -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ1 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 ->
let x' :: Variable a
x' = Variable 'U -> Sing a -> Variable a
forall (a :: Hakaru). Variable 'U -> Sing a -> Variable a
makeVar Variable 'U
x Sing a
typ2 in
Variable a
-> TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt)
forall (a :: Hakaru) b.
Variable a -> TypeCheckMonad b -> TypeCheckMonad b
pushCtx Variable a
x' (TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ do
TypedAST Sing b
typ3 abt '[] b
e3' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e2'
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ3 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
_ ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] ('HMeasure a) -> TypedAST abt)
-> abt '[] ('HMeasure a)
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ3 (abt '[] ('HMeasure a) -> TypeCheckMonad (TypedAST abt))
-> abt '[] ('HMeasure a) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[LC ('HMeasure a), '( '[a], 'HMeasure a)] ('HMeasure a)
forall (a :: Hakaru) (a :: Hakaru).
SCon '[LC ('HMeasure a), '( '[a], 'HMeasure a)] ('HMeasure a)
MBind SCon '[LC ('HMeasure a), '( '[a], 'HMeasure a)] ('HMeasure a)
-> SArgs abt '[LC ('HMeasure a), '( '[a], 'HMeasure a)]
-> Term abt ('HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[a], b)]
-> SArgs abt '[ '( '[], b), '( '[a], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* Variable a -> abt '[] b -> abt '[a] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable a
x' abt '[] b
e3' abt '[a] b -> SArgs abt '[] -> SArgs abt '[ '( '[a], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Plate_ AST
e1 U_ABT '[ 'U] 'U
e2 ->
U_ABT '[ 'U] 'U
-> (Variable 'U -> AST -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind U_ABT '[ 'U] 'U
e2 ((Variable 'U -> AST -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (Variable 'U -> AST -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Variable 'U
x AST
e2' -> do
abt '[] 'HNat
e1' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e1
let x' :: Variable 'HNat
x' = Variable 'U -> Sing 'HNat -> Variable 'HNat
forall (a :: Hakaru). Variable 'U -> Sing a -> Variable a
makeVar Variable 'U
x Sing 'HNat
SNat
Variable 'HNat
-> TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt)
forall (a :: Hakaru) b.
Variable a -> TypeCheckMonad b -> TypeCheckMonad b
pushCtx Variable 'HNat
x' (TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ do
TypedAST Sing b
typ2 abt '[] b
e3' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e2'
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ2 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ3 ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] ('HMeasure ('HArray a)) -> TypedAST abt)
-> abt '[] ('HMeasure ('HArray a))
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing ('HMeasure ('HArray a))
-> abt '[] ('HMeasure ('HArray a)) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing ('HArray a) -> Sing ('HMeasure ('HArray a))
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure (Sing ('HArray a) -> Sing ('HMeasure ('HArray a)))
-> (Sing a -> Sing ('HArray a))
-> Sing a
-> Sing ('HMeasure ('HArray a))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing a -> Sing ('HArray a)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray (Sing a -> Sing ('HMeasure ('HArray a)))
-> Sing a -> Sing ('HMeasure ('HArray a))
forall a b. (a -> b) -> a -> b
$ Sing a
typ3) (abt '[] ('HMeasure ('HArray a)) -> TypeCheckMonad (TypedAST abt))
-> abt '[] ('HMeasure ('HArray a)) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt ('HMeasure ('HArray a)) -> abt '[] ('HMeasure ('HArray a))
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon
'[LC 'HNat, '( '[ 'HNat], 'HMeasure a)] ('HMeasure ('HArray a))
forall (a :: Hakaru).
SCon
'[LC 'HNat, '( '[ 'HNat], 'HMeasure a)] ('HMeasure ('HArray a))
Plate SCon
'[LC 'HNat, '( '[ 'HNat], 'HMeasure a)] ('HMeasure ('HArray a))
-> SArgs abt '[LC 'HNat, '( '[ 'HNat], 'HMeasure a)]
-> Term abt ('HMeasure ('HArray a))
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HNat
e1' abt '[] 'HNat
-> SArgs abt '[ '( '[ 'HNat], b)]
-> SArgs abt '[LC 'HNat, '( '[ 'HNat], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* Variable 'HNat -> abt '[] b -> abt '[ 'HNat] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable 'HNat
x' abt '[] b
e3' abt '[ 'HNat] b -> SArgs abt '[] -> SArgs abt '[ '( '[ 'HNat], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Chain_ AST
e1 AST
e2 U_ABT '[ 'U] 'U
e3 ->
U_ABT '[ 'U] 'U
-> (Variable 'U -> AST -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind U_ABT '[ 'U] 'U
e3 ((Variable 'U -> AST -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (Variable 'U -> AST -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Variable 'U
x AST
e3' -> do
abt '[] 'HNat
e1' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e1
TypedAST Sing b
typ2 abt '[] b
e2' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e2
let x' :: Variable b
x' = Variable 'U -> Sing b -> Variable b
forall (a :: Hakaru). Variable 'U -> Sing a -> Variable a
makeVar Variable 'U
x Sing b
typ2
Variable b
-> TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt)
forall (a :: Hakaru) b.
Variable a -> TypeCheckMonad b -> TypeCheckMonad b
pushCtx Variable b
x' (TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ do
TypedAST Sing b
typ3 abt '[] b
e4' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e3'
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ3 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ4 ->
Unify2 HPair (TypedAST abt) a
forall r (x :: Hakaru). Unify2 HPair r x
unifyPair Sing a
typ4 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru) (b :: Hakaru).
(a ~ HPair a b) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru) (b :: Hakaru).
(a ~ HPair a b) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
a Sing b
b ->
Sing b
-> Sing b
-> Maybe SourceSpan
-> ()
-> ()
-> ((b ~ b) => TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall t0 t1 (x :: Hakaru) (y :: Hakaru) r.
(TCMTypeRepr t0, TCMTypeRepr t1) =>
Sing x
-> Sing y
-> Maybe SourceSpan
-> t0
-> t1
-> ((x ~ y) => TypeCheckMonad r)
-> TypeCheckMonad r
matchTypes Sing b
typ2 Sing b
b Maybe SourceSpan
sourceSpan () () (((b ~ b) => TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> ((b ~ b) => TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] ('HMeasure (HPair ('HArray a) b)) -> TypedAST abt)
-> abt '[] ('HMeasure (HPair ('HArray a) b))
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing ('HMeasure (HPair ('HArray a) b))
-> abt '[] ('HMeasure (HPair ('HArray a) b)) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing (HPair ('HArray a) b)
-> Sing ('HMeasure (HPair ('HArray a) b))
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure (Sing (HPair ('HArray a) b)
-> Sing ('HMeasure (HPair ('HArray a) b)))
-> Sing (HPair ('HArray a) b)
-> Sing ('HMeasure (HPair ('HArray a) b))
forall a b. (a -> b) -> a -> b
$ Sing ('HArray a) -> Sing b -> Sing (HPair ('HArray a) b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (HPair a b)
sPair (Sing a -> Sing ('HArray a)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray Sing a
a) Sing b
typ2) (abt '[] ('HMeasure (HPair ('HArray a) b))
-> TypeCheckMonad (TypedAST abt))
-> abt '[] ('HMeasure (HPair ('HArray a) b))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt ('HMeasure (HPair ('HArray a) b))
-> abt '[] ('HMeasure (HPair ('HArray a) b))
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon
'[LC 'HNat, LC b, '( '[b], 'HMeasure (HPair a b))]
('HMeasure (HPair ('HArray a) b))
forall (s :: Hakaru) (a :: Hakaru).
SCon
'[LC 'HNat, LC s, '( '[s], 'HMeasure (HPair a s))]
('HMeasure (HPair ('HArray a) s))
Chain SCon
'[LC 'HNat, LC b, '( '[b], 'HMeasure (HPair a b))]
('HMeasure (HPair ('HArray a) b))
-> SArgs abt '[LC 'HNat, LC b, '( '[b], 'HMeasure (HPair a b))]
-> Term abt ('HMeasure (HPair ('HArray a) b))
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HNat
e1' abt '[] 'HNat
-> SArgs abt '[LC b, '( '[b], b)]
-> SArgs abt '[LC 'HNat, LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] b
e2' abt '[] b
-> SArgs abt '[ '( '[b], b)] -> SArgs abt '[LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* Variable b -> abt '[] b -> abt '[b] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable b
x' abt '[] b
e4' abt '[b] b -> SArgs abt '[] -> SArgs abt '[ '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Integrate_ AST
e1 AST
e2 U_ABT '[ 'U] 'U
e3 -> do
abt '[] 'HReal
e1' <- Sing 'HReal -> AST -> TypeCheckMonad (abt '[] 'HReal)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HReal
SReal AST
e1
abt '[] 'HReal
e2' <- Sing 'HReal -> AST -> TypeCheckMonad (abt '[] 'HReal)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HReal
SReal AST
e2
abt '[ 'HReal] 'HProb
e3' <- Sing 'HReal
-> Sing 'HProb
-> U_ABT '[ 'U] 'U
-> TypeCheckMonad (abt '[ 'HReal] 'HProb)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing 'HReal
SReal Sing 'HProb
SProb U_ABT '[ 'U] 'U
e3
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HProb -> TypedAST abt)
-> abt '[] 'HProb
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HProb -> abt '[] 'HProb -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HProb
SProb (abt '[] 'HProb -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HProb -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[LC 'HReal, LC 'HReal, '( '[ 'HReal], 'HProb)] 'HProb
Integrate SCon '[LC 'HReal, LC 'HReal, '( '[ 'HReal], 'HProb)] 'HProb
-> SArgs abt '[LC 'HReal, LC 'HReal, '( '[ 'HReal], 'HProb)]
-> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HReal
e1' abt '[] 'HReal
-> SArgs abt '[LC 'HReal, '( '[ 'HReal], 'HProb)]
-> SArgs abt '[LC 'HReal, LC 'HReal, '( '[ 'HReal], 'HProb)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] 'HReal
e2' abt '[] 'HReal
-> SArgs abt '[ '( '[ 'HReal], 'HProb)]
-> SArgs abt '[LC 'HReal, '( '[ 'HReal], 'HProb)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[ 'HReal] 'HProb
e3' abt '[ 'HReal] 'HProb
-> SArgs abt '[] -> SArgs abt '[ '( '[ 'HReal], 'HProb)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Summate_ AST
e1 AST
e2 U_ABT '[ 'U] 'U
e3 -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
e1
abt '[] b
e2' <- Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
typ1 AST
e2
case Sing b -> Maybe (HDiscrete b)
forall (a :: Hakaru). Sing a -> Maybe (HDiscrete a)
hDiscrete_Sing Sing b
typ1 of
Maybe (HDiscrete b)
Nothing -> TypeCheckError -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"Summate given bounds which are not discrete"
Just HDiscrete b
h1 -> Sing b
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru).
Sing b -> abt '[b] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) r.
ABT Term abt =>
Sing a
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru). Sing b -> abt '[a] b -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinder Sing b
typ1 U_ABT '[ 'U] 'U
e3 ((forall (b :: Hakaru).
Sing b -> abt '[b] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (b :: Hakaru).
Sing b -> abt '[b] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing b
typ2 abt '[b] b
ee' ->
case Sing b -> Maybe (HSemiring b)
forall (a :: Hakaru). Sing a -> Maybe (HSemiring a)
hSemiring_Sing Sing b
typ2 of
Maybe (HSemiring b)
Nothing -> TypeCheckError -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"Summate given summands which are not in a semiring"
Just HSemiring b
h2 ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ2 (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (HDiscrete b -> HSemiring b -> SCon '[LC b, LC b, '( '[b], b)] b
forall (a :: Hakaru) (b :: Hakaru).
HDiscrete a -> HSemiring b -> SCon '[LC a, LC a, '( '[a], b)] b
Summate HDiscrete b
h1 HSemiring b
h2 SCon '[LC b, LC b, '( '[b], b)] b
-> SArgs abt '[LC b, LC b, '( '[b], b)] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[LC b, '( '[b], b)]
-> SArgs abt '[LC b, LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] b
e2' abt '[] b
-> SArgs abt '[ '( '[b], b)] -> SArgs abt '[LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[b] b
ee' abt '[b] b -> SArgs abt '[] -> SArgs abt '[ '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Product_ AST
e1 AST
e2 U_ABT '[ 'U] 'U
e3 -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
e1
abt '[] b
e2' <- Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
typ1 AST
e2
case Sing b -> Maybe (HDiscrete b)
forall (a :: Hakaru). Sing a -> Maybe (HDiscrete a)
hDiscrete_Sing Sing b
typ1 of
Maybe (HDiscrete b)
Nothing -> TypeCheckError -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"Product given bounds which are not discrete"
Just HDiscrete b
h1 -> Sing b
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru).
Sing b -> abt '[b] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) r.
ABT Term abt =>
Sing a
-> U_ABT '[ 'U] 'U
-> (forall (b :: Hakaru). Sing b -> abt '[a] b -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinder Sing b
typ1 U_ABT '[ 'U] 'U
e3 ((forall (b :: Hakaru).
Sing b -> abt '[b] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (b :: Hakaru).
Sing b -> abt '[b] b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing b
typ2 abt '[b] b
e3' ->
case Sing b -> Maybe (HSemiring b)
forall (a :: Hakaru). Sing a -> Maybe (HSemiring a)
hSemiring_Sing Sing b
typ2 of
Maybe (HSemiring b)
Nothing -> TypeCheckError -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"Product given factors which are not in a semiring"
Just HSemiring b
h2 ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ2 (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (HDiscrete b -> HSemiring b -> SCon '[LC b, LC b, '( '[b], b)] b
forall (a :: Hakaru) (b :: Hakaru).
HDiscrete a -> HSemiring b -> SCon '[LC a, LC a, '( '[a], b)] b
Product HDiscrete b
h1 HSemiring b
h2 SCon '[LC b, LC b, '( '[b], b)] b
-> SArgs abt '[LC b, LC b, '( '[b], b)] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[LC b, '( '[b], b)]
-> SArgs abt '[LC b, LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] b
e2' abt '[] b
-> SArgs abt '[ '( '[b], b)] -> SArgs abt '[LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[b] b
e3' abt '[b] b -> SArgs abt '[] -> SArgs abt '[ '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Bucket_ AST
e1 AST
e2 Reducer xs (MetaABT SourceSpan Term) 'U
r1 -> do
abt '[] 'HNat
e1' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e1
abt '[] 'HNat
e2' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e2
TypedReducer Sing b
typ1 List1 Variable '[]
Nil1 Reducer abt '[] b
r1' <- Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable '[] -> TypeCheckMonad (TypedReducer abt '[])
forall (xs :: [Untyped]) (xs1 :: [Hakaru]).
Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
inferReducer Reducer xs (MetaABT SourceSpan Term) 'U
r1 List1 Variable '[]
forall k (a :: k -> *). List1 a '[]
Nil1
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ1 (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (abt '[] 'HNat -> abt '[] 'HNat -> Reducer abt '[] b -> Term abt b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] 'HNat -> abt '[] 'HNat -> Reducer abt '[] a -> Term abt a
Bucket abt '[] 'HNat
e1' abt '[] 'HNat
e2' Reducer abt '[] b
r1')
U.Transform_ Transform as x
tr SArgs (MetaABT SourceSpan Term) as
es -> Maybe SourceSpan
-> Transform as x
-> SArgs (MetaABT SourceSpan Term) as
-> TypeCheckMonad (TypedAST abt)
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Maybe SourceSpan
-> Transform as x
-> SArgs (MetaABT SourceSpan Term) as
-> TypeCheckMonad (TypedAST abt)
inferTransform Maybe SourceSpan
sourceSpan Transform as x
tr SArgs (MetaABT SourceSpan Term) as
es
U.Superpose_ NonEmpty (AST, AST)
pes -> do
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
TypedASTs Sing b
typ [abt '[] b]
es' <-
case TypeCheckMode
mode of
TypeCheckMode
StrictMode -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers_ (NonEmpty AST -> [AST]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty AST -> [AST]) -> NonEmpty AST -> [AST]
forall a b. (a -> b) -> a -> b
$ ((AST, AST) -> AST) -> NonEmpty (AST, AST) -> NonEmpty AST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AST, AST) -> AST
forall a b. (a, b) -> b
snd NonEmpty (AST, AST)
pes)
TypeCheckMode
LaxMode -> Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferLubType Maybe SourceSpan
sourceSpan (NonEmpty AST -> [AST]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty AST -> [AST]) -> NonEmpty AST -> [AST]
forall a b. (a -> b) -> a -> b
$ ((AST, AST) -> AST) -> NonEmpty (AST, AST) -> NonEmpty AST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AST, AST) -> AST
forall a b. (a, b) -> b
snd NonEmpty (AST, AST)
pes)
TypeCheckMode
UnsafeMode -> Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferLubType Maybe SourceSpan
sourceSpan (NonEmpty AST -> [AST]
forall a. NonEmpty a -> [a]
L.toList (NonEmpty AST -> [AST]) -> NonEmpty AST -> [AST]
forall a b. (a -> b) -> a -> b
$ ((AST, AST) -> AST) -> NonEmpty (AST, AST) -> NonEmpty AST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AST, AST) -> AST
forall a b. (a, b) -> b
snd NonEmpty (AST, AST)
pes)
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
_ -> do
NonEmpty (abt '[] 'HProb)
ps' <- (AST -> TypeCheckMonad (abt '[] 'HProb))
-> NonEmpty AST -> TypeCheckMonad (NonEmpty (abt '[] 'HProb))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (Sing 'HProb -> AST -> TypeCheckMonad (abt '[] 'HProb)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType Sing 'HProb
SProb) (((AST, AST) -> AST) -> NonEmpty (AST, AST) -> NonEmpty AST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AST, AST) -> AST
forall a b. (a, b) -> a
fst NonEmpty (AST, AST)
pes)
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ (Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> Term abt ('HMeasure a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> Term abt ('HMeasure a)
Superpose_ (NonEmpty (abt '[] 'HProb)
-> NonEmpty (abt '[] b) -> NonEmpty (abt '[] 'HProb, abt '[] b)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
L.zip NonEmpty (abt '[] 'HProb)
ps' ([abt '[] b] -> NonEmpty (abt '[] b)
forall a. [a] -> NonEmpty a
L.fromList [abt '[] b]
es'))))
U.InjTyped forall (abt' :: [Hakaru] -> Hakaru -> *).
ABT Term abt' =>
abt' '[] x
t -> let t' :: abt '[] x
t' = abt '[] x
forall (abt' :: [Hakaru] -> Hakaru -> *).
ABT Term abt' =>
abt' '[] x
t in TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Sing x -> abt '[] x -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (abt '[] x -> Sing x
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Sing a
typeOf abt '[] x
t') abt '[] x
t'
Term (MetaABT SourceSpan Term) 'U
_ | AST -> Bool
mustCheck AST
e0 -> Maybe SourceSpan -> TypeCheckMonad (TypedAST abt)
forall r. Maybe SourceSpan -> TypeCheckMonad r
ambiguousMustCheck Maybe SourceSpan
sourceSpan
| Bool
otherwise -> [Char] -> TypeCheckMonad (TypedAST abt)
forall a. HasCallStack => [Char] -> a
error [Char]
"inferType: missing an inferable branch!"
inferTransform
:: Maybe U.SourceSpan
-> Transform as x
-> U.SArgs U.U_ABT as
-> TypeCheckMonad (TypedAST abt)
inferTransform :: Maybe SourceSpan
-> Transform as x
-> SArgs (MetaABT SourceSpan Term) as
-> TypeCheckMonad (TypedAST abt)
inferTransform Maybe SourceSpan
sourceSpan
Transform as x
Expect
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* (Cons2 ToUntyped x y
U.ToU List2 ToUntyped xs ys
Nil2, U_ABT varsu 'U
e2) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
let e1src :: Maybe SourceSpan
e1src = U_ABT varsu 'U -> Maybe SourceSpan
forall meta k (syn :: ([k] -> k -> *) -> k -> *) (xs :: [k])
(a :: k).
MetaABT meta syn xs a -> Maybe meta
getMetadata U_ABT varsu 'U
e1
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ U_ABT varsu 'U
AST
e1
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ1 Maybe SourceSpan
e1src ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 -> do
abt '[a] 'HProb
e2' <- Sing a
-> Sing 'HProb
-> U_ABT '[ 'U] 'U
-> TypeCheckMonad (abt '[a] 'HProb)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing a
typ2 Sing 'HProb
SProb U_ABT varsu 'U
U_ABT '[ 'U] 'U
e2
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HProb -> TypedAST abt)
-> abt '[] 'HProb
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HProb -> abt '[] 'HProb -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HProb
SProb (abt '[] 'HProb -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HProb -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn
(Transform '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
-> SCon '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
forall (a :: Hakaru).
Transform '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
Expect SCon '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
-> SArgs abt '[LC ('HMeasure a), '( '[a], 'HProb)]
-> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[a], 'HProb)]
-> SArgs abt '[ '( '[], b), '( '[a], 'HProb)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[a] 'HProb
e2' abt '[a] 'HProb -> SArgs abt '[] -> SArgs abt '[ '( '[a], 'HProb)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
inferTransform Maybe SourceSpan
sourceSpan
Transform as x
Observe
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e2) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
let e1src :: Maybe SourceSpan
e1src = U_ABT varsu 'U -> Maybe SourceSpan
forall meta k (syn :: ([k] -> k -> *) -> k -> *) (xs :: [k])
(a :: k).
MetaABT meta syn xs a -> Maybe meta
getMetadata U_ABT varsu 'U
e1
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ U_ABT varsu 'U
AST
e1
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ1 Maybe SourceSpan
e1src ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 -> do
abt '[] a
e2' <- Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing a
typ2 U_ABT varsu 'U
AST
e2
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] ('HMeasure a) -> TypedAST abt)
-> abt '[] ('HMeasure a)
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ1 (abt '[] ('HMeasure a) -> TypeCheckMonad (TypedAST abt))
-> abt '[] ('HMeasure a) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn
(Transform '[LC ('HMeasure a), LC a] ('HMeasure a)
-> SCon '[LC ('HMeasure a), LC a] ('HMeasure a)
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[LC ('HMeasure a), LC a] ('HMeasure a)
forall (a :: Hakaru).
Transform '[LC ('HMeasure a), LC a] ('HMeasure a)
Observe SCon '[LC ('HMeasure a), LC a] ('HMeasure a)
-> SArgs abt '[LC ('HMeasure a), LC a] -> Term abt ('HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b -> SArgs abt '[LC a] -> SArgs abt '[ '( '[], b), LC a]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] a
e2' abt '[] a -> SArgs abt '[] -> SArgs abt '[LC a]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
inferTransform Maybe SourceSpan
sourceSpan
Transform as x
MCMC
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e2) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
let e1src :: Maybe SourceSpan
e1src = U_ABT varsu 'U -> Maybe SourceSpan
forall meta k (syn :: ([k] -> k -> *) -> k -> *) (xs :: [k])
(a :: k).
MetaABT meta syn xs a -> Maybe meta
getMetadata U_ABT varsu 'U
e1
e2src :: Maybe SourceSpan
e2src = U_ABT varsu 'U -> Maybe SourceSpan
forall meta k (syn :: ([k] -> k -> *) -> k -> *) (xs :: [k])
(a :: k).
MetaABT meta syn xs a -> Maybe meta
getMetadata U_ABT varsu 'U
e2
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ U_ABT varsu 'U
AST
e1
TypedAST Sing b
typ2 abt '[] b
e2' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ U_ABT varsu 'U
AST
e2
Unify2 (':->) (TypedAST abt) b
forall r (x :: Hakaru). Unify2 (':->) r x
unifyFun Sing b
typ1 Maybe SourceSpan
e1src ((forall (a :: Hakaru) (b :: Hakaru).
(b ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru) (b :: Hakaru).
(b ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typa Sing b
typmb ->
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typmb Maybe SourceSpan
e1src ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typb ->
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ2 Maybe SourceSpan
e2src ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typc ->
Sing a
-> Sing a
-> Maybe SourceSpan
-> Sing (a ':-> 'HMeasure a)
-> Sing b
-> ((a ~ a) => TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall t0 t1 (x :: Hakaru) (y :: Hakaru) r.
(TCMTypeRepr t0, TCMTypeRepr t1) =>
Sing x
-> Sing y
-> Maybe SourceSpan
-> t0
-> t1
-> ((x ~ y) => TypeCheckMonad r)
-> TypeCheckMonad r
matchTypes Sing a
typa Sing a
typb Maybe SourceSpan
e1src (Sing a -> Sing ('HMeasure a) -> Sing (a ':-> 'HMeasure a)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (a ':-> b)
SFun Sing a
typa (Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure Sing a
typa)) Sing b
typ1 (((a ~ a) => TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> ((a ~ a) => TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Sing a
-> Sing a
-> Maybe SourceSpan
-> Sing b
-> Sing b
-> ((a ~ a) => TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall t0 t1 (x :: Hakaru) (y :: Hakaru) r.
(TCMTypeRepr t0, TCMTypeRepr t1) =>
Sing x
-> Sing y
-> Maybe SourceSpan
-> t0
-> t1
-> ((x ~ y) => TypeCheckMonad r)
-> TypeCheckMonad r
matchTypes Sing a
typb Sing a
typc Maybe SourceSpan
e2src Sing b
typmb Sing b
typ2 (((a ~ a) => TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> ((a ~ a) => TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Sing (a ':-> 'HMeasure a)
-> abt '[] (a ':-> 'HMeasure a) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing a -> Sing ('HMeasure a) -> Sing (a ':-> 'HMeasure a)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (a ':-> b)
SFun Sing a
typa (Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure Sing a
typa))
(abt '[] (a ':-> 'HMeasure a) -> TypedAST abt)
-> abt '[] (a ':-> 'HMeasure a) -> TypedAST abt
forall a b. (a -> b) -> a -> b
$ Term abt (a ':-> 'HMeasure a) -> abt '[] (a ':-> 'HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term abt (a ':-> 'HMeasure a) -> abt '[] (a ':-> 'HMeasure a))
-> Term abt (a ':-> 'HMeasure a) -> abt '[] (a ':-> 'HMeasure a)
forall a b. (a -> b) -> a -> b
$ Transform
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
-> SCon
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
forall (a :: Hakaru).
Transform
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
MCMC SCon
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
-> SArgs abt '[LC (a ':-> 'HMeasure a), LC ('HMeasure a)]
-> Term abt (a ':-> 'HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[], b)] -> SArgs abt '[ '( '[], b), '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] b
e2' abt '[] b -> SArgs abt '[] -> SArgs abt '[ '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End
inferTransform Maybe SourceSpan
sourceSpan
(Disint TransformImpl
k)
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
let e1src :: Maybe SourceSpan
e1src = U_ABT varsu 'U -> Maybe SourceSpan
forall meta k (syn :: ([k] -> k -> *) -> k -> *) (xs :: [k])
(a :: k).
MetaABT meta syn xs a -> Maybe meta
getMetadata U_ABT varsu 'U
e1
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ U_ABT varsu 'U
AST
e1
Unify1 'HMeasure (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ1 Maybe SourceSpan
e1src ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 ->
Unify2 HPair (TypedAST abt) a
forall r (x :: Hakaru). Unify2 HPair r x
unifyPair Sing a
typ2 Maybe SourceSpan
e1src ((forall (a :: Hakaru) (b :: Hakaru).
(a ~ HPair a b) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru) (b :: Hakaru).
(a ~ HPair a b) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typa Sing b
typb ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Sing (a ':-> 'HMeasure b)
-> abt '[] (a ':-> 'HMeasure b) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (Sing a -> Sing ('HMeasure b) -> Sing (a ':-> 'HMeasure b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (a ':-> b)
SFun Sing a
typa (Sing b -> Sing ('HMeasure b)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure Sing b
typb)) (abt '[] (a ':-> 'HMeasure b) -> TypedAST abt)
-> abt '[] (a ':-> 'HMeasure b) -> TypedAST abt
forall a b. (a -> b) -> a -> b
$
Term abt (a ':-> 'HMeasure b) -> abt '[] (a ':-> 'HMeasure b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term abt (a ':-> 'HMeasure b) -> abt '[] (a ':-> 'HMeasure b))
-> Term abt (a ':-> 'HMeasure b) -> abt '[] (a ':-> 'HMeasure b)
forall a b. (a -> b) -> a -> b
$ Transform '[LC ('HMeasure (HPair a b))] (a ':-> 'HMeasure b)
-> SCon '[LC ('HMeasure (HPair a b))] (a ':-> 'HMeasure b)
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ (TransformImpl
-> Transform '[LC ('HMeasure (HPair a b))] (a ':-> 'HMeasure b)
forall (a :: Hakaru) (b :: Hakaru).
TransformImpl
-> Transform '[LC ('HMeasure (HPair a b))] (a ':-> 'HMeasure b)
Disint TransformImpl
k) SCon '[LC ('HMeasure (HPair a b))] (a ':-> 'HMeasure b)
-> SArgs abt '[LC ('HMeasure (HPair a b))]
-> Term abt (a ':-> 'HMeasure b)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b -> SArgs abt '[] -> SArgs abt '[ '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End
inferTransform Maybe SourceSpan
sourceSpan
Transform as x
Simplify
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ U_ABT varsu 'U
AST
e1
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ1 (abt '[] b -> TypedAST abt) -> abt '[] b -> TypedAST abt
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Transform '[LC b] b -> SCon '[LC b] b
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[LC b] b
forall (a :: Hakaru). Transform '[LC a] a
Simplify SCon '[LC b] b -> SArgs abt '[LC b] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b -> SArgs abt '[] -> SArgs abt '[LC b]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
inferTransform Maybe SourceSpan
sourceSpan
Transform as x
Reparam
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ U_ABT varsu 'U
AST
e1
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ1 (abt '[] b -> TypedAST abt) -> abt '[] b -> TypedAST abt
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Transform '[LC b] b -> SCon '[LC b] b
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[LC b] b
forall (a :: Hakaru). Transform '[LC a] a
Reparam SCon '[LC b] b -> SArgs abt '[LC b] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b -> SArgs abt '[] -> SArgs abt '[LC b]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
inferTransform Maybe SourceSpan
sourceSpan
Transform as x
Summarize
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ U_ABT varsu 'U
AST
e1
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ1 (abt '[] b -> TypedAST abt) -> abt '[] b -> TypedAST abt
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Transform '[LC b] b -> SCon '[LC b] b
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[LC b] b
forall (a :: Hakaru). Transform '[LC a] a
Summarize SCon '[LC b] b -> SArgs abt '[LC b] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b -> SArgs abt '[] -> SArgs abt '[LC b]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
inferTransform Maybe SourceSpan
_ Transform as x
tr SArgs (MetaABT SourceSpan Term) as
_ = [Char] -> TypeCheckMonad (TypedAST abt)
forall a. HasCallStack => [Char] -> a
error ([Char] -> TypeCheckMonad (TypedAST abt))
-> [Char] -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ [Char]
"inferTransform{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Transform as x -> [Char]
forall a. Show a => a -> [Char]
show Transform as x
tr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}: TODO"
inferPrimOp
:: U.PrimOp
-> [U.AST]
-> TypeCheckMonad (TypedAST abt)
inferPrimOp :: PrimOp -> [AST] -> TypeCheckMonad (TypedAST abt)
inferPrimOp PrimOp
U.Not [AST]
es =
case [AST]
es of
[AST
e] -> do abt '[] HBool
e' <- Sing HBool -> AST -> TypeCheckMonad (abt '[] HBool)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing HBool
sBool AST
e
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] HBool -> TypedAST abt)
-> abt '[] HBool
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing HBool -> abt '[] HBool -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing HBool
sBool (abt '[] HBool -> TypeCheckMonad (TypedAST abt))
-> abt '[] HBool -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt HBool -> abt '[] HBool
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[HBool] HBool -> SCon '[ '( '[], HBool)] HBool
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[HBool] HBool
Not SCon '[ '( '[], HBool)] HBool
-> SArgs abt '[ '( '[], HBool)] -> Term abt HBool
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] HBool
e' abt '[] HBool -> SArgs abt '[] -> SArgs abt '[ '( '[], HBool)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Pi [AST]
es =
case [AST]
es of
[] -> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HProb -> TypedAST abt)
-> abt '[] 'HProb
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HProb -> abt '[] 'HProb -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HProb
SProb (abt '[] 'HProb -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HProb -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[] 'HProb -> SCon '[] 'HProb
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[] 'HProb
Pi SCon '[] 'HProb -> SArgs abt '[] -> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Cos [AST]
es =
case [AST]
es of
[AST
e] -> do abt '[] 'HReal
e' <- Sing 'HReal -> AST -> TypeCheckMonad (abt '[] 'HReal)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HReal
SReal AST
e
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HReal -> TypedAST abt)
-> abt '[] 'HReal
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HReal -> abt '[] 'HReal -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HReal
SReal (abt '[] 'HReal -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HReal -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt 'HReal -> abt '[] 'HReal
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HReal] 'HReal -> SCon '[LC 'HReal] 'HReal
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[ 'HReal] 'HReal
Cos SCon '[LC 'HReal] 'HReal
-> SArgs abt '[LC 'HReal] -> Term abt 'HReal
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HReal
e' abt '[] 'HReal -> SArgs abt '[] -> SArgs abt '[LC 'HReal]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.RealPow [AST]
es =
case [AST]
es of
[AST
e1, AST
e2] -> do abt '[] 'HProb
e1' <- Sing 'HProb -> AST -> TypeCheckMonad (abt '[] 'HProb)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HProb
SProb AST
e1
abt '[] 'HReal
e2' <- Sing 'HReal -> AST -> TypeCheckMonad (abt '[] 'HReal)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HReal
SReal AST
e2
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HProb -> TypedAST abt)
-> abt '[] 'HProb
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HProb -> abt '[] 'HProb -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HProb
SProb (abt '[] 'HProb -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HProb -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HProb, 'HReal] 'HProb
-> SCon '[ '( '[], 'HProb), LC 'HReal] 'HProb
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[ 'HProb, 'HReal] 'HProb
RealPow SCon '[ '( '[], 'HProb), LC 'HReal] 'HProb
-> SArgs abt '[ '( '[], 'HProb), LC 'HReal] -> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HProb
e1' abt '[] 'HProb
-> SArgs abt '[LC 'HReal]
-> SArgs abt '[ '( '[], 'HProb), LC 'HReal]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] 'HReal
e2' abt '[] 'HReal -> SArgs abt '[] -> SArgs abt '[LC 'HReal]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Choose [AST]
es =
case [AST]
es of
[AST
e1, AST
e2] -> do abt '[] 'HNat
e1' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e1
abt '[] 'HNat
e2' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e2
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HNat -> TypedAST abt)
-> abt '[] 'HNat
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HNat -> abt '[] 'HNat -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HNat
SNat (abt '[] 'HNat -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HNat -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt 'HNat -> abt '[] 'HNat
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HNat, 'HNat] 'HNat -> SCon '[LC 'HNat, LC 'HNat] 'HNat
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[ 'HNat, 'HNat] 'HNat
Choose SCon '[LC 'HNat, LC 'HNat] 'HNat
-> SArgs abt '[LC 'HNat, LC 'HNat] -> Term abt 'HNat
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HNat
e1' abt '[] 'HNat
-> SArgs abt '[LC 'HNat] -> SArgs abt '[LC 'HNat, LC 'HNat]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] 'HNat
e2' abt '[] 'HNat -> SArgs abt '[] -> SArgs abt '[LC 'HNat]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Exp [AST]
es =
case [AST]
es of
[AST
e] -> do abt '[] 'HReal
e' <- Sing 'HReal -> AST -> TypeCheckMonad (abt '[] 'HReal)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HReal
SReal AST
e
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HProb -> TypedAST abt)
-> abt '[] 'HProb
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HProb -> abt '[] 'HProb -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HProb
SProb (abt '[] 'HProb -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HProb -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HReal] 'HProb -> SCon '[LC 'HReal] 'HProb
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[ 'HReal] 'HProb
Exp SCon '[LC 'HReal] 'HProb
-> SArgs abt '[LC 'HReal] -> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HReal
e' abt '[] 'HReal -> SArgs abt '[] -> SArgs abt '[LC 'HReal]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Log [AST]
es =
case [AST]
es of
[AST
e] -> do abt '[] 'HProb
e' <- Sing 'HProb -> AST -> TypeCheckMonad (abt '[] 'HProb)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HProb
SProb AST
e
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HReal -> TypedAST abt)
-> abt '[] 'HReal
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HReal -> abt '[] 'HReal -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HReal
SReal (abt '[] 'HReal -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HReal -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt 'HReal -> abt '[] 'HReal
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HProb] 'HReal -> SCon '[ '( '[], 'HProb)] 'HReal
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[ 'HProb] 'HReal
Log SCon '[ '( '[], 'HProb)] 'HReal
-> SArgs abt '[ '( '[], 'HProb)] -> Term abt 'HReal
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HProb
e' abt '[] 'HProb -> SArgs abt '[] -> SArgs abt '[ '( '[], 'HProb)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Infinity [AST]
es =
case [AST]
es of
[] -> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HProb -> TypedAST abt)
-> abt '[] 'HProb
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HProb -> abt '[] 'HProb -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HProb
SProb (abt '[] 'HProb -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HProb -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[] 'HProb -> SCon '[] 'HProb
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ (HIntegrable 'HProb -> PrimOp '[] 'HProb
forall (a :: Hakaru). HIntegrable a -> PrimOp '[] a
Infinity HIntegrable 'HProb
HIntegrable_Prob) SCon '[] 'HProb -> SArgs abt '[] -> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.GammaFunc [AST]
es =
case [AST]
es of
[AST
e] -> do abt '[] 'HReal
e' <- Sing 'HReal -> AST -> TypeCheckMonad (abt '[] 'HReal)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HReal
SReal AST
e
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HProb -> TypedAST abt)
-> abt '[] 'HProb
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HProb -> abt '[] 'HProb -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HProb
SProb (abt '[] 'HProb -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HProb -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HReal] 'HProb -> SCon '[LC 'HReal] 'HProb
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[ 'HReal] 'HProb
GammaFunc SCon '[LC 'HReal] 'HProb
-> SArgs abt '[LC 'HReal] -> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HReal
e' abt '[] 'HReal -> SArgs abt '[] -> SArgs abt '[LC 'HReal]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.BetaFunc [AST]
es =
case [AST]
es of
[AST
e1, AST
e2] -> do abt '[] 'HProb
e1' <- Sing 'HProb -> AST -> TypeCheckMonad (abt '[] 'HProb)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HProb
SProb AST
e1
abt '[] 'HProb
e2' <- Sing 'HProb -> AST -> TypeCheckMonad (abt '[] 'HProb)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HProb
SProb AST
e2
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HProb -> TypedAST abt)
-> abt '[] 'HProb
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HProb -> abt '[] 'HProb -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HProb
SProb (abt '[] 'HProb -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HProb -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HProb, 'HProb] 'HProb
-> SCon '[ '( '[], 'HProb), '( '[], 'HProb)] 'HProb
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[ 'HProb, 'HProb] 'HProb
BetaFunc SCon '[ '( '[], 'HProb), '( '[], 'HProb)] 'HProb
-> SArgs abt '[ '( '[], 'HProb), '( '[], 'HProb)]
-> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HProb
e1' abt '[] 'HProb
-> SArgs abt '[ '( '[], 'HProb)]
-> SArgs abt '[ '( '[], 'HProb), '( '[], 'HProb)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] 'HProb
e2' abt '[] 'HProb -> SArgs abt '[] -> SArgs abt '[ '( '[], 'HProb)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Equal [AST]
es =
case [AST]
es of
[AST
_, AST
_] -> do TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
TypedASTs Sing b
typ [abt '[] b
e1', abt '[] b
e2'] <-
case TypeCheckMode
mode of
TypeCheckMode
StrictMode -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers_ [AST]
es
TypeCheckMode
_ -> Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferLubType Maybe SourceSpan
forall a. Maybe a
Nothing [AST]
es
PrimOp '[b, b] HBool
primop <- HEq b -> PrimOp '[b, b] HBool
forall (a :: Hakaru). HEq a -> PrimOp '[a, a] HBool
Equal (HEq b -> PrimOp '[b, b] HBool)
-> TypeCheckMonad (HEq b) -> TypeCheckMonad (PrimOp '[b, b] HBool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing b -> TypeCheckMonad (HEq b)
forall (a :: Hakaru). Sing a -> TypeCheckMonad (HEq a)
getHEq Sing b
typ
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] HBool -> TypedAST abt)
-> abt '[] HBool
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing HBool -> abt '[] HBool -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing HBool
sBool (abt '[] HBool -> TypeCheckMonad (TypedAST abt))
-> abt '[] HBool -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt HBool -> abt '[] HBool
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[b, b] HBool -> SCon '[ '( '[], b), '( '[], b)] HBool
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[b, b] HBool
primop SCon '[ '( '[], b), '( '[], b)] HBool
-> SArgs abt '[ '( '[], b), '( '[], b)] -> Term abt HBool
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[], b)] -> SArgs abt '[ '( '[], b), '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] b
e2' abt '[] b -> SArgs abt '[] -> SArgs abt '[ '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Less [AST]
es =
case [AST]
es of
[AST
_, AST
_] -> do TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
TypedASTs Sing b
typ [abt '[] b
e1', abt '[] b
e2'] <-
case TypeCheckMode
mode of
TypeCheckMode
StrictMode -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers_ [AST]
es
TypeCheckMode
_ -> Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferLubType Maybe SourceSpan
forall a. Maybe a
Nothing [AST]
es
PrimOp '[b, b] HBool
primop <- HOrd b -> PrimOp '[b, b] HBool
forall (a :: Hakaru). HOrd a -> PrimOp '[a, a] HBool
Less (HOrd b -> PrimOp '[b, b] HBool)
-> TypeCheckMonad (HOrd b) -> TypeCheckMonad (PrimOp '[b, b] HBool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing b -> TypeCheckMonad (HOrd b)
forall (a :: Hakaru). Sing a -> TypeCheckMonad (HOrd a)
getHOrd Sing b
typ
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] HBool -> TypedAST abt)
-> abt '[] HBool
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing HBool -> abt '[] HBool -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing HBool
sBool (abt '[] HBool -> TypeCheckMonad (TypedAST abt))
-> abt '[] HBool -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt HBool -> abt '[] HBool
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[b, b] HBool -> SCon '[ '( '[], b), '( '[], b)] HBool
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[b, b] HBool
primop SCon '[ '( '[], b), '( '[], b)] HBool
-> SArgs abt '[ '( '[], b), '( '[], b)] -> Term abt HBool
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[], b)] -> SArgs abt '[ '( '[], b), '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] b
e2' abt '[] b -> SArgs abt '[] -> SArgs abt '[ '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.NatPow [AST]
es =
case [AST]
es of
[AST
e1, AST
e2] -> do TypedAST Sing b
typ abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
abt '[] 'HNat
e2' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e2
PrimOp '[b, 'HNat] b
primop <- HSemiring b -> PrimOp '[b, 'HNat] b
forall (a :: Hakaru). HSemiring a -> PrimOp '[a, 'HNat] a
NatPow (HSemiring b -> PrimOp '[b, 'HNat] b)
-> TypeCheckMonad (HSemiring b)
-> TypeCheckMonad (PrimOp '[b, 'HNat] b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing b -> TypeCheckMonad (HSemiring b)
forall (a :: Hakaru). Sing a -> TypeCheckMonad (HSemiring a)
getHSemiring Sing b
typ
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[b, 'HNat] b -> SCon '[ '( '[], b), LC 'HNat] b
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[b, 'HNat] b
primop SCon '[ '( '[], b), LC 'HNat] b
-> SArgs abt '[ '( '[], b), LC 'HNat] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[LC 'HNat] -> SArgs abt '[ '( '[], b), LC 'HNat]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] 'HNat
e2' abt '[] 'HNat -> SArgs abt '[] -> SArgs abt '[LC 'HNat]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Negate [AST]
es =
case [AST]
es of
[AST
e] -> do TypedAST Sing b
typ abt '[] b
e' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
SomeRing HRing b
ring Coercion b b
c <- Sing b -> TypeCheckMode -> TypeCheckMonad (SomeRing b)
forall (a :: Hakaru).
Sing a -> TypeCheckMode -> TypeCheckMonad (SomeRing a)
getHRing Sing b
typ TypeCheckMode
mode
PrimOp '[b] b
primop <- HRing b -> PrimOp '[b] b
forall (a :: Hakaru). HRing a -> PrimOp '[a] a
Negate (HRing b -> PrimOp '[b] b)
-> TypeCheckMonad (HRing b) -> TypeCheckMonad (PrimOp '[b] b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HRing b -> TypeCheckMonad (HRing b)
forall (m :: * -> *) a. Monad m => a -> m a
return HRing b
ring
let e'' :: abt '[] b
e'' = case Coercion b b
c of
Coercion b b
CNil -> abt '[] b
abt '[] b
e'
Coercion b b
c' -> LC_ abt b -> abt '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt b -> abt '[] b)
-> (LC_ abt b -> LC_ abt b) -> LC_ abt b -> abt '[] b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion b b -> LC_ abt b -> LC_ abt b
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion b b
c' (LC_ abt b -> abt '[] b) -> LC_ abt b -> abt '[] b
forall a b. (a -> b) -> a -> b
$ abt '[] b -> LC_ abt b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ abt '[] b
e'
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (HRing b -> Sing b
forall (a :: Hakaru). HRing a -> Sing a
sing_HRing HRing b
ring) (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[b] b -> SCon '[ '( '[], b)] b
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[b] b
primop SCon '[ '( '[], b)] b -> SArgs abt '[ '( '[], b)] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e'' abt '[] b -> SArgs abt '[] -> SArgs abt '[ '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Abs [AST]
es =
case [AST]
es of
[AST
e] -> do TypedAST Sing b
typ abt '[] b
e' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
SomeRing HRing b
ring Coercion b b
c <- Sing b -> TypeCheckMode -> TypeCheckMonad (SomeRing b)
forall (a :: Hakaru).
Sing a -> TypeCheckMode -> TypeCheckMonad (SomeRing a)
getHRing Sing b
typ TypeCheckMode
mode
PrimOp '[b] (NonNegative b)
primop <- HRing b -> PrimOp '[b] (NonNegative b)
forall (a :: Hakaru). HRing a -> PrimOp '[a] (NonNegative a)
Abs (HRing b -> PrimOp '[b] (NonNegative b))
-> TypeCheckMonad (HRing b)
-> TypeCheckMonad (PrimOp '[b] (NonNegative b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HRing b -> TypeCheckMonad (HRing b)
forall (m :: * -> *) a. Monad m => a -> m a
return HRing b
ring
let e'' :: abt '[] b
e'' = case Coercion b b
c of
Coercion b b
CNil -> abt '[] b
abt '[] b
e'
Coercion b b
c' -> LC_ abt b -> abt '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt b -> abt '[] b)
-> (LC_ abt b -> LC_ abt b) -> LC_ abt b -> abt '[] b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion b b -> LC_ abt b -> LC_ abt b
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion b b
c' (LC_ abt b -> abt '[] b) -> LC_ abt b -> abt '[] b
forall a b. (a -> b) -> a -> b
$ abt '[] b -> LC_ abt b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ abt '[] b
e'
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] (NonNegative b) -> TypedAST abt)
-> abt '[] (NonNegative b)
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing (NonNegative b) -> abt '[] (NonNegative b) -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (HRing b -> Sing (NonNegative b)
forall (a :: Hakaru). HRing a -> Sing (NonNegative a)
sing_NonNegative HRing b
ring) (abt '[] (NonNegative b) -> TypeCheckMonad (TypedAST abt))
-> abt '[] (NonNegative b) -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt (NonNegative b) -> abt '[] (NonNegative b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[b] (NonNegative b) -> SCon '[ '( '[], b)] (NonNegative b)
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[b] (NonNegative b)
primop SCon '[ '( '[], b)] (NonNegative b)
-> SArgs abt '[ '( '[], b)] -> Term abt (NonNegative b)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e'' abt '[] b -> SArgs abt '[] -> SArgs abt '[ '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Signum [AST]
es =
case [AST]
es of
[AST
e] -> do TypedAST Sing b
typ abt '[] b
e' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
SomeRing HRing b
ring Coercion b b
c <- Sing b -> TypeCheckMode -> TypeCheckMonad (SomeRing b)
forall (a :: Hakaru).
Sing a -> TypeCheckMode -> TypeCheckMonad (SomeRing a)
getHRing Sing b
typ TypeCheckMode
mode
PrimOp '[b] b
primop <- HRing b -> PrimOp '[b] b
forall (a :: Hakaru). HRing a -> PrimOp '[a] a
Signum (HRing b -> PrimOp '[b] b)
-> TypeCheckMonad (HRing b) -> TypeCheckMonad (PrimOp '[b] b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HRing b -> TypeCheckMonad (HRing b)
forall (m :: * -> *) a. Monad m => a -> m a
return HRing b
ring
let e'' :: abt '[] b
e'' = case Coercion b b
c of
Coercion b b
CNil -> abt '[] b
abt '[] b
e'
Coercion b b
c' -> LC_ abt b -> abt '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt b -> abt '[] b)
-> (LC_ abt b -> LC_ abt b) -> LC_ abt b -> abt '[] b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion b b -> LC_ abt b -> LC_ abt b
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion b b
c' (LC_ abt b -> abt '[] b) -> LC_ abt b -> abt '[] b
forall a b. (a -> b) -> a -> b
$ abt '[] b -> LC_ abt b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ abt '[] b
e'
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (HRing b -> Sing b
forall (a :: Hakaru). HRing a -> Sing a
sing_HRing HRing b
ring) (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[b] b -> SCon '[ '( '[], b)] b
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[b] b
primop SCon '[ '( '[], b)] b -> SArgs abt '[ '( '[], b)] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e'' abt '[] b -> SArgs abt '[] -> SArgs abt '[ '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Recip [AST]
es =
case [AST]
es of
[AST
e] -> do TypedAST Sing b
typ abt '[] b
e' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
SomeFractional HFractional b
frac Coercion b b
c <- Sing b -> TypeCheckMode -> TypeCheckMonad (SomeFractional b)
forall (a :: Hakaru).
Sing a -> TypeCheckMode -> TypeCheckMonad (SomeFractional a)
getHFractional Sing b
typ TypeCheckMode
mode
PrimOp '[b] b
primop <- HFractional b -> PrimOp '[b] b
forall (a :: Hakaru). HFractional a -> PrimOp '[a] a
Recip (HFractional b -> PrimOp '[b] b)
-> TypeCheckMonad (HFractional b) -> TypeCheckMonad (PrimOp '[b] b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HFractional b -> TypeCheckMonad (HFractional b)
forall (m :: * -> *) a. Monad m => a -> m a
return HFractional b
frac
let e'' :: abt '[] b
e'' = case Coercion b b
c of
Coercion b b
CNil -> abt '[] b
abt '[] b
e'
Coercion b b
c' -> LC_ abt b -> abt '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt b -> abt '[] b)
-> (LC_ abt b -> LC_ abt b) -> LC_ abt b -> abt '[] b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion b b -> LC_ abt b -> LC_ abt b
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion b b
c' (LC_ abt b -> abt '[] b) -> LC_ abt b -> abt '[] b
forall a b. (a -> b) -> a -> b
$ abt '[] b -> LC_ abt b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ abt '[] b
e'
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] b -> TypedAST abt)
-> abt '[] b
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST (HFractional b -> Sing b
forall (a :: Hakaru). HFractional a -> Sing a
sing_HFractional HFractional b
frac) (abt '[] b -> TypeCheckMonad (TypedAST abt))
-> abt '[] b -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[b] b -> SCon '[ '( '[], b)] b
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[b] b
primop SCon '[ '( '[], b)] b -> SArgs abt '[ '( '[], b)] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e'' abt '[] b -> SArgs abt '[] -> SArgs abt '[ '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.NatRoot [AST]
es =
case [AST]
es of
[AST
e1, AST
e2] -> do abt '[] 'HProb
e1' <- Sing 'HProb -> AST -> TypeCheckMonad (abt '[] 'HProb)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HProb
SProb AST
e1
abt '[] 'HNat
e2' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e2
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HProb -> TypedAST abt)
-> abt '[] 'HProb
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HProb -> abt '[] 'HProb -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HProb
SProb (abt '[] 'HProb -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HProb -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HProb, 'HNat] 'HProb
-> SCon '[ '( '[], 'HProb), LC 'HNat] 'HProb
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ (HRadical 'HProb -> PrimOp '[ 'HProb, 'HNat] 'HProb
forall (a :: Hakaru). HRadical a -> PrimOp '[a, 'HNat] a
NatRoot HRadical 'HProb
HRadical_Prob)
SCon '[ '( '[], 'HProb), LC 'HNat] 'HProb
-> SArgs abt '[ '( '[], 'HProb), LC 'HNat] -> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HProb
e1' abt '[] 'HProb
-> SArgs abt '[LC 'HNat] -> SArgs abt '[ '( '[], 'HProb), LC 'HNat]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] 'HNat
e2' abt '[] 'HNat -> SArgs abt '[] -> SArgs abt '[LC 'HNat]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Erf [AST]
es =
case [AST]
es of
[AST
e] -> do abt '[] 'HReal
e' <- Sing 'HReal -> AST -> TypeCheckMonad (abt '[] 'HReal)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HReal
SReal AST
e
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HReal -> TypedAST abt)
-> abt '[] 'HReal
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HReal -> abt '[] 'HReal -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HReal
SReal (abt '[] 'HReal -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HReal -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt 'HReal -> abt '[] 'HReal
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HReal] 'HReal -> SCon '[LC 'HReal] 'HReal
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ (HContinuous 'HReal -> PrimOp '[ 'HReal] 'HReal
forall (a :: Hakaru). HContinuous a -> PrimOp '[a] a
Erf HContinuous 'HReal
HContinuous_Real)
SCon '[LC 'HReal] 'HReal
-> SArgs abt '[LC 'HReal] -> Term abt 'HReal
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HReal
e' abt '[] 'HReal -> SArgs abt '[] -> SArgs abt '[LC 'HReal]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
x [AST]
es
| Just PrimOp '[ 'HReal] 'HReal
y <- PrimOp
-> [(PrimOp, PrimOp '[ 'HReal] 'HReal)]
-> Maybe (PrimOp '[ 'HReal] 'HReal)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup PrimOp
x
[(PrimOp
U.Sin , PrimOp '[ 'HReal] 'HReal
Sin ),
(PrimOp
U.Cos , PrimOp '[ 'HReal] 'HReal
Cos ),
(PrimOp
U.Tan , PrimOp '[ 'HReal] 'HReal
Tan ),
(PrimOp
U.Asin , PrimOp '[ 'HReal] 'HReal
Asin ),
(PrimOp
U.Acos , PrimOp '[ 'HReal] 'HReal
Acos ),
(PrimOp
U.Atan , PrimOp '[ 'HReal] 'HReal
Atan ),
(PrimOp
U.Sinh , PrimOp '[ 'HReal] 'HReal
Sinh ),
(PrimOp
U.Cosh , PrimOp '[ 'HReal] 'HReal
Cosh ),
(PrimOp
U.Tanh , PrimOp '[ 'HReal] 'HReal
Tanh ),
(PrimOp
U.Asinh, PrimOp '[ 'HReal] 'HReal
Asinh),
(PrimOp
U.Acosh, PrimOp '[ 'HReal] 'HReal
Acosh),
(PrimOp
U.Atanh, PrimOp '[ 'HReal] 'HReal
Atanh)] =
case [AST]
es of
[AST
e] -> do abt '[] 'HReal
e' <- Sing 'HReal -> AST -> TypeCheckMonad (abt '[] 'HReal)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HReal
SReal AST
e
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HReal -> TypedAST abt)
-> abt '[] 'HReal
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HReal -> abt '[] 'HReal -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HReal
SReal (abt '[] 'HReal -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HReal -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt 'HReal -> abt '[] 'HReal
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HReal] 'HReal -> SCon '[LC 'HReal] 'HReal
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[ 'HReal] 'HReal
y SCon '[LC 'HReal] 'HReal
-> SArgs abt '[LC 'HReal] -> Term abt 'HReal
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HReal
e' abt '[] 'HReal -> SArgs abt '[] -> SArgs abt '[LC 'HReal]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
U.Floor [AST]
es =
case [AST]
es of
[AST
e] -> do abt '[] 'HProb
e' <- Sing 'HProb -> AST -> TypeCheckMonad (abt '[] 'HProb)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HProb
SProb AST
e
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HNat -> TypedAST abt)
-> abt '[] 'HNat
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HNat -> abt '[] 'HNat -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HNat
SNat (abt '[] 'HNat -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HNat -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ Term abt 'HNat -> abt '[] 'HNat
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[ 'HProb] 'HNat -> SCon '[ '( '[], 'HProb)] 'HNat
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ PrimOp '[ 'HProb] 'HNat
Floor SCon '[ '( '[], 'HProb)] 'HNat
-> SArgs abt '[ '( '[], 'HProb)] -> Term abt 'HNat
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HProb
e' abt '[] 'HProb -> SArgs abt '[] -> SArgs abt '[ '( '[], 'HProb)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferPrimOp PrimOp
x [AST]
_ = [Char] -> TypeCheckMonad (TypedAST abt)
forall a. HasCallStack => [Char] -> a
error ([Char]
"TODO: inferPrimOp: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PrimOp -> [Char]
forall a. Show a => a -> [Char]
show PrimOp
x)
inferArrayOp :: U.ArrayOp
-> [U.AST]
-> TypeCheckMonad (TypedAST abt)
inferArrayOp :: ArrayOp -> [AST] -> TypeCheckMonad (TypedAST abt)
inferArrayOp ArrayOp
U.Index_ [AST]
es =
case [AST]
es of
[AST
e1, AST
e2] -> do TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
Unify1 'HArray (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HArray r x
unifyArray Sing b
typ1 Maybe SourceSpan
forall a. Maybe a
Nothing ((forall (a :: Hakaru).
(b ~ 'HArray a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HArray a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 -> do
abt '[] 'HNat
e2' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e2
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] a -> TypedAST abt)
-> abt '[] a
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing a -> abt '[] a -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing a
typ2 (abt '[] a -> TypeCheckMonad (TypedAST abt))
-> abt '[] a -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt a -> abt '[] a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (ArrayOp '[ 'HArray a, 'HNat] a -> SCon '[ '( '[], b), LC 'HNat] a
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
ArrayOp typs a -> SCon args a
ArrayOp_ (Sing a -> ArrayOp '[ 'HArray a, 'HNat] a
forall (a :: Hakaru). Sing a -> ArrayOp '[ 'HArray a, 'HNat] a
Index Sing a
typ2) SCon '[ '( '[], b), LC 'HNat] a
-> SArgs abt '[ '( '[], b), LC 'HNat] -> Term abt a
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[LC 'HNat] -> SArgs abt '[ '( '[], b), LC 'HNat]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] 'HNat
e2' abt '[] 'HNat -> SArgs abt '[] -> SArgs abt '[LC 'HNat]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferArrayOp ArrayOp
U.Size [AST]
es =
case [AST]
es of
[AST
e] -> do TypedAST Sing b
typ abt '[] b
e' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e
Unify1 'HArray (TypedAST abt) b
forall r (x :: Hakaru). Unify1 'HArray r x
unifyArray Sing b
typ Maybe SourceSpan
forall a. Maybe a
Nothing ((forall (a :: Hakaru).
(b ~ 'HArray a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
(b ~ 'HArray a) =>
Sing a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ1 ->
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] 'HNat -> TypedAST abt)
-> abt '[] 'HNat
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing 'HNat -> abt '[] 'HNat -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing 'HNat
SNat (abt '[] 'HNat -> TypeCheckMonad (TypedAST abt))
-> abt '[] 'HNat -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt 'HNat -> abt '[] 'HNat
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (ArrayOp '[ 'HArray a] 'HNat -> SCon '[ '( '[], b)] 'HNat
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
ArrayOp typs a -> SCon args a
ArrayOp_ (Sing a -> ArrayOp '[ 'HArray a] 'HNat
forall (a :: Hakaru). Sing a -> ArrayOp '[ 'HArray a] 'HNat
Size Sing a
typ1) SCon '[ '( '[], b)] 'HNat
-> SArgs abt '[ '( '[], b)] -> Term abt 'HNat
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e' abt '[] b -> SArgs abt '[] -> SArgs abt '[ '( '[], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferArrayOp ArrayOp
U.Reduce [AST]
es =
case [AST]
es of
[AST
e1, AST
e2, AST
e3] -> do
TypedAST Sing b
typ abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
Unify2 (':->) (TypedAST abt) b
forall r (x :: Hakaru). Unify2 (':->) r x
unifyFun Sing b
typ Maybe SourceSpan
forall a. Maybe a
Nothing ((forall (a :: Hakaru) (b :: Hakaru).
(b ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru) (b :: Hakaru).
(b ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ1 Sing b
typ2 -> do
TypeEq b (a ':-> a)
Refl <- Sing b -> Sing (a ':-> a) -> TypeCheckMonad (TypeEq b (a ':-> a))
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> TypeCheckMonad (TypeEq a b)
jmEq1_ Sing b
typ2 (Sing a -> Sing a -> Sing (a ':-> a)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (a ':-> b)
SFun Sing a
typ1 Sing a
typ1)
abt '[] a
e2' <- Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing a
typ1 AST
e2
abt '[] ('HArray a)
e3' <- Sing ('HArray a) -> AST -> TypeCheckMonad (abt '[] ('HArray a))
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ (Sing a -> Sing ('HArray a)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray Sing a
typ1) AST
e3
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> (abt '[] a -> TypedAST abt)
-> abt '[] a
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing a -> abt '[] a -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing a
typ1 (abt '[] a -> TypeCheckMonad (TypedAST abt))
-> abt '[] a -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$
Term abt a -> abt '[] a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (ArrayOp '[ a ':-> (a ':-> a), a, 'HArray a] a
-> SCon '[ '( '[], b), '( '[], a), '( '[], 'HArray a)] a
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
ArrayOp typs a -> SCon args a
ArrayOp_ (Sing a -> ArrayOp '[ a ':-> (a ':-> a), a, 'HArray a] a
forall (a :: Hakaru).
Sing a -> ArrayOp '[ a ':-> (a ':-> a), a, 'HArray a] a
Reduce Sing a
typ1)
SCon '[ '( '[], b), '( '[], a), '( '[], 'HArray a)] a
-> SArgs abt '[ '( '[], b), '( '[], a), '( '[], 'HArray a)]
-> Term abt a
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[], a), '( '[], 'HArray a)]
-> SArgs abt '[ '( '[], b), '( '[], a), '( '[], 'HArray a)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] a
e2' abt '[] a
-> SArgs abt '[ '( '[], 'HArray a)]
-> SArgs abt '[ '( '[], a), '( '[], 'HArray a)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] ('HArray a)
e3' abt '[] ('HArray a)
-> SArgs abt '[] -> SArgs abt '[ '( '[], 'HArray a)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
[AST]
_ -> TypeCheckMonad (TypedAST abt)
forall r. TypeCheckMonad r
argumentNumberError
inferReducer :: U.Reducer xs U.U_ABT 'U.U
-> List1 Variable xs1
-> TypeCheckMonad (TypedReducer abt xs1)
inferReducer :: Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
inferReducer (U.R_Fanout_ Reducer xs (MetaABT SourceSpan Term) 'U
r1 Reducer xs (MetaABT SourceSpan Term) 'U
r2) List1 Variable xs1
xs = do
TypedReducer Sing b
t1 List1 Variable xs1
_ Reducer abt xs1 b
r1' <- Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall (xs :: [Untyped]) (xs1 :: [Hakaru]).
Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
inferReducer Reducer xs (MetaABT SourceSpan Term) 'U
r1 List1 Variable xs1
xs
TypedReducer Sing b
t2 List1 Variable xs1
_ Reducer abt xs1 b
r2' <- Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall (xs :: [Untyped]) (xs1 :: [Hakaru]).
Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
inferReducer Reducer xs (MetaABT SourceSpan Term) 'U
r2 List1 Variable xs1
xs
TypedReducer abt xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall (m :: * -> *) a. Monad m => a -> m a
return (Sing (HPair b b)
-> List1 Variable xs1
-> Reducer abt xs1 (HPair b b)
-> TypedReducer abt xs1
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(b :: Hakaru).
Sing b
-> List1 Variable xs -> Reducer abt xs b -> TypedReducer abt xs
TypedReducer (Sing b -> Sing b -> Sing (HPair b b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (HPair a b)
sPair Sing b
t1 Sing b
t2) List1 Variable xs1
xs (Reducer abt xs1 b
-> Reducer abt xs1 b -> Reducer abt xs1 (HPair b b)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru) (b :: Hakaru).
Reducer abt xs a -> Reducer abt xs b -> Reducer abt xs (HPair a b)
Red_Fanout Reducer abt xs1 b
r1' Reducer abt xs1 b
r2'))
inferReducer (U.R_Index_ Variable 'U
x U_ABT xs 'U
n U_ABT ('U : xs) 'U
ix Reducer ('U : xs) (MetaABT SourceSpan Term) 'U
r1) List1 Variable xs1
xs = do
let (List1 Variable xs
_, AST
n') = U_ABT xs 'U -> (List1 Variable xs, AST)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(xs :: [k]) (a :: k).
ABT syn abt =>
abt xs a -> (List1 Variable xs, abt '[] a)
caseBinds U_ABT xs 'U
n
let b :: Variable 'HNat
b = Variable 'U -> Sing 'HNat -> Variable 'HNat
forall (a :: Hakaru). Variable 'U -> Sing a -> Variable a
makeVar Variable 'U
x Sing 'HNat
SNat
TypedReducer Sing b
t1 List1 Variable ('HNat : xs1)
_ Reducer abt ('HNat : xs1) b
r1' <- Reducer ('U : xs) (MetaABT SourceSpan Term) 'U
-> List1 Variable ('HNat : xs1)
-> TypeCheckMonad (TypedReducer abt ('HNat : xs1))
forall (xs :: [Untyped]) (xs1 :: [Hakaru]).
Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
inferReducer Reducer ('U : xs) (MetaABT SourceSpan Term) 'U
r1 (Variable 'HNat
-> List1 Variable xs1 -> List1 Variable ('HNat : xs1)
forall a (a :: a -> *) (x :: a) (xs :: [a]).
a x -> List1 a xs -> List1 a (x : xs)
Cons1 Variable 'HNat
b List1 Variable xs1
xs)
abt xs1 'HNat
n'' <- List1 Variable xs1
-> Sing 'HNat -> AST -> TypeCheckMonad (abt xs1 'HNat)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
List1 Variable xs -> Sing a -> AST -> TypeCheckMonad (abt xs a)
checkBinders List1 Variable xs1
xs Sing 'HNat
SNat AST
n'
U_ABT ('U : xs) 'U
-> (Variable 'U
-> U_ABT xs 'U -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind U_ABT ('U : xs) 'U
ix ((Variable 'U
-> U_ABT xs 'U -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1))
-> (Variable 'U
-> U_ABT xs 'U -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1)
forall a b. (a -> b) -> a -> b
$ \Variable 'U
i U_ABT xs 'U
ix1 ->
let i' :: Variable 'HNat
i' = Variable 'U -> Sing 'HNat -> Variable 'HNat
forall (a :: Hakaru). Variable 'U -> Sing a -> Variable a
makeVar Variable 'U
i Sing 'HNat
SNat
(List1 Variable xs
_, AST
ix2) = U_ABT xs 'U -> (List1 Variable xs, AST)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(xs :: [k]) (a :: k).
ABT syn abt =>
abt xs a -> (List1 Variable xs, abt '[] a)
caseBinds U_ABT xs 'U
ix1 in do
abt xs1 'HNat
ix3 <- Variable 'HNat
-> TypeCheckMonad (abt xs1 'HNat) -> TypeCheckMonad (abt xs1 'HNat)
forall (a :: Hakaru) b.
Variable a -> TypeCheckMonad b -> TypeCheckMonad b
pushCtx Variable 'HNat
i' (List1 Variable xs1
-> Sing 'HNat -> AST -> TypeCheckMonad (abt xs1 'HNat)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
List1 Variable xs -> Sing a -> AST -> TypeCheckMonad (abt xs a)
checkBinders List1 Variable xs1
xs Sing 'HNat
SNat AST
ix2)
TypedReducer abt xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedReducer abt xs1 -> TypeCheckMonad (TypedReducer abt xs1))
-> (Reducer abt xs1 ('HArray b) -> TypedReducer abt xs1)
-> Reducer abt xs1 ('HArray b)
-> TypeCheckMonad (TypedReducer abt xs1)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing ('HArray b)
-> List1 Variable xs1
-> Reducer abt xs1 ('HArray b)
-> TypedReducer abt xs1
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(b :: Hakaru).
Sing b
-> List1 Variable xs -> Reducer abt xs b -> TypedReducer abt xs
TypedReducer (Sing b -> Sing ('HArray b)
forall (a :: Hakaru). Sing a -> Sing ('HArray a)
SArray Sing b
t1) List1 Variable xs1
xs (Reducer abt xs1 ('HArray b)
-> TypeCheckMonad (TypedReducer abt xs1))
-> Reducer abt xs1 ('HArray b)
-> TypeCheckMonad (TypedReducer abt xs1)
forall a b. (a -> b) -> a -> b
$
abt xs1 'HNat
-> abt ('HNat : xs1) 'HNat
-> Reducer abt ('HNat : xs1) b
-> Reducer abt xs1 ('HArray b)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
abt xs 'HNat
-> abt ('HNat : xs) 'HNat
-> Reducer abt ('HNat : xs) a
-> Reducer abt xs ('HArray a)
Red_Index abt xs1 'HNat
n'' (Variable 'HNat -> abt xs1 'HNat -> abt ('HNat : xs1) 'HNat
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable 'HNat
i' abt xs1 'HNat
ix3) Reducer abt ('HNat : xs1) b
r1'
inferReducer (U.R_Split_ U_ABT ('U : xs) 'U
b Reducer xs (MetaABT SourceSpan Term) 'U
r1 Reducer xs (MetaABT SourceSpan Term) 'U
r2) List1 Variable xs1
xs = do
TypedReducer Sing b
t1 List1 Variable xs1
_ Reducer abt xs1 b
r1' <- Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall (xs :: [Untyped]) (xs1 :: [Hakaru]).
Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
inferReducer Reducer xs (MetaABT SourceSpan Term) 'U
r1 List1 Variable xs1
xs
TypedReducer Sing b
t2 List1 Variable xs1
_ Reducer abt xs1 b
r2' <- Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall (xs :: [Untyped]) (xs1 :: [Hakaru]).
Reducer xs (MetaABT SourceSpan Term) 'U
-> List1 Variable xs1 -> TypeCheckMonad (TypedReducer abt xs1)
inferReducer Reducer xs (MetaABT SourceSpan Term) 'U
r2 List1 Variable xs1
xs
U_ABT ('U : xs) 'U
-> (Variable 'U
-> U_ABT xs 'U -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind U_ABT ('U : xs) 'U
b ((Variable 'U
-> U_ABT xs 'U -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1))
-> (Variable 'U
-> U_ABT xs 'U -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1)
forall a b. (a -> b) -> a -> b
$ \Variable 'U
x U_ABT xs 'U
b1 ->
let (List1 Variable xs
_, AST
b2) = U_ABT xs 'U -> (List1 Variable xs, AST)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(xs :: [k]) (a :: k).
ABT syn abt =>
abt xs a -> (List1 Variable xs, abt '[] a)
caseBinds U_ABT xs 'U
b1
x' :: Variable 'HNat
x' = Variable 'U -> Sing 'HNat -> Variable 'HNat
forall (a :: Hakaru). Variable 'U -> Sing a -> Variable a
makeVar Variable 'U
x Sing 'HNat
SNat in do
abt xs1 HBool
b3 <- Variable 'HNat
-> TypeCheckMonad (abt xs1 HBool) -> TypeCheckMonad (abt xs1 HBool)
forall (a :: Hakaru) b.
Variable a -> TypeCheckMonad b -> TypeCheckMonad b
pushCtx Variable 'HNat
x' (List1 Variable xs1
-> Sing HBool -> AST -> TypeCheckMonad (abt xs1 HBool)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
List1 Variable xs -> Sing a -> AST -> TypeCheckMonad (abt xs a)
checkBinders List1 Variable xs1
xs Sing HBool
sBool AST
b2)
TypedReducer abt xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedReducer abt xs1 -> TypeCheckMonad (TypedReducer abt xs1))
-> (Reducer abt xs1 (HPair b b) -> TypedReducer abt xs1)
-> Reducer abt xs1 (HPair b b)
-> TypeCheckMonad (TypedReducer abt xs1)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing (HPair b b)
-> List1 Variable xs1
-> Reducer abt xs1 (HPair b b)
-> TypedReducer abt xs1
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(b :: Hakaru).
Sing b
-> List1 Variable xs -> Reducer abt xs b -> TypedReducer abt xs
TypedReducer (Sing b -> Sing b -> Sing (HPair b b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (HPair a b)
sPair Sing b
t1 Sing b
t2) List1 Variable xs1
xs (Reducer abt xs1 (HPair b b)
-> TypeCheckMonad (TypedReducer abt xs1))
-> Reducer abt xs1 (HPair b b)
-> TypeCheckMonad (TypedReducer abt xs1)
forall a b. (a -> b) -> a -> b
$
(abt ('HNat : xs1) HBool
-> Reducer abt xs1 b
-> Reducer abt xs1 b
-> Reducer abt xs1 (HPair b b)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru) (b :: Hakaru).
abt ('HNat : xs) HBool
-> Reducer abt xs a
-> Reducer abt xs b
-> Reducer abt xs (HPair a b)
Red_Split (Variable 'HNat -> abt xs1 HBool -> abt ('HNat : xs1) HBool
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable 'HNat
x' abt xs1 HBool
b3) Reducer abt xs1 b
r1' Reducer abt xs1 b
r2')
inferReducer Reducer xs (MetaABT SourceSpan Term) 'U
U.R_Nop_ List1 Variable xs1
xs = TypedReducer abt xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall (m :: * -> *) a. Monad m => a -> m a
return (Sing HUnit
-> List1 Variable xs1
-> Reducer abt xs1 HUnit
-> TypedReducer abt xs1
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(b :: Hakaru).
Sing b
-> List1 Variable xs -> Reducer abt xs b -> TypedReducer abt xs
TypedReducer Sing HUnit
sUnit List1 Variable xs1
xs Reducer abt xs1 HUnit
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru]).
Reducer abt xs HUnit
Red_Nop)
inferReducer (U.R_Add_ U_ABT ('U : xs) 'U
e) List1 Variable xs1
xs =
U_ABT ('U : xs) 'U
-> (Variable 'U
-> U_ABT xs 'U -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(x :: k) (xs :: [k]) (a :: k) r.
ABT syn abt =>
abt (x : xs) a -> (Variable x -> abt xs a -> r) -> r
caseBind U_ABT ('U : xs) 'U
e ((Variable 'U
-> U_ABT xs 'U -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1))
-> (Variable 'U
-> U_ABT xs 'U -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1)
forall a b. (a -> b) -> a -> b
$ \Variable 'U
x U_ABT xs 'U
e1 ->
let (List1 Variable xs
_, AST
e2) = U_ABT xs 'U -> (List1 Variable xs, AST)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(xs :: [k]) (a :: k).
ABT syn abt =>
abt xs a -> (List1 Variable xs, abt '[] a)
caseBinds U_ABT xs 'U
e1
x' :: Variable 'HNat
x' = Variable 'U -> Sing 'HNat -> Variable 'HNat
forall (a :: Hakaru). Variable 'U -> Sing a -> Variable a
makeVar Variable 'U
x Sing 'HNat
SNat in
Variable 'HNat
-> TypeCheckMonad (TypedReducer abt xs1)
-> TypeCheckMonad (TypedReducer abt xs1)
forall (a :: Hakaru) b.
Variable a -> TypeCheckMonad b -> TypeCheckMonad b
pushCtx Variable 'HNat
x' (TypeCheckMonad (TypedReducer abt xs1)
-> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1)
-> TypeCheckMonad (TypedReducer abt xs1)
forall a b. (a -> b) -> a -> b
$
List1 Variable xs1
-> AST
-> (forall (a :: Hakaru).
Sing a -> abt xs1 a -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru]) r.
ABT Term abt =>
List1 Variable xs
-> AST
-> (forall (a :: Hakaru). Sing a -> abt xs a -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinders List1 Variable xs1
xs AST
e2 ((forall (a :: Hakaru).
Sing a -> abt xs1 a -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1))
-> (forall (a :: Hakaru).
Sing a -> abt xs1 a -> TypeCheckMonad (TypedReducer abt xs1))
-> TypeCheckMonad (TypedReducer abt xs1)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ abt xs1 a
e3 -> do
HSemiring a
h <- Sing a -> TypeCheckMonad (HSemiring a)
forall (a :: Hakaru). Sing a -> TypeCheckMonad (HSemiring a)
getHSemiring Sing a
typ
TypedReducer abt xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedReducer abt xs1 -> TypeCheckMonad (TypedReducer abt xs1))
-> TypedReducer abt xs1 -> TypeCheckMonad (TypedReducer abt xs1)
forall a b. (a -> b) -> a -> b
$ Sing a
-> List1 Variable xs1 -> Reducer abt xs1 a -> TypedReducer abt xs1
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(b :: Hakaru).
Sing b
-> List1 Variable xs -> Reducer abt xs b -> TypedReducer abt xs
TypedReducer Sing a
typ List1 Variable xs1
xs (HSemiring a -> abt ('HNat : xs1) a -> Reducer abt xs1 a
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *)
(xs :: [Hakaru]).
HSemiring a -> abt ('HNat : xs) a -> Reducer abt xs a
Red_Add HSemiring a
h (Variable 'HNat -> abt xs1 a -> abt ('HNat : xs1) a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable 'HNat
x' abt xs1 a
e3))
inferOneCheckOthers
:: forall abt
. (ABT Term abt)
=> [U.AST]
-> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers :: [AST] -> TypeCheckMonad (TypedASTs abt)
inferOneCheckOthers = [AST] -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferOne []
where
inferOne :: [U.AST] -> [U.AST] -> TypeCheckMonad (TypedASTs abt)
inferOne :: [AST] -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferOne [AST]
ls []
| [AST] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AST]
ls = Maybe SourceSpan -> TypeCheckMonad (TypedASTs abt)
forall r. Maybe SourceSpan -> TypeCheckMonad r
ambiguousEmptyNary Maybe SourceSpan
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe SourceSpan -> TypeCheckMonad (TypedASTs abt)
forall r. Maybe SourceSpan -> TypeCheckMonad r
ambiguousMustCheckNary Maybe SourceSpan
forall a. Maybe a
Nothing
inferOne [AST]
ls (AST
e:[AST]
rs) = do
Maybe (TypedAST abt)
m <- TypeCheckMonad (TypedAST abt)
-> TypeCheckMonad (Maybe (TypedAST abt))
forall a. TypeCheckMonad a -> TypeCheckMonad (Maybe a)
try (TypeCheckMonad (TypedAST abt)
-> TypeCheckMonad (Maybe (TypedAST abt)))
-> TypeCheckMonad (TypedAST abt)
-> TypeCheckMonad (Maybe (TypedAST abt))
forall a b. (a -> b) -> a -> b
$ AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
e
case Maybe (TypedAST abt)
m of
Maybe (TypedAST abt)
Nothing -> [AST] -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferOne (AST
eAST -> [AST] -> [AST]
forall a. a -> [a] -> [a]
:[AST]
ls) [AST]
rs
Just (TypedAST Sing b
typ abt '[] b
e') -> do
[abt '[] b]
ls' <- Sing b -> [AST] -> TypeCheckMonad [abt '[] b]
forall (a :: Hakaru). Sing a -> [AST] -> TypeCheckMonad [abt '[] a]
checkOthers Sing b
typ [AST]
ls
[abt '[] b]
rs' <- Sing b -> [AST] -> TypeCheckMonad [abt '[] b]
forall (a :: Hakaru). Sing a -> [AST] -> TypeCheckMonad [abt '[] a]
checkOthers Sing b
typ [AST]
rs
TypedASTs abt -> TypeCheckMonad (TypedASTs abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Sing b -> [abt '[] b] -> TypedASTs abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> [abt '[] b] -> TypedASTs abt
TypedASTs Sing b
typ ([abt '[] b] -> [abt '[] b]
forall a. [a] -> [a]
reverse [abt '[] b]
ls' [abt '[] b] -> [abt '[] b] -> [abt '[] b]
forall a. [a] -> [a] -> [a]
++ abt '[] b
e' abt '[] b -> [abt '[] b] -> [abt '[] b]
forall a. a -> [a] -> [a]
: [abt '[] b]
rs'))
checkOthers
:: forall a. Sing a -> [U.AST] -> TypeCheckMonad [abt '[] a]
checkOthers :: Sing a -> [AST] -> TypeCheckMonad [abt '[] a]
checkOthers Sing a
typ = (AST -> TypeCheckMonad (abt '[] a))
-> [AST] -> TypeCheckMonad [abt '[] a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType Sing a
typ)
inferLubType
:: forall abt
. (ABT Term abt)
=> Maybe U.SourceSpan
-> [U.AST]
-> TypeCheckMonad (TypedASTs abt)
inferLubType :: Maybe SourceSpan -> [AST] -> TypeCheckMonad (TypedASTs abt)
inferLubType Maybe SourceSpan
s = [AST] -> TypeCheckMonad (TypedASTs abt)
start
where
start :: [U.AST] -> TypeCheckMonad (TypedASTs abt)
start :: [AST] -> TypeCheckMonad (TypedASTs abt)
start [] = Maybe SourceSpan -> TypeCheckMonad (TypedASTs abt)
forall r. Maybe SourceSpan -> TypeCheckMonad r
ambiguousEmptyNary Maybe SourceSpan
forall a. Maybe a
Nothing
start (AST
u:[AST]
us) = do
TypedAST Sing b
typ1 abt '[] b
e1 <- AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
u
TypedASTs Sing b
typ2 [abt '[] b]
es <- (TypedASTs abt -> AST -> TypeCheckMonad (TypedASTs abt))
-> TypedASTs abt -> [AST] -> TypeCheckMonad (TypedASTs abt)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
F.foldlM TypedASTs abt -> AST -> TypeCheckMonad (TypedASTs abt)
step (Sing b -> [abt '[] b] -> TypedASTs abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> [abt '[] b] -> TypedASTs abt
TypedASTs Sing b
typ1 [abt '[] b
e1]) [AST]
us
TypedASTs abt -> TypeCheckMonad (TypedASTs abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Sing b -> [abt '[] b] -> TypedASTs abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> [abt '[] b] -> TypedASTs abt
TypedASTs Sing b
typ2 ([abt '[] b] -> [abt '[] b]
forall a. [a] -> [a]
reverse [abt '[] b]
es))
step :: TypedASTs abt -> U.AST -> TypeCheckMonad (TypedASTs abt)
step :: TypedASTs abt -> AST -> TypeCheckMonad (TypedASTs abt)
step (TypedASTs Sing b
typ1 [abt '[] b]
es) AST
u = do
TypedAST Sing b
typ2 abt '[] b
e2 <- AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
u
case Sing b -> Sing b -> Maybe (Lub b b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Maybe (Lub a b)
findLub Sing b
typ1 Sing b
typ2 of
Maybe (Lub b b)
Nothing -> Sing b
-> Sing b -> Maybe SourceSpan -> TypeCheckMonad (TypedASTs abt)
forall (a :: Hakaru) (b :: Hakaru) r.
Sing a -> Sing b -> Maybe SourceSpan -> TypeCheckMonad r
missingLub Sing b
typ1 Sing b
typ2 Maybe SourceSpan
s
Just (Lub Sing c
typ Coercion b c
c1 Coercion b c
c2) ->
let es' :: [abt '[] c]
es' = (abt '[] b -> abt '[] c) -> [abt '[] b] -> [abt '[] c]
forall a b. (a -> b) -> [a] -> [b]
map (LC_ abt c -> abt '[] c
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt c -> abt '[] c)
-> (abt '[] b -> LC_ abt c) -> abt '[] b -> abt '[] c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion b c -> LC_ abt b -> LC_ abt c
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion b c
c1 (LC_ abt b -> LC_ abt c)
-> (abt '[] b -> LC_ abt b) -> abt '[] b -> LC_ abt c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. abt '[] b -> LC_ abt b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_) [abt '[] b]
es
e2' :: abt '[] c
e2' = LC_ abt c -> abt '[] c
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt c -> abt '[] c)
-> (LC_ abt b -> LC_ abt c) -> LC_ abt b -> abt '[] c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion b c -> LC_ abt b -> LC_ abt c
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion b c
c2 (LC_ abt b -> abt '[] c) -> LC_ abt b -> abt '[] c
forall a b. (a -> b) -> a -> b
$ abt '[] b -> LC_ abt b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ abt '[] b
e2
in TypedASTs abt -> TypeCheckMonad (TypedASTs abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Sing c -> [abt '[] c] -> TypedASTs abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> [abt '[] b] -> TypedASTs abt
TypedASTs Sing c
typ (abt '[] c
e2' abt '[] c -> [abt '[] c] -> [abt '[] c]
forall a. a -> [a] -> [a]
: [abt '[] c]
es'))
inferCaseStrict
:: forall abt a
. (ABT Term abt)
=> Sing a
-> abt '[] a
-> [U.Branch]
-> TypeCheckMonad (TypedAST abt)
inferCaseStrict :: Sing a
-> abt '[] a
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
inferCaseStrict Sing a
typA abt '[] a
e1 = [Branch_ (MetaABT SourceSpan Term)]
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
inferOne []
where
inferOne :: [U.Branch] -> [U.Branch] -> TypeCheckMonad (TypedAST abt)
inferOne :: [Branch_ (MetaABT SourceSpan Term)]
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
inferOne [Branch_ (MetaABT SourceSpan Term)]
ls []
| [Branch_ (MetaABT SourceSpan Term)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Branch_ (MetaABT SourceSpan Term)]
ls = Maybe SourceSpan -> TypeCheckMonad (TypedAST abt)
forall r. Maybe SourceSpan -> TypeCheckMonad r
ambiguousEmptyNary Maybe SourceSpan
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe SourceSpan -> TypeCheckMonad (TypedAST abt)
forall r. Maybe SourceSpan -> TypeCheckMonad r
ambiguousMustCheckNary Maybe SourceSpan
forall a. Maybe a
Nothing
inferOne [Branch_ (MetaABT SourceSpan Term)]
ls (b :: Branch_ (MetaABT SourceSpan Term)
b@(U.Branch_ Pattern
pat AST
e):[Branch_ (MetaABT SourceSpan Term)]
rs) = do
SP Pattern vars a
pat' List1 Variable vars
vars <- Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
forall (a :: Hakaru).
Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
checkPattern Sing a
typA Pattern
pat
Maybe (TypedAST abt)
m <- TypeCheckMonad (TypedAST abt)
-> TypeCheckMonad (Maybe (TypedAST abt))
forall a. TypeCheckMonad a -> TypeCheckMonad (Maybe a)
try (TypeCheckMonad (TypedAST abt)
-> TypeCheckMonad (Maybe (TypedAST abt)))
-> TypeCheckMonad (TypedAST abt)
-> TypeCheckMonad (Maybe (TypedAST abt))
forall a b. (a -> b) -> a -> b
$ List1 Variable vars
-> AST
-> (forall (a :: Hakaru).
Sing a -> abt vars a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru]) r.
ABT Term abt =>
List1 Variable xs
-> AST
-> (forall (a :: Hakaru). Sing a -> abt xs a -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinders List1 Variable vars
vars AST
e ((forall (a :: Hakaru).
Sing a -> abt vars a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
Sing a -> abt vars a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ abt vars a
e' -> do
[Branch a abt a]
ls' <- Sing a
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad [Branch a abt a]
forall (b :: Hakaru).
Sing b
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad [Branch a abt b]
checkOthers Sing a
typ [Branch_ (MetaABT SourceSpan Term)]
ls
[Branch a abt a]
rs' <- Sing a
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad [Branch a abt a]
forall (b :: Hakaru).
Sing b
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad [Branch a abt b]
checkOthers Sing a
typ [Branch_ (MetaABT SourceSpan Term)]
rs
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (Sing a -> abt '[] a -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing a
typ (abt '[] a -> TypedAST abt) -> abt '[] a -> TypedAST abt
forall a b. (a -> b) -> a -> b
$ Term abt a -> abt '[] a
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (abt '[] a -> [Branch a abt a] -> Term abt a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
abt '[] a -> [Branch a abt b] -> Term abt b
Case_ abt '[] a
e1 ([Branch a abt a] -> [Branch a abt a]
forall a. [a] -> [a]
reverse [Branch a abt a]
ls' [Branch a abt a] -> [Branch a abt a] -> [Branch a abt a]
forall a. [a] -> [a] -> [a]
++ (Pattern vars a -> abt vars a -> Branch a abt a
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru)
(xs :: [Hakaru]).
Pattern xs a -> abt xs b -> Branch a abt b
Branch Pattern vars a
pat' abt vars a
e') Branch a abt a -> [Branch a abt a] -> [Branch a abt a]
forall a. a -> [a] -> [a]
: [Branch a abt a]
rs')))
case Maybe (TypedAST abt)
m of
Maybe (TypedAST abt)
Nothing -> [Branch_ (MetaABT SourceSpan Term)]
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
inferOne (Branch_ (MetaABT SourceSpan Term)
bBranch_ (MetaABT SourceSpan Term)
-> [Branch_ (MetaABT SourceSpan Term)]
-> [Branch_ (MetaABT SourceSpan Term)]
forall a. a -> [a] -> [a]
:[Branch_ (MetaABT SourceSpan Term)]
ls) [Branch_ (MetaABT SourceSpan Term)]
rs
Just TypedAST abt
m' -> TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return TypedAST abt
m'
checkOthers
:: forall b. Sing b -> [U.Branch] -> TypeCheckMonad [Branch a abt b]
checkOthers :: Sing b
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad [Branch a abt b]
checkOthers Sing b
typ = (Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (Branch a abt b))
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad [Branch a abt b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse (Sing a
-> Sing b
-> Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (Branch a abt b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a
-> Sing b
-> Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (Branch a abt b)
checkBranch Sing a
typA Sing b
typ)
inferCaseLax
:: forall abt a
. (ABT Term abt)
=> Maybe U.SourceSpan
-> Sing a
-> abt '[] a
-> [U.Branch]
-> TypeCheckMonad (TypedAST abt)
inferCaseLax :: Maybe SourceSpan
-> Sing a
-> abt '[] a
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
inferCaseLax Maybe SourceSpan
s Sing a
typA abt '[] a
e1 = [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
start
where
start :: [U.Branch] -> TypeCheckMonad (TypedAST abt)
start :: [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (TypedAST abt)
start [] = Maybe SourceSpan -> TypeCheckMonad (TypedAST abt)
forall r. Maybe SourceSpan -> TypeCheckMonad r
ambiguousEmptyNary Maybe SourceSpan
forall a. Maybe a
Nothing
start ((U.Branch_ Pattern
pat AST
e):[Branch_ (MetaABT SourceSpan Term)]
us) = do
SP Pattern vars a
pat' List1 Variable vars
vars <- Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
forall (a :: Hakaru).
Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
checkPattern Sing a
typA Pattern
pat
List1 Variable vars
-> AST
-> (forall (a :: Hakaru).
Sing a -> abt vars a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru]) r.
ABT Term abt =>
List1 Variable xs
-> AST
-> (forall (a :: Hakaru). Sing a -> abt xs a -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinders List1 Variable vars
vars AST
e ((forall (a :: Hakaru).
Sing a -> abt vars a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt))
-> (forall (a :: Hakaru).
Sing a -> abt vars a -> TypeCheckMonad (TypedAST abt))
-> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ1 abt vars a
e' -> do
SomeBranch Sing b
typ2 [Branch a abt b]
bs <- (SomeBranch a abt
-> Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (SomeBranch a abt))
-> SomeBranch a abt
-> [Branch_ (MetaABT SourceSpan Term)]
-> TypeCheckMonad (SomeBranch a abt)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
F.foldlM SomeBranch a abt
-> Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (SomeBranch a abt)
step (Sing a -> [Branch a abt a] -> SomeBranch a abt
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *)
(b :: Hakaru).
Sing b -> [Branch a abt b] -> SomeBranch a abt
SomeBranch Sing a
typ1 [Pattern vars a -> abt vars a -> Branch a abt a
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru)
(xs :: [Hakaru]).
Pattern xs a -> abt xs b -> Branch a abt b
Branch Pattern vars a
pat' abt vars a
e']) [Branch_ (MetaABT SourceSpan Term)]
us
TypedAST abt -> TypeCheckMonad (TypedAST abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (TypedAST abt -> TypeCheckMonad (TypedAST abt))
-> ([Branch a abt b] -> TypedAST abt)
-> [Branch a abt b]
-> TypeCheckMonad (TypedAST abt)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Sing b -> abt '[] b -> TypedAST abt
forall (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru).
Sing b -> abt '[] b -> TypedAST abt
TypedAST Sing b
typ2 (abt '[] b -> TypedAST abt)
-> ([Branch a abt b] -> abt '[] b)
-> [Branch a abt b]
-> TypedAST abt
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term abt b -> abt '[] b)
-> ([Branch a abt b] -> Term abt b)
-> [Branch a abt b]
-> abt '[] b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. abt '[] a -> [Branch a abt b] -> Term abt b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
abt '[] a -> [Branch a abt b] -> Term abt b
Case_ abt '[] a
e1 ([Branch a abt b] -> TypeCheckMonad (TypedAST abt))
-> [Branch a abt b] -> TypeCheckMonad (TypedAST abt)
forall a b. (a -> b) -> a -> b
$ [Branch a abt b] -> [Branch a abt b]
forall a. [a] -> [a]
reverse [Branch a abt b]
bs
step :: SomeBranch a abt
-> U.Branch
-> TypeCheckMonad (SomeBranch a abt)
step :: SomeBranch a abt
-> Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (SomeBranch a abt)
step (SomeBranch Sing b
typB [Branch a abt b]
bs) (U.Branch_ Pattern
pat AST
e) = do
SP Pattern vars a
pat' List1 Variable vars
vars <- Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
forall (a :: Hakaru).
Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
checkPattern Sing a
typA Pattern
pat
List1 Variable vars
-> AST
-> (forall (a :: Hakaru).
Sing a -> abt vars a -> TypeCheckMonad (SomeBranch a abt))
-> TypeCheckMonad (SomeBranch a abt)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru]) r.
ABT Term abt =>
List1 Variable xs
-> AST
-> (forall (a :: Hakaru). Sing a -> abt xs a -> TypeCheckMonad r)
-> TypeCheckMonad r
inferBinders List1 Variable vars
vars AST
e ((forall (a :: Hakaru).
Sing a -> abt vars a -> TypeCheckMonad (SomeBranch a abt))
-> TypeCheckMonad (SomeBranch a abt))
-> (forall (a :: Hakaru).
Sing a -> abt vars a -> TypeCheckMonad (SomeBranch a abt))
-> TypeCheckMonad (SomeBranch a abt)
forall a b. (a -> b) -> a -> b
$ \Sing a
typE abt vars a
e' ->
case Sing b -> Sing a -> Maybe (Lub b a)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Maybe (Lub a b)
findLub Sing b
typB Sing a
typE of
Maybe (Lub b a)
Nothing -> Sing b
-> Sing a -> Maybe SourceSpan -> TypeCheckMonad (SomeBranch a abt)
forall (a :: Hakaru) (b :: Hakaru) r.
Sing a -> Sing b -> Maybe SourceSpan -> TypeCheckMonad r
missingLub Sing b
typB Sing a
typE Maybe SourceSpan
s
Just (Lub Sing c
typLub Coercion b c
coeB Coercion a c
coeE) ->
SomeBranch a abt -> TypeCheckMonad (SomeBranch a abt)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeBranch a abt -> TypeCheckMonad (SomeBranch a abt))
-> SomeBranch a abt -> TypeCheckMonad (SomeBranch a abt)
forall a b. (a -> b) -> a -> b
$ Sing c -> [Branch a abt c] -> SomeBranch a abt
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *)
(b :: Hakaru).
Sing b -> [Branch a abt b] -> SomeBranch a abt
SomeBranch Sing c
typLub
( Pattern vars a -> abt vars c -> Branch a abt c
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru)
(xs :: [Hakaru]).
Pattern xs a -> abt xs b -> Branch a abt b
Branch Pattern vars a
pat' (Coercion a c -> abt vars a -> abt vars c
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru) (b :: Hakaru)
(xs :: [Hakaru]).
ABT Term abt =>
Coercion a b -> abt xs a -> abt xs b
coerceTo_nonLC Coercion a c
coeE abt vars a
e')
Branch a abt c -> [Branch a abt c] -> [Branch a abt c]
forall a. a -> [a] -> [a]
: (Branch a abt b -> Branch a abt c)
-> [Branch a abt b] -> [Branch a abt c]
forall a b. (a -> b) -> [a] -> [b]
map (Coercion b c -> Branch a abt b -> Branch a abt c
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion b c
coeB) [Branch a abt b]
bs
)
checkSArgs
:: (ABT Term abt, typs ~ UnLCs args, args ~ LCs typs)
=> List1 Sing typs
-> [U.AST]
-> TypeCheckMonad (SArgs abt args)
checkSArgs :: List1 Sing typs -> [AST] -> TypeCheckMonad (SArgs abt args)
checkSArgs List1 Sing typs
Nil1 [] = SArgs abt '[] -> TypeCheckMonad (SArgs abt '[])
forall (m :: * -> *) a. Monad m => a -> m a
return SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End
checkSArgs (Cons1 Sing x
typ List1 Sing xs
typs) (AST
e:[AST]
es) =
abt '[] x -> SArgs abt (LCs xs) -> SArgs abt ('( '[], x) : LCs xs)
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
(:*) (abt '[] x
-> SArgs abt (LCs xs) -> SArgs abt ('( '[], x) : LCs xs))
-> TypeCheckMonad (abt '[] x)
-> TypeCheckMonad
(SArgs abt (LCs xs) -> SArgs abt ('( '[], x) : LCs xs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing x -> AST -> TypeCheckMonad (abt '[] x)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType Sing x
typ AST
e TypeCheckMonad
(SArgs abt (LCs xs) -> SArgs abt ('( '[], x) : LCs xs))
-> TypeCheckMonad (SArgs abt (LCs xs))
-> TypeCheckMonad (SArgs abt ('( '[], x) : LCs xs))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> List1 Sing xs -> [AST] -> TypeCheckMonad (SArgs abt (LCs xs))
forall (abt :: [Hakaru] -> Hakaru -> *) (typs :: [Hakaru])
(args :: [([Hakaru], Hakaru)]).
(ABT Term abt, typs ~ UnLCs args, args ~ LCs typs) =>
List1 Sing typs -> [AST] -> TypeCheckMonad (SArgs abt args)
checkSArgs List1 Sing xs
typs [AST]
es
checkSArgs List1 Sing typs
_ [AST]
_ =
[Char] -> TypeCheckMonad (SArgs abt args)
forall a. HasCallStack => [Char] -> a
error [Char]
"checkSArgs: the number of types and terms doesn't match up"
checkType
:: forall abt a
. (ABT Term abt)
=> Sing a
-> U.AST
-> TypeCheckMonad (abt '[] a)
checkType :: Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType = Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_
where
inferType_ :: U.AST -> TypeCheckMonad (TypedAST abt)
inferType_ :: AST -> TypeCheckMonad (TypedAST abt)
inferType_ = AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType
checkVariable
:: forall b
. Sing b
-> Maybe U.SourceSpan
-> Variable 'U.U
-> TypeCheckMonad (abt '[] b)
checkVariable :: Sing b
-> Maybe SourceSpan -> Variable 'U -> TypeCheckMonad (abt '[] b)
checkVariable Sing b
typ0 Maybe SourceSpan
sourceSpan Variable 'U
x = do
TypedAST Sing b
typ' abt '[] b
e0' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ (Variable 'U -> AST
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
Variable a -> abt '[] a
var Variable 'U
x)
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
case TypeCheckMode
mode of
TypeCheckMode
StrictMode ->
case Sing b -> Sing b -> Maybe (TypeEq b b)
forall k (a :: k -> *) (i :: k) (j :: k).
JmEq1 a =>
a i -> a j -> Maybe (TypeEq i j)
jmEq1 Sing b
typ0 Sing b
typ' of
Just TypeEq b b
Refl -> abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return abt '[] b
e0'
Maybe (TypeEq b b)
Nothing -> Maybe SourceSpan
-> Either TypeCheckError (Sing b)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad (abt '[] b)
forall (a :: Hakaru) (b :: Hakaru) r.
Maybe SourceSpan
-> Either TypeCheckError (Sing a)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad r
typeMismatch Maybe SourceSpan
sourceSpan (Sing b -> Either TypeCheckError (Sing b)
forall a b. b -> Either a b
Right Sing b
typ0) (Sing b -> Either TypeCheckError (Sing b)
forall a b. b -> Either a b
Right Sing b
typ')
TypeCheckMode
LaxMode -> Maybe SourceSpan
-> abt '[] b -> Sing b -> Sing b -> TypeCheckMonad (abt '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrCoerce Maybe SourceSpan
sourceSpan abt '[] b
e0' Sing b
typ' Sing b
typ0
TypeCheckMode
UnsafeMode -> Maybe SourceSpan
-> abt '[] b -> Sing b -> Sing b -> TypeCheckMonad (abt '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrUnsafeCoerce Maybe SourceSpan
sourceSpan abt '[] b
e0' Sing b
typ' Sing b
typ0
checkType_
:: forall b. Sing b -> U.AST -> TypeCheckMonad (abt '[] b)
checkType_ :: Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
typ0 AST
e0 =
let s :: Maybe SourceSpan
s = AST -> Maybe SourceSpan
forall meta k (syn :: ([k] -> k -> *) -> k -> *) (xs :: [k])
(a :: k).
MetaABT meta syn xs a -> Maybe meta
getMetadata AST
e0 in
AST
-> (Variable 'U -> TypeCheckMonad (abt '[] b))
-> (Term (MetaABT SourceSpan Term) 'U
-> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) r.
ABT syn abt =>
abt '[] a -> (Variable a -> r) -> (syn abt a -> r) -> r
caseVarSyn AST
e0 (Sing b
-> Maybe SourceSpan -> Variable 'U -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru).
Sing b
-> Maybe SourceSpan -> Variable 'U -> TypeCheckMonad (abt '[] b)
checkVariable Sing b
typ0 Maybe SourceSpan
s) (Maybe SourceSpan
-> Term (MetaABT SourceSpan Term) 'U -> TypeCheckMonad (abt '[] b)
go Maybe SourceSpan
s)
where
go :: Maybe SourceSpan
-> Term (MetaABT SourceSpan Term) 'U -> TypeCheckMonad (abt '[] b)
go Maybe SourceSpan
sourceSpan Term (MetaABT SourceSpan Term) 'U
t =
case Term (MetaABT SourceSpan Term) 'U
t of
U.Lam_ (U.SSing Sing a
typ) U_ABT '[ 'U] 'U
e1 ->
Unify2 (':->) (abt '[] b) b
forall r (x :: Hakaru). Unify2 (':->) r x
unifyFun Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru) (b :: Hakaru).
(b ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru) (b :: Hakaru).
(b ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ1 Sing b
typ2 ->
Sing a
-> Sing a
-> Maybe SourceSpan
-> ()
-> ()
-> ((a ~ a) => TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall t0 t1 (x :: Hakaru) (y :: Hakaru) r.
(TCMTypeRepr t0, TCMTypeRepr t1) =>
Sing x
-> Sing y
-> Maybe SourceSpan
-> t0
-> t1
-> ((x ~ y) => TypeCheckMonad r)
-> TypeCheckMonad r
matchTypes Sing a
typ1 Sing a
typ Maybe SourceSpan
sourceSpan () () (((a ~ a) => TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> ((a ~ a) => TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$
do abt '[a] b
e1' <- Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing a
typ1 Sing b
typ2 U_ABT '[ 'U] 'U
e1
abt '[] (a ':-> b) -> TypeCheckMonad (abt '[] (a ':-> b))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] (a ':-> b) -> TypeCheckMonad (abt '[] (a ':-> b)))
-> abt '[] (a ':-> b) -> TypeCheckMonad (abt '[] (a ':-> b))
forall a b. (a -> b) -> a -> b
$ Term abt (a ':-> b) -> abt '[] (a ':-> b)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[ '( '[a], b)] (a ':-> b)
forall (a :: Hakaru) (a :: Hakaru). SCon '[ '( '[a], a)] (a ':-> a)
Lam_ SCon '[ '( '[a], b)] (a ':-> b)
-> SArgs abt '[ '( '[a], b)] -> Term abt (a ':-> b)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[a] b
e1' abt '[a] b -> SArgs abt '[] -> SArgs abt '[ '( '[a], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Let_ AST
e1 U_ABT '[ 'U] 'U
e2 -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
abt '[b] b
e2' <- Sing b -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[b] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing b
typ1 Sing b
typ0 U_ABT '[ 'U] 'U
e2
abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> abt '[] b -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[LC b, '( '[b], b)] b
forall (a :: Hakaru) (b :: Hakaru). SCon '[LC a, '( '[a], b)] b
Let_ SCon '[LC b, '( '[b], b)] b
-> SArgs abt '[LC b, '( '[b], b)] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[b], b)] -> SArgs abt '[LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[b] b
e2' abt '[b] b -> SArgs abt '[] -> SArgs abt '[ '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.CoerceTo_ (Some2 Coercion i j
c) AST
e1 ->
case Coercion i j -> Maybe (Sing i, Sing j)
forall (a :: Hakaru) (b :: Hakaru).
Coercion a b -> Maybe (Sing a, Sing b)
singCoerceDomCod Coercion i j
c of
Maybe (Sing i, Sing j)
Nothing -> do
abt '[] b
e1' <- Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
typ0 AST
e1
abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> abt '[] b -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Coercion b b -> SCon '[LC b] b
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> SCon '[LC a] b
CoerceTo_ Coercion b b
forall (a :: Hakaru). Coercion a a
CNil SCon '[LC b] b -> SArgs abt '[LC b] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b -> SArgs abt '[] -> SArgs abt '[LC b]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
Just (Sing i
dom, Sing j
cod) ->
Sing b
-> Sing j
-> Maybe SourceSpan
-> ()
-> ()
-> ((b ~ j) => TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall t0 t1 (x :: Hakaru) (y :: Hakaru) r.
(TCMTypeRepr t0, TCMTypeRepr t1) =>
Sing x
-> Sing y
-> Maybe SourceSpan
-> t0
-> t1
-> ((x ~ y) => TypeCheckMonad r)
-> TypeCheckMonad r
matchTypes Sing b
typ0 Sing j
cod Maybe SourceSpan
sourceSpan () () (((b ~ j) => TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> ((b ~ j) => TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ do
abt '[] i
e1' <- Sing i -> AST -> TypeCheckMonad (abt '[] i)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing i
dom AST
e1
abt '[] j -> TypeCheckMonad (abt '[] j)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] j -> TypeCheckMonad (abt '[] j))
-> abt '[] j -> TypeCheckMonad (abt '[] j)
forall a b. (a -> b) -> a -> b
$ Term abt j -> abt '[] j
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Coercion i j -> SCon '[LC i] j
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> SCon '[LC a] b
CoerceTo_ Coercion i j
c SCon '[LC i] j -> SArgs abt '[LC i] -> Term abt j
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] i
e1' abt '[] i -> SArgs abt '[] -> SArgs abt '[LC i]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.UnsafeTo_ (Some2 Coercion i j
c) AST
e1 ->
case Coercion i j -> Maybe (Sing i, Sing j)
forall (a :: Hakaru) (b :: Hakaru).
Coercion a b -> Maybe (Sing a, Sing b)
singCoerceDomCod Coercion i j
c of
Maybe (Sing i, Sing j)
Nothing -> do
abt '[] b
e1' <- Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
typ0 AST
e1
abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> abt '[] b -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Coercion b b -> SCon '[LC b] b
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> SCon '[LC b] a
UnsafeFrom_ Coercion b b
forall (a :: Hakaru). Coercion a a
CNil SCon '[LC b] b -> SArgs abt '[LC b] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b -> SArgs abt '[] -> SArgs abt '[LC b]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
Just (Sing i
dom, Sing j
cod) ->
Sing b
-> Sing i
-> Maybe SourceSpan
-> ()
-> ()
-> ((b ~ i) => TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall t0 t1 (x :: Hakaru) (y :: Hakaru) r.
(TCMTypeRepr t0, TCMTypeRepr t1) =>
Sing x
-> Sing y
-> Maybe SourceSpan
-> t0
-> t1
-> ((x ~ y) => TypeCheckMonad r)
-> TypeCheckMonad r
matchTypes Sing b
typ0 Sing i
dom Maybe SourceSpan
sourceSpan () () (((b ~ i) => TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> ((b ~ i) => TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ do
abt '[] j
e1' <- Sing j -> AST -> TypeCheckMonad (abt '[] j)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing j
cod AST
e1
abt '[] i -> TypeCheckMonad (abt '[] i)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] i -> TypeCheckMonad (abt '[] i))
-> abt '[] i -> TypeCheckMonad (abt '[] i)
forall a b. (a -> b) -> a -> b
$ Term abt i -> abt '[] i
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Coercion i j -> SCon '[LC j] i
forall (a :: Hakaru) (b :: Hakaru). Coercion a b -> SCon '[LC b] a
UnsafeFrom_ Coercion i j
c SCon '[LC j] i -> SArgs abt '[LC j] -> Term abt i
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] j
e1' abt '[] j -> SArgs abt '[] -> SArgs abt '[LC j]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.PrimOp_ PrimOp
U.Infinity [] -> do
case Sing b
typ0 of
Sing b
SNat -> abt '[] 'HNat -> TypeCheckMonad (abt '[] 'HNat)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] 'HNat -> TypeCheckMonad (abt '[] 'HNat))
-> abt '[] 'HNat -> TypeCheckMonad (abt '[] 'HNat)
forall a b. (a -> b) -> a -> b
$
Term abt 'HNat -> abt '[] 'HNat
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[] 'HNat -> SCon '[] 'HNat
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ (HIntegrable 'HNat -> PrimOp '[] 'HNat
forall (a :: Hakaru). HIntegrable a -> PrimOp '[] a
Infinity HIntegrable 'HNat
HIntegrable_Nat) SCon '[] 'HNat -> SArgs abt '[] -> Term abt 'HNat
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
Sing b
SInt -> Maybe SourceSpan
-> abt '[] 'HNat
-> Sing 'HNat
-> Sing 'HInt
-> TypeCheckMonad (abt '[] 'HInt)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrCoerce Maybe SourceSpan
sourceSpan (Term abt 'HNat -> abt '[] 'HNat
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[] 'HNat -> SCon '[] 'HNat
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ (HIntegrable 'HNat -> PrimOp '[] 'HNat
forall (a :: Hakaru). HIntegrable a -> PrimOp '[] a
Infinity HIntegrable 'HNat
HIntegrable_Nat) SCon '[] 'HNat -> SArgs abt '[] -> Term abt 'HNat
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End))
Sing 'HNat
SNat
Sing 'HInt
SInt
Sing b
SProb -> abt '[] 'HProb -> TypeCheckMonad (abt '[] 'HProb)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] 'HProb -> TypeCheckMonad (abt '[] 'HProb))
-> abt '[] 'HProb -> TypeCheckMonad (abt '[] 'HProb)
forall a b. (a -> b) -> a -> b
$
Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[] 'HProb -> SCon '[] 'HProb
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ (HIntegrable 'HProb -> PrimOp '[] 'HProb
forall (a :: Hakaru). HIntegrable a -> PrimOp '[] a
Infinity HIntegrable 'HProb
HIntegrable_Prob) SCon '[] 'HProb -> SArgs abt '[] -> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
Sing b
SReal -> Maybe SourceSpan
-> abt '[] 'HProb
-> Sing 'HProb
-> Sing 'HReal
-> TypeCheckMonad (abt '[] 'HReal)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrCoerce Maybe SourceSpan
sourceSpan (Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (PrimOp '[] 'HProb -> SCon '[] 'HProb
forall (typs :: [Hakaru]) (args :: [([Hakaru], Hakaru)])
(a :: Hakaru).
(typs ~ UnLCs args, args ~ LCs typs) =>
PrimOp typs a -> SCon args a
PrimOp_ (HIntegrable 'HProb -> PrimOp '[] 'HProb
forall (a :: Hakaru). HIntegrable a -> PrimOp '[] a
Infinity HIntegrable 'HProb
HIntegrable_Prob) SCon '[] 'HProb -> SArgs abt '[] -> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End))
Sing 'HProb
SProb
Sing 'HReal
SReal
Sing b
_ -> TypeCheckError -> TypeCheckMonad (abt '[] b)
forall r. TypeCheckError -> TypeCheckMonad r
failwith (TypeCheckError -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad TypeCheckError -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
TypeCheckError
-> Maybe SourceSpan
-> TypeCheckError
-> TypeCheckMonad TypeCheckError
makeErrMsg
TypeCheckError
"Type Mismatch:"
Maybe SourceSpan
sourceSpan
TypeCheckError
"infinity can only be checked against nat or prob"
U.Product_ AST
e1 AST
e2 U_ABT '[ 'U] 'U
e3 ->
case Sing b -> Maybe (HSemiring b)
forall (a :: Hakaru). Sing a -> Maybe (HSemiring a)
hSemiring_Sing Sing b
typ0 of
Maybe (HSemiring b)
Nothing -> TypeCheckError -> TypeCheckMonad (abt '[] b)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"Product given factors which are not in a semiring"
Just HSemiring b
h2 -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
e1
abt '[] b
e2' <- Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
typ1 AST
e2
case Sing b -> Maybe (HDiscrete b)
forall (a :: Hakaru). Sing a -> Maybe (HDiscrete a)
hDiscrete_Sing Sing b
typ1 of
Maybe (HDiscrete b)
Nothing -> TypeCheckError -> TypeCheckMonad (abt '[] b)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"Product given bounds which are not discrete"
Just HDiscrete b
h1 -> do
abt '[b] b
e3' <- Sing b -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[b] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing b
typ1 Sing b
typ0 U_ABT '[ 'U] 'U
e3
abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> abt '[] b -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (HDiscrete b -> HSemiring b -> SCon '[LC b, LC b, '( '[b], b)] b
forall (a :: Hakaru) (b :: Hakaru).
HDiscrete a -> HSemiring b -> SCon '[LC a, LC a, '( '[a], b)] b
Product HDiscrete b
h1 HSemiring b
h2 SCon '[LC b, LC b, '( '[b], b)] b
-> SArgs abt '[LC b, LC b, '( '[b], b)] -> Term abt b
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[LC b, '( '[b], b)]
-> SArgs abt '[LC b, LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] b
e2' abt '[] b
-> SArgs abt '[ '( '[b], b)] -> SArgs abt '[LC b, '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[b] b
e3' abt '[b] b -> SArgs abt '[] -> SArgs abt '[ '( '[b], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.NaryOp_ NaryOp
op [AST]
es -> do
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
case TypeCheckMode
mode of
TypeCheckMode
StrictMode -> Sing b -> TypeCheckMonad (abt '[] b)
forall (c :: Hakaru). Sing c -> TypeCheckMonad (abt '[] c)
safeNaryOp Sing b
typ0
TypeCheckMode
LaxMode -> Sing b -> TypeCheckMonad (abt '[] b)
forall (c :: Hakaru). Sing c -> TypeCheckMonad (abt '[] c)
safeNaryOp Sing b
typ0
TypeCheckMode
UnsafeMode -> case NaryOp
op of
NaryOp
U.Prod -> do
NaryOp b
op' <- Sing b -> NaryOp -> TypeCheckMonad (NaryOp b)
forall (a :: Hakaru). Sing a -> NaryOp -> TypeCheckMonad (NaryOp a)
make_NaryOp Sing b
typ0 NaryOp
op
([AST]
bads, [abt '[] b]
goods) <-
([Either AST (abt '[] b)] -> ([AST], [abt '[] b]))
-> TypeCheckMonad [Either AST (abt '[] b)]
-> TypeCheckMonad ([AST], [abt '[] b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either AST (abt '[] b)] -> ([AST], [abt '[] b])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (TypeCheckMonad [Either AST (abt '[] b)]
-> TypeCheckMonad ([AST], [abt '[] b]))
-> ((AST -> TypeCheckMonad (Either AST (abt '[] b)))
-> TypeCheckMonad [Either AST (abt '[] b)])
-> (AST -> TypeCheckMonad (Either AST (abt '[] b)))
-> TypeCheckMonad ([AST], [abt '[] b])
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [AST]
-> (AST -> TypeCheckMonad (Either AST (abt '[] b)))
-> TypeCheckMonad [Either AST (abt '[] b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM [AST]
es ((AST -> TypeCheckMonad (Either AST (abt '[] b)))
-> TypeCheckMonad ([AST], [abt '[] b]))
-> (AST -> TypeCheckMonad (Either AST (abt '[] b)))
-> TypeCheckMonad ([AST], [abt '[] b])
forall a b. (a -> b) -> a -> b
$ \AST
e -> do
Maybe (abt '[] b)
r <- TypeCheckMode
-> TypeCheckMonad (abt '[] b) -> TypeCheckMonad (Maybe (abt '[] b))
forall a.
TypeCheckMode -> TypeCheckMonad a -> TypeCheckMonad (Maybe a)
tryWith TypeCheckMode
LaxMode (Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
typ0 AST
e)
case Maybe (abt '[] b)
r of
Just abt '[] b
er -> Either AST (abt '[] b) -> TypeCheckMonad (Either AST (abt '[] b))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> Either AST (abt '[] b)
forall a b. b -> Either a b
Right abt '[] b
er)
Maybe (abt '[] b)
Nothing -> do
Maybe (abt '[] b)
r <- TypeCheckMonad (abt '[] b) -> TypeCheckMonad (Maybe (abt '[] b))
forall a. TypeCheckMonad a -> TypeCheckMonad (Maybe a)
try (do TypedAST Sing b
t abt '[] b
p <- AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
e
Maybe SourceSpan
-> abt '[] b -> Sing b -> Sing b -> TypeCheckMonad (abt '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrCoerce Maybe SourceSpan
sourceSpan abt '[] b
p Sing b
t Sing b
typ0)
case Maybe (abt '[] b)
r of
Just abt '[] b
er -> Either AST (abt '[] b) -> TypeCheckMonad (Either AST (abt '[] b))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> Either AST (abt '[] b)
forall a b. b -> Either a b
Right abt '[] b
er)
Maybe (abt '[] b)
Nothing -> Either AST (abt '[] b) -> TypeCheckMonad (Either AST (abt '[] b))
forall (m :: * -> *) a. Monad m => a -> m a
return (AST -> Either AST (abt '[] b)
forall a b. a -> Either a b
Left AST
e)
if [AST] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AST]
bads
then abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> abt '[] b -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (NaryOp b -> Seq (abt '[] b) -> Term abt b
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *).
NaryOp a -> Seq (abt '[] a) -> Term abt a
NaryOp_ NaryOp b
op' ([abt '[] b] -> Seq (abt '[] b)
forall a. [a] -> Seq a
S.fromList [abt '[] b]
goods))
else do TypedAST Sing b
typ abt '[] b
bad <- AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType (case [AST]
bads of
[AST
b] -> AST
b
[AST]
_ -> Term (MetaABT SourceSpan Term) 'U -> AST
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term (MetaABT SourceSpan Term) 'U -> AST)
-> Term (MetaABT SourceSpan Term) 'U -> AST
forall a b. (a -> b) -> a -> b
$ NaryOp -> [AST] -> Term (MetaABT SourceSpan Term) 'U
forall (abt :: [Untyped] -> Untyped -> *).
NaryOp -> [abt '[] 'U] -> Term abt 'U
U.NaryOp_ NaryOp
op [AST]
bads)
abt '[] b
bad <- Maybe SourceSpan
-> abt '[] b -> Sing b -> Sing b -> TypeCheckMonad (abt '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrUnsafeCoerce Maybe SourceSpan
sourceSpan abt '[] b
bad Sing b
typ Sing b
typ0
abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (case abt '[] b
badabt '[] b -> [abt '[] b] -> [abt '[] b]
forall a. a -> [a] -> [a]
:[abt '[] b]
goods of
[abt '[] b
e] -> abt '[] b
e
[abt '[] b]
es' -> Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term abt b -> abt '[] b) -> Term abt b -> abt '[] b
forall a b. (a -> b) -> a -> b
$ NaryOp b -> Seq (abt '[] b) -> Term abt b
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *).
NaryOp a -> Seq (abt '[] a) -> Term abt a
NaryOp_ NaryOp b
op' ([abt '[] b] -> Seq (abt '[] b)
forall a. [a] -> Seq a
S.fromList [abt '[] b]
es'))
NaryOp
_ -> do
Maybe (abt '[] b)
es' <- TypeCheckMode
-> TypeCheckMonad (abt '[] b) -> TypeCheckMonad (Maybe (abt '[] b))
forall a.
TypeCheckMode -> TypeCheckMonad a -> TypeCheckMonad (Maybe a)
tryWith TypeCheckMode
LaxMode (Sing b -> TypeCheckMonad (abt '[] b)
forall (c :: Hakaru). Sing c -> TypeCheckMonad (abt '[] c)
safeNaryOp Sing b
typ0)
case Maybe (abt '[] b)
es' of
Just abt '[] b
es'' -> abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return abt '[] b
es''
Maybe (abt '[] b)
Nothing -> do
TypedAST Sing b
typ abt '[] b
e0' <- AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType (Term (MetaABT SourceSpan Term) 'U -> AST
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term (MetaABT SourceSpan Term) 'U -> AST)
-> Term (MetaABT SourceSpan Term) 'U -> AST
forall a b. (a -> b) -> a -> b
$ NaryOp -> [AST] -> Term (MetaABT SourceSpan Term) 'U
forall (abt :: [Untyped] -> Untyped -> *).
NaryOp -> [abt '[] 'U] -> Term abt 'U
U.NaryOp_ NaryOp
op [AST]
es)
Maybe SourceSpan
-> abt '[] b -> Sing b -> Sing b -> TypeCheckMonad (abt '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrUnsafeCoerce Maybe SourceSpan
sourceSpan abt '[] b
e0' Sing b
typ Sing b
typ0
where
safeNaryOp :: forall c. Sing c -> TypeCheckMonad (abt '[] c)
safeNaryOp :: Sing c -> TypeCheckMonad (abt '[] c)
safeNaryOp Sing c
typ = do
NaryOp c
op' <- Sing c -> NaryOp -> TypeCheckMonad (NaryOp c)
forall (a :: Hakaru). Sing a -> NaryOp -> TypeCheckMonad (NaryOp a)
make_NaryOp Sing c
typ NaryOp
op
[abt '[] c]
es' <- [AST]
-> (AST -> TypeCheckMonad (abt '[] c))
-> TypeCheckMonad [abt '[] c]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM [AST]
es ((AST -> TypeCheckMonad (abt '[] c)) -> TypeCheckMonad [abt '[] c])
-> (AST -> TypeCheckMonad (abt '[] c))
-> TypeCheckMonad [abt '[] c]
forall a b. (a -> b) -> a -> b
$ Sing c -> AST -> TypeCheckMonad (abt '[] c)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing c
typ
abt '[] c -> TypeCheckMonad (abt '[] c)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] c -> TypeCheckMonad (abt '[] c))
-> abt '[] c -> TypeCheckMonad (abt '[] c)
forall a b. (a -> b) -> a -> b
$ Term abt c -> abt '[] c
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (NaryOp c -> Seq (abt '[] c) -> Term abt c
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *).
NaryOp a -> Seq (abt '[] a) -> Term abt a
NaryOp_ NaryOp c
op' ([abt '[] c] -> Seq (abt '[] c)
forall a. [a] -> Seq a
S.fromList [abt '[] c]
es'))
U.Pair_ AST
e1 AST
e2 ->
Unify2 HPair (abt '[] b) b
forall r (x :: Hakaru). Unify2 HPair r x
unifyPair Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru) (b :: Hakaru).
(b ~ HPair a b) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru) (b :: Hakaru).
(b ~ HPair a b) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
a Sing b
b -> do
abt '[] a
e1' <- Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing a
a AST
e1
abt '[] b
e2' <- Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
b AST
e2
abt '[] ('HData (('TyCon "Pair" ':@ a) ':@ b) '[ '[ 'K a, 'K b]])
-> TypeCheckMonad
(abt '[] ('HData (('TyCon "Pair" ':@ a) ':@ b) '[ '[ 'K a, 'K b]]))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HData (('TyCon "Pair" ':@ a) ':@ b) '[ '[ 'K a, 'K b]])
-> TypeCheckMonad
(abt
'[] ('HData (('TyCon "Pair" ':@ a) ':@ b) '[ '[ 'K a, 'K b]])))
-> abt
'[] ('HData (('TyCon "Pair" ':@ a) ':@ b) '[ '[ 'K a, 'K b]])
-> TypeCheckMonad
(abt '[] ('HData (('TyCon "Pair" ':@ a) ':@ b) '[ '[ 'K a, 'K b]]))
forall a b. (a -> b) -> a -> b
$ Term abt ('HData (('TyCon "Pair" ':@ a) ':@ b) '[ '[ 'K a, 'K b]])
-> abt
'[] ('HData (('TyCon "Pair" ':@ a) ':@ b) '[ '[ 'K a, 'K b]])
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Datum (abt '[]) (HData' (('TyCon "Pair" ':@ a) ':@ b))
-> Term abt (HData' (('TyCon "Pair" ':@ a) ':@ b))
forall (abt :: [Hakaru] -> Hakaru -> *) (t :: HakaruCon).
Datum (abt '[]) (HData' t) -> Term abt (HData' t)
Datum_ (Datum (abt '[]) (HData' (('TyCon "Pair" ':@ a) ':@ b))
-> Term abt (HData' (('TyCon "Pair" ':@ a) ':@ b)))
-> Datum (abt '[]) (HData' (('TyCon "Pair" ':@ a) ':@ b))
-> Term abt (HData' (('TyCon "Pair" ':@ a) ':@ b))
forall a b. (a -> b) -> a -> b
$ Sing a
-> Sing b
-> abt '[] a
-> abt '[] b
-> Datum
(abt '[]) ('HData (('TyCon "Pair" ':@ a) ':@ b) '[ '[ 'K a, 'K b]])
forall (a :: Hakaru) (b :: Hakaru) (ast :: Hakaru -> *).
Sing a -> Sing b -> ast a -> ast b -> Datum ast (HPair a b)
dPair_ Sing a
a Sing b
b abt '[] a
e1' abt '[] b
e2')
U.Array_ AST
e1 U_ABT '[ 'U] 'U
e2 ->
Unify1 'HArray (abt '[] b) b
forall r (x :: Hakaru). Unify1 'HArray r x
unifyArray Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HArray a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(b ~ 'HArray a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ1 -> do
abt '[] 'HNat
e1' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e1
abt '[ 'HNat] a
e2' <- Sing 'HNat
-> Sing a -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[ 'HNat] a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing 'HNat
SNat Sing a
typ1 U_ABT '[ 'U] 'U
e2
abt '[] ('HArray a) -> TypeCheckMonad (abt '[] ('HArray a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HArray a) -> TypeCheckMonad (abt '[] ('HArray a)))
-> abt '[] ('HArray a) -> TypeCheckMonad (abt '[] ('HArray a))
forall a b. (a -> b) -> a -> b
$ Term abt ('HArray a) -> abt '[] ('HArray a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (abt '[] 'HNat -> abt '[ 'HNat] a -> Term abt ('HArray a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] 'HNat -> abt '[ 'HNat] a -> Term abt ('HArray a)
Array_ abt '[] 'HNat
e1' abt '[ 'HNat] a
e2')
U.ArrayLiteral_ [AST]
es ->
Unify1 'HArray (abt '[] b) b
forall r (x :: Hakaru). Unify1 'HArray r x
unifyArray Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HArray a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(b ~ 'HArray a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ1 ->
if [AST] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AST]
es then abt '[] ('HArray a) -> TypeCheckMonad (abt '[] ('HArray a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HArray a) -> TypeCheckMonad (abt '[] ('HArray a)))
-> abt '[] ('HArray a) -> TypeCheckMonad (abt '[] ('HArray a))
forall a b. (a -> b) -> a -> b
$ Term abt ('HArray a) -> abt '[] ('HArray a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Sing ('HArray a) -> Term abt ('HArray a)
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *).
Sing ('HArray a) -> Term abt ('HArray a)
Empty_ Sing b
Sing ('HArray a)
typ0) else do
[abt '[] a]
es' <- [AST]
-> (AST -> TypeCheckMonad (abt '[] a))
-> TypeCheckMonad [abt '[] a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM [AST]
es ((AST -> TypeCheckMonad (abt '[] a)) -> TypeCheckMonad [abt '[] a])
-> (AST -> TypeCheckMonad (abt '[] a))
-> TypeCheckMonad [abt '[] a]
forall a b. (a -> b) -> a -> b
$ Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing a
typ1
abt '[] ('HArray a) -> TypeCheckMonad (abt '[] ('HArray a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HArray a) -> TypeCheckMonad (abt '[] ('HArray a)))
-> abt '[] ('HArray a) -> TypeCheckMonad (abt '[] ('HArray a))
forall a b. (a -> b) -> a -> b
$ Term abt ('HArray a) -> abt '[] ('HArray a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn ([abt '[] a] -> Term abt ('HArray a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
[abt '[] a] -> Term abt ('HArray a)
ArrayLiteral_ [abt '[] a]
es')
U.Datum_ (U.Datum TypeCheckError
hint DCode (MetaABT SourceSpan Term)
d) ->
case Sing b
typ0 of
SData _ typ2 ->
(Term abt ('HData t (Code t)) -> abt '[] ('HData t (Code t))
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term abt ('HData t (Code t)) -> abt '[] ('HData t (Code t)))
-> (DatumCode (Code t) (abt '[]) ('HData t (Code t))
-> Term abt ('HData t (Code t)))
-> DatumCode (Code t) (abt '[]) ('HData t (Code t))
-> abt '[] ('HData t (Code t))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Datum (abt '[]) ('HData t (Code t)) -> Term abt ('HData t (Code t))
forall (abt :: [Hakaru] -> Hakaru -> *) (t :: HakaruCon).
Datum (abt '[]) (HData' t) -> Term abt (HData' t)
Datum_ (Datum (abt '[]) ('HData t (Code t))
-> Term abt ('HData t (Code t)))
-> (DatumCode (Code t) (abt '[]) ('HData t (Code t))
-> Datum (abt '[]) ('HData t (Code t)))
-> DatumCode (Code t) (abt '[]) ('HData t (Code t))
-> Term abt ('HData t (Code t))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TypeCheckError
-> Sing ('HData t (Code t))
-> DatumCode (Code t) (abt '[]) ('HData t (Code t))
-> Datum (abt '[]) ('HData t (Code t))
forall (xss :: HakaruCon) (ast :: Hakaru -> *).
TypeCheckError
-> Sing (HData' xss)
-> DatumCode (Code xss) ast (HData' xss)
-> Datum ast (HData' xss)
Datum TypeCheckError
hint Sing b
Sing ('HData t (Code t))
typ0)
(DatumCode (Code t) (abt '[]) ('HData t (Code t))
-> abt '[] ('HData t (Code t)))
-> TypeCheckMonad
(DatumCode (Code t) (abt '[]) ('HData t (Code t)))
-> TypeCheckMonad (abt '[] ('HData t (Code t)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing ('HData t (Code t))
-> Sing (Code t)
-> DCode (MetaABT SourceSpan Term)
-> TypeCheckMonad
(DatumCode (Code t) (abt '[]) ('HData t (Code t)))
forall (xss :: [[HakaruFun]]) (t :: HakaruCon).
Sing (HData' t)
-> Sing xss
-> DCode (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumCode xss (abt '[]) (HData' t))
checkDatumCode Sing b
Sing ('HData t (Code t))
typ0 Sing (Code t)
typ2 DCode (MetaABT SourceSpan Term)
d
Sing b
_ -> Maybe SourceSpan
-> Either TypeCheckError (Sing b)
-> Either TypeCheckError (Sing Any)
-> TypeCheckMonad (abt '[] b)
forall (a :: Hakaru) (b :: Hakaru) r.
Maybe SourceSpan
-> Either TypeCheckError (Sing a)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad r
typeMismatch Maybe SourceSpan
sourceSpan (Sing b -> Either TypeCheckError (Sing b)
forall a b. b -> Either a b
Right Sing b
typ0) (TypeCheckError -> Either TypeCheckError (Sing Any)
forall a b. a -> Either a b
Left TypeCheckError
"HData")
U.Case_ AST
e1 [Branch_ (MetaABT SourceSpan Term)]
branches -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
[Branch b abt b]
branches' <- [Branch_ (MetaABT SourceSpan Term)]
-> (Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (Branch b abt b))
-> TypeCheckMonad [Branch b abt b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM [Branch_ (MetaABT SourceSpan Term)]
branches ((Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (Branch b abt b))
-> TypeCheckMonad [Branch b abt b])
-> (Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (Branch b abt b))
-> TypeCheckMonad [Branch b abt b]
forall a b. (a -> b) -> a -> b
$ Sing b
-> Sing b
-> Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (Branch b abt b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a
-> Sing b
-> Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (Branch a abt b)
checkBranch Sing b
typ1 Sing b
typ0
abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> abt '[] b -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ Term abt b -> abt '[] b
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (abt '[] b -> [Branch b abt b] -> Term abt b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
abt '[] a -> [Branch a abt b] -> Term abt b
Case_ abt '[] b
e1' [Branch b abt b]
branches')
U.Dirac_ AST
e1 ->
Unify1 'HMeasure (abt '[] b) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ1 -> do
abt '[] a
e1' <- Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing a
typ1 AST
e1
abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a)))
-> abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[LC a] ('HMeasure a)
forall (a :: Hakaru). SCon '[LC a] ('HMeasure a)
Dirac SCon '[LC a] ('HMeasure a)
-> SArgs abt '[LC a] -> Term abt ('HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] a
e1' abt '[] a -> SArgs abt '[] -> SArgs abt '[LC a]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.MBind_ AST
e1 U_ABT '[ 'U] 'U
e2 ->
Unify1 'HMeasure (abt '[] b) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
_ -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e1
Unify1 'HMeasure (abt '[] b) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ1 (AST -> Maybe SourceSpan
forall meta k (syn :: ([k] -> k -> *) -> k -> *) (xs :: [k])
(a :: k).
MetaABT meta syn xs a -> Maybe meta
getMetadata AST
e1) ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 -> do
abt '[a] b
e2' <- Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing a
typ2 Sing b
typ0 U_ABT '[ 'U] 'U
e2
abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a)))
-> abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[LC ('HMeasure a), '( '[a], 'HMeasure a)] ('HMeasure a)
forall (a :: Hakaru) (a :: Hakaru).
SCon '[LC ('HMeasure a), '( '[a], 'HMeasure a)] ('HMeasure a)
MBind SCon '[LC ('HMeasure a), '( '[a], 'HMeasure a)] ('HMeasure a)
-> SArgs abt '[LC ('HMeasure a), '( '[a], 'HMeasure a)]
-> Term abt ('HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[a], b)]
-> SArgs abt '[ '( '[], b), '( '[a], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[a] b
e2' abt '[a] b -> SArgs abt '[] -> SArgs abt '[ '( '[a], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Plate_ AST
e1 U_ABT '[ 'U] 'U
e2 ->
Unify1 'HMeasure (abt '[] b) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ1 -> do
abt '[] 'HNat
e1' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e1
Unify1 'HArray (abt '[] b) a
forall r (x :: Hakaru). Unify1 'HArray r x
unifyArray Sing a
typ1 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(a ~ 'HArray a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(a ~ 'HArray a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 -> do
abt '[ 'HNat] ('HMeasure a)
e2' <- Sing 'HNat
-> Sing ('HMeasure a)
-> U_ABT '[ 'U] 'U
-> TypeCheckMonad (abt '[ 'HNat] ('HMeasure a))
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing 'HNat
SNat (Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure Sing a
typ2) U_ABT '[ 'U] 'U
e2
abt '[] ('HMeasure ('HArray a))
-> TypeCheckMonad (abt '[] ('HMeasure ('HArray a)))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HMeasure ('HArray a))
-> TypeCheckMonad (abt '[] ('HMeasure ('HArray a))))
-> abt '[] ('HMeasure ('HArray a))
-> TypeCheckMonad (abt '[] ('HMeasure ('HArray a)))
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure ('HArray a)) -> abt '[] ('HMeasure ('HArray a))
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon
'[LC 'HNat, '( '[ 'HNat], 'HMeasure a)] ('HMeasure ('HArray a))
forall (a :: Hakaru).
SCon
'[LC 'HNat, '( '[ 'HNat], 'HMeasure a)] ('HMeasure ('HArray a))
Plate SCon
'[LC 'HNat, '( '[ 'HNat], 'HMeasure a)] ('HMeasure ('HArray a))
-> SArgs abt '[LC 'HNat, '( '[ 'HNat], 'HMeasure a)]
-> Term abt ('HMeasure ('HArray a))
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HNat
e1' abt '[] 'HNat
-> SArgs abt '[ '( '[ 'HNat], 'HMeasure a)]
-> SArgs abt '[LC 'HNat, '( '[ 'HNat], 'HMeasure a)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[ 'HNat] ('HMeasure a)
e2' abt '[ 'HNat] ('HMeasure a)
-> SArgs abt '[] -> SArgs abt '[ '( '[ 'HNat], 'HMeasure a)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Chain_ AST
e1 AST
e2 U_ABT '[ 'U] 'U
e3 ->
Unify1 'HMeasure (abt '[] b) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
typ1 ->
Unify2 HPair (abt '[] b) a
forall r (x :: Hakaru). Unify2 HPair r x
unifyPair Sing a
typ1 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru) (b :: Hakaru).
(a ~ HPair a b) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru) (b :: Hakaru).
(a ~ HPair a b) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
aa Sing b
s ->
Unify1 'HArray (abt '[] b) a
forall r (x :: Hakaru). Unify1 'HArray r x
unifyArray Sing a
aa Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(a ~ 'HArray a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(a ~ 'HArray a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
a -> do
abt '[] 'HNat
e1' <- Sing 'HNat -> AST -> TypeCheckMonad (abt '[] 'HNat)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HNat
SNat AST
e1
abt '[] b
e2' <- Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
s AST
e2
abt '[b] ('HMeasure (HPair a b))
e3' <- Sing b
-> Sing ('HMeasure (HPair a b))
-> U_ABT '[ 'U] 'U
-> TypeCheckMonad (abt '[b] ('HMeasure (HPair a b)))
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing b
s (Sing (HPair a b) -> Sing ('HMeasure (HPair a b))
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure (Sing (HPair a b) -> Sing ('HMeasure (HPair a b)))
-> Sing (HPair a b) -> Sing ('HMeasure (HPair a b))
forall a b. (a -> b) -> a -> b
$ Sing a -> Sing b -> Sing (HPair a b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (HPair a b)
sPair Sing a
a Sing b
s) U_ABT '[ 'U] 'U
e3
abt '[] ('HMeasure (HPair ('HArray a) b))
-> TypeCheckMonad (abt '[] ('HMeasure (HPair ('HArray a) b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HMeasure (HPair ('HArray a) b))
-> TypeCheckMonad (abt '[] ('HMeasure (HPair ('HArray a) b))))
-> abt '[] ('HMeasure (HPair ('HArray a) b))
-> TypeCheckMonad (abt '[] ('HMeasure (HPair ('HArray a) b)))
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure (HPair ('HArray a) b))
-> abt '[] ('HMeasure (HPair ('HArray a) b))
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon
'[LC 'HNat, LC b, '( '[b], 'HMeasure (HPair a b))]
('HMeasure (HPair ('HArray a) b))
forall (s :: Hakaru) (a :: Hakaru).
SCon
'[LC 'HNat, LC s, '( '[s], 'HMeasure (HPair a s))]
('HMeasure (HPair ('HArray a) s))
Chain SCon
'[LC 'HNat, LC b, '( '[b], 'HMeasure (HPair a b))]
('HMeasure (HPair ('HArray a) b))
-> SArgs abt '[LC 'HNat, LC b, '( '[b], 'HMeasure (HPair a b))]
-> Term abt ('HMeasure (HPair ('HArray a) b))
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] 'HNat
e1' abt '[] 'HNat
-> SArgs abt '[LC b, '( '[b], 'HMeasure (HPair a b))]
-> SArgs abt '[LC 'HNat, LC b, '( '[b], 'HMeasure (HPair a b))]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] b
e2' abt '[] b
-> SArgs abt '[ '( '[b], 'HMeasure (HPair a b))]
-> SArgs abt '[LC b, '( '[b], 'HMeasure (HPair a b))]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[b] ('HMeasure (HPair a b))
e3' abt '[b] ('HMeasure (HPair a b))
-> SArgs abt '[] -> SArgs abt '[ '( '[b], 'HMeasure (HPair a b))]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
U.Transform_ Transform as x
tr SArgs (MetaABT SourceSpan Term) as
es -> Maybe SourceSpan
-> Sing b
-> Transform as x
-> SArgs (MetaABT SourceSpan Term) as
-> TypeCheckMonad (abt '[] b)
forall (x' :: Hakaru) (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Maybe SourceSpan
-> Sing x'
-> Transform as x
-> SArgs (MetaABT SourceSpan Term) as
-> TypeCheckMonad (abt '[] x')
checkTransform Maybe SourceSpan
sourceSpan Sing b
typ0 Transform as x
tr SArgs (MetaABT SourceSpan Term) as
es
U.Superpose_ NonEmpty (AST, AST)
pes ->
Unify1 'HMeasure (abt '[] b) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
_ ->
(NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> abt '[] ('HMeasure a))
-> TypeCheckMonad
(NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a)))
-> TypeCheckMonad (abt '[] ('HMeasure a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term abt ('HMeasure a) -> abt '[] ('HMeasure a))
-> (NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> Term abt ('HMeasure a))
-> NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> abt '[] ('HMeasure a)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> Term abt ('HMeasure a)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))
-> Term abt ('HMeasure a)
Superpose_) (TypeCheckMonad (NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a)))
-> TypeCheckMonad (abt '[] ('HMeasure a)))
-> (((AST, AST)
-> TypeCheckMonad (abt '[] 'HProb, abt '[] ('HMeasure a)))
-> TypeCheckMonad
(NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a))))
-> ((AST, AST)
-> TypeCheckMonad (abt '[] 'HProb, abt '[] ('HMeasure a)))
-> TypeCheckMonad (abt '[] ('HMeasure a))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
NonEmpty (AST, AST)
-> ((AST, AST)
-> TypeCheckMonad (abt '[] 'HProb, abt '[] ('HMeasure a)))
-> TypeCheckMonad
(NonEmpty (abt '[] 'HProb, abt '[] ('HMeasure a)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
T.forM NonEmpty (AST, AST)
pes (((AST, AST) -> TypeCheckMonad (abt '[] 'HProb, abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> ((AST, AST) -> TypeCheckMonad (abt '[] 'HProb, abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \(AST
p,AST
e) ->
(,) (abt '[] 'HProb -> abt '[] b -> (abt '[] 'HProb, abt '[] b))
-> TypeCheckMonad (abt '[] 'HProb)
-> TypeCheckMonad (abt '[] b -> (abt '[] 'HProb, abt '[] b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing 'HProb -> AST -> TypeCheckMonad (abt '[] 'HProb)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing 'HProb
SProb AST
p TypeCheckMonad (abt '[] b -> (abt '[] 'HProb, abt '[] b))
-> TypeCheckMonad (abt '[] b)
-> TypeCheckMonad (abt '[] 'HProb, abt '[] b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sing b -> AST -> TypeCheckMonad (abt '[] b)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing b
typ0 AST
e
Term (MetaABT SourceSpan Term) 'U
U.Reject_ ->
Unify1 'HMeasure (abt '[] b) b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] b))
-> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ \Sing a
_ ->
abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a)))
-> abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Sing ('HMeasure a) -> Term abt ('HMeasure a)
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *).
Sing ('HMeasure a) -> Term abt ('HMeasure a)
Reject_ Sing b
Sing ('HMeasure a)
typ0)
U.InjTyped forall (abt' :: [Hakaru] -> Hakaru -> *).
ABT Term abt' =>
abt' '[] x
t ->
let typ1 :: Sing x
typ1 = TrivialABT Term '[] x -> Sing x
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
abt '[] a -> Sing a
typeOf (TrivialABT Term '[] x -> Sing x)
-> TrivialABT Term '[] x -> Sing x
forall a b. (a -> b) -> a -> b
$ TrivialABT Term '[] x -> TrivialABT Term '[] x
forall (a :: Hakaru).
TrivialABT Term '[] a -> TrivialABT Term '[] a
triv TrivialABT Term '[] x
forall (abt' :: [Hakaru] -> Hakaru -> *).
ABT Term abt' =>
abt' '[] x
t
in case Sing b -> Sing x -> Maybe (TypeEq b x)
forall k (a :: k -> *) (i :: k) (j :: k).
JmEq1 a =>
a i -> a j -> Maybe (TypeEq i j)
jmEq1 Sing b
typ0 Sing x
typ1 of
Just TypeEq b x
Refl -> abt '[] x -> TypeCheckMonad (abt '[] x)
forall (m :: * -> *) a. Monad m => a -> m a
return abt '[] x
forall (abt' :: [Hakaru] -> Hakaru -> *).
ABT Term abt' =>
abt' '[] x
t
Maybe (TypeEq b x)
Nothing -> Maybe SourceSpan
-> Either TypeCheckError (Sing b)
-> Either TypeCheckError (Sing x)
-> TypeCheckMonad (abt '[] b)
forall (a :: Hakaru) (b :: Hakaru) r.
Maybe SourceSpan
-> Either TypeCheckError (Sing a)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad r
typeMismatch Maybe SourceSpan
sourceSpan (Sing b -> Either TypeCheckError (Sing b)
forall a b. b -> Either a b
Right Sing b
typ0) (Sing x -> Either TypeCheckError (Sing x)
forall a b. b -> Either a b
Right Sing x
typ1)
Term (MetaABT SourceSpan Term) 'U
_ | AST -> Bool
inferable AST
e0 -> do
TypedAST Sing b
typ' abt '[] b
e0' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ AST
e0
TypeCheckMode
mode <- TypeCheckMonad TypeCheckMode
getMode
case TypeCheckMode
mode of
TypeCheckMode
StrictMode ->
case Sing b -> Sing b -> Maybe (TypeEq b b)
forall k (a :: k -> *) (i :: k) (j :: k).
JmEq1 a =>
a i -> a j -> Maybe (TypeEq i j)
jmEq1 Sing b
typ0 Sing b
typ' of
Just TypeEq b b
Refl -> abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return abt '[] b
e0'
Maybe (TypeEq b b)
Nothing -> Maybe SourceSpan
-> Either TypeCheckError (Sing b)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad (abt '[] b)
forall (a :: Hakaru) (b :: Hakaru) r.
Maybe SourceSpan
-> Either TypeCheckError (Sing a)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad r
typeMismatch Maybe SourceSpan
sourceSpan (Sing b -> Either TypeCheckError (Sing b)
forall a b. b -> Either a b
Right Sing b
typ0) (Sing b -> Either TypeCheckError (Sing b)
forall a b. b -> Either a b
Right Sing b
typ')
TypeCheckMode
LaxMode -> Maybe SourceSpan
-> abt '[] b -> Sing b -> Sing b -> TypeCheckMonad (abt '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrCoerce Maybe SourceSpan
sourceSpan abt '[] b
e0' Sing b
typ' Sing b
typ0
TypeCheckMode
UnsafeMode -> Maybe SourceSpan
-> abt '[] b -> Sing b -> Sing b -> TypeCheckMonad (abt '[] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrUnsafeCoerce Maybe SourceSpan
sourceSpan abt '[] b
e0' Sing b
typ' Sing b
typ0
| Bool
otherwise -> [Char] -> TypeCheckMonad (abt '[] b)
forall a. HasCallStack => [Char] -> a
error [Char]
"checkType: missing an mustCheck branch!"
checkTransform
:: Maybe U.SourceSpan
-> Sing x'
-> Transform as x
-> U.SArgs U.U_ABT as
-> TypeCheckMonad (abt '[] x')
checkTransform :: Maybe SourceSpan
-> Sing x'
-> Transform as x
-> SArgs (MetaABT SourceSpan Term) as
-> TypeCheckMonad (abt '[] x')
checkTransform Maybe SourceSpan
sourceSpan Sing x'
typ0
Transform as x
Expect
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* (Cons2 ToUntyped x y
U.ToU List2 ToUntyped xs ys
Nil2, U_ABT varsu 'U
e2) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) =
case Sing x'
typ0 of
Sing x'
SProb -> do
TypedAST Sing b
typ1 abt '[] b
e1' <- AST -> TypeCheckMonad (TypedAST abt)
inferType_ U_ABT varsu 'U
AST
e1
Unify1 'HMeasure (abt '[] x') b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typ1 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x'))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 -> do
abt '[a] x'
e2' <- Sing a
-> Sing x' -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] x')
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing a
typ2 Sing x'
typ0 U_ABT varsu 'U
U_ABT '[ 'U] 'U
e2
abt '[] 'HProb -> TypeCheckMonad (abt '[] 'HProb)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] 'HProb -> TypeCheckMonad (abt '[] 'HProb))
-> abt '[] 'HProb -> TypeCheckMonad (abt '[] 'HProb)
forall a b. (a -> b) -> a -> b
$ Term abt 'HProb -> abt '[] 'HProb
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Transform '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
-> SCon '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
forall (a :: Hakaru).
Transform '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
Expect SCon '[LC ('HMeasure a), '( '[a], 'HProb)] 'HProb
-> SArgs abt '[LC ('HMeasure a), '( '[a], 'HProb)]
-> Term abt 'HProb
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] b
e1' abt '[] b
-> SArgs abt '[ '( '[a], x')]
-> SArgs abt '[ '( '[], b), '( '[a], x')]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[a] x'
e2' abt '[a] x' -> SArgs abt '[] -> SArgs abt '[ '( '[a], x')]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
Sing x'
_ -> Maybe SourceSpan
-> Either TypeCheckError (Sing x')
-> Either TypeCheckError (Sing Any)
-> TypeCheckMonad (abt '[] x')
forall (a :: Hakaru) (b :: Hakaru) r.
Maybe SourceSpan
-> Either TypeCheckError (Sing a)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad r
typeMismatch Maybe SourceSpan
sourceSpan (Sing x' -> Either TypeCheckError (Sing x')
forall a b. b -> Either a b
Right Sing x'
typ0) (TypeCheckError -> Either TypeCheckError (Sing Any)
forall a b. a -> Either a b
Left TypeCheckError
"HProb")
checkTransform Maybe SourceSpan
sourceSpan Sing x'
typ0
Transform as x
Observe
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e2) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) =
Unify1 'HMeasure (abt '[] x') x'
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing x'
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(x' ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x'))
-> (forall (a :: Hakaru).
(x' ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ \Sing a
typ2 -> do
abt '[] x'
e1' <- Sing x' -> AST -> TypeCheckMonad (abt '[] x')
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing x'
typ0 U_ABT varsu 'U
AST
e1
abt '[] a
e2' <- Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing a
typ2 U_ABT varsu 'U
AST
e2
abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a)))
-> abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Transform '[LC ('HMeasure a), LC a] ('HMeasure a)
-> SCon '[LC ('HMeasure a), LC a] ('HMeasure a)
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[LC ('HMeasure a), LC a] ('HMeasure a)
forall (a :: Hakaru).
Transform '[LC ('HMeasure a), LC a] ('HMeasure a)
Observe SCon '[LC ('HMeasure a), LC a] ('HMeasure a)
-> SArgs abt '[LC ('HMeasure a), LC a] -> Term abt ('HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] x'
e1' abt '[] x' -> SArgs abt '[LC a] -> SArgs abt '[ '( '[], x'), LC a]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] a
e2' abt '[] a -> SArgs abt '[] -> SArgs abt '[LC a]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
checkTransform Maybe SourceSpan
sourceSpan Sing x'
typ0
Transform as x
MCMC
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* (List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e2) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) =
Unify2 (':->) (abt '[] x') x'
forall r (x :: Hakaru). Unify2 (':->) r x
unifyFun Sing x'
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru) (b :: Hakaru).
(x' ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x'))
-> (forall (a :: Hakaru) (b :: Hakaru).
(x' ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ \Sing a
typa Sing b
typmb ->
Unify1 'HMeasure (abt '[] x') b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typmb Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x'))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ \Sing a
typb ->
Sing a
-> Sing a
-> Maybe SourceSpan
-> Sing (a ':-> 'HMeasure a)
-> Sing x'
-> ((a ~ a) => TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x')
forall t0 t1 (x :: Hakaru) (y :: Hakaru) r.
(TCMTypeRepr t0, TCMTypeRepr t1) =>
Sing x
-> Sing y
-> Maybe SourceSpan
-> t0
-> t1
-> ((x ~ y) => TypeCheckMonad r)
-> TypeCheckMonad r
matchTypes Sing a
typa Sing a
typb Maybe SourceSpan
sourceSpan (Sing a -> Sing ('HMeasure a) -> Sing (a ':-> 'HMeasure a)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (a ':-> b)
SFun Sing a
typa (Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure Sing a
typa)) Sing x'
typ0 (((a ~ a) => TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x'))
-> ((a ~ a) => TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ do
abt '[] (a ':-> 'HMeasure a)
e1' <- Sing (a ':-> 'HMeasure a)
-> AST -> TypeCheckMonad (abt '[] (a ':-> 'HMeasure a))
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType (Sing a -> Sing ('HMeasure a) -> Sing (a ':-> 'HMeasure a)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (a ':-> b)
SFun Sing a
typa (Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure Sing a
typa)) U_ABT varsu 'U
AST
e1
abt '[] ('HMeasure a)
e2' <- Sing ('HMeasure a) -> AST -> TypeCheckMonad (abt '[] ('HMeasure a))
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType (Sing a -> Sing ('HMeasure a)
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure Sing a
typa) U_ABT varsu 'U
AST
e2
abt '[] (a ':-> 'HMeasure a)
-> TypeCheckMonad (abt '[] (a ':-> 'HMeasure a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] (a ':-> 'HMeasure a)
-> TypeCheckMonad (abt '[] (a ':-> 'HMeasure a)))
-> abt '[] (a ':-> 'HMeasure a)
-> TypeCheckMonad (abt '[] (a ':-> 'HMeasure a))
forall a b. (a -> b) -> a -> b
$ Term abt (a ':-> 'HMeasure a) -> abt '[] (a ':-> 'HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term abt (a ':-> 'HMeasure a) -> abt '[] (a ':-> 'HMeasure a))
-> Term abt (a ':-> 'HMeasure a) -> abt '[] (a ':-> 'HMeasure a)
forall a b. (a -> b) -> a -> b
$ Transform
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
-> SCon
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
forall (a :: Hakaru).
Transform
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
MCMC SCon
'[LC (a ':-> 'HMeasure a), LC ('HMeasure a)] (a ':-> 'HMeasure a)
-> SArgs abt '[LC (a ':-> 'HMeasure a), LC ('HMeasure a)]
-> Term abt (a ':-> 'HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] (a ':-> 'HMeasure a)
e1' abt '[] (a ':-> 'HMeasure a)
-> SArgs abt '[LC ('HMeasure a)]
-> SArgs abt '[LC (a ':-> 'HMeasure a), LC ('HMeasure a)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[] ('HMeasure a)
e2' abt '[] ('HMeasure a)
-> SArgs abt '[] -> SArgs abt '[LC ('HMeasure a)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End
checkTransform Maybe SourceSpan
sourceSpan Sing x'
typ0
(Disint TransformImpl
k)
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) =
Unify2 (':->) (abt '[] x') x'
forall r (x :: Hakaru). Unify2 (':->) r x
unifyFun Sing x'
typ0 Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru) (b :: Hakaru).
(x' ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x'))
-> (forall (a :: Hakaru) (b :: Hakaru).
(x' ~ (a ':-> b)) =>
Sing a -> Sing b -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ \Sing a
typa Sing b
typmb ->
Unify1 'HMeasure (abt '[] x') b
forall r (x :: Hakaru). Unify1 'HMeasure r x
unifyMeasure Sing b
typmb Maybe SourceSpan
sourceSpan ((forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x'))
-> (forall (a :: Hakaru).
(b ~ 'HMeasure a) =>
Sing a -> TypeCheckMonad (abt '[] x'))
-> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ \Sing a
typb -> do
abt '[] ('HMeasure (HPair a a))
e1' <- Sing ('HMeasure (HPair a a))
-> AST -> TypeCheckMonad (abt '[] ('HMeasure (HPair a a)))
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
ABT Term abt =>
Sing a -> AST -> TypeCheckMonad (abt '[] a)
checkType (Sing (HPair a a) -> Sing ('HMeasure (HPair a a))
forall (a :: Hakaru). Sing a -> Sing ('HMeasure a)
SMeasure (Sing a -> Sing a -> Sing (HPair a a)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Sing (HPair a b)
sPair Sing a
typa Sing a
typb)) U_ABT varsu 'U
AST
e1
abt '[] (a ':-> 'HMeasure a)
-> TypeCheckMonad (abt '[] (a ':-> 'HMeasure a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] (a ':-> 'HMeasure a)
-> TypeCheckMonad (abt '[] (a ':-> 'HMeasure a)))
-> abt '[] (a ':-> 'HMeasure a)
-> TypeCheckMonad (abt '[] (a ':-> 'HMeasure a))
forall a b. (a -> b) -> a -> b
$ Term abt (a ':-> 'HMeasure a) -> abt '[] (a ':-> 'HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term abt (a ':-> 'HMeasure a) -> abt '[] (a ':-> 'HMeasure a))
-> Term abt (a ':-> 'HMeasure a) -> abt '[] (a ':-> 'HMeasure a)
forall a b. (a -> b) -> a -> b
$ Transform '[LC ('HMeasure (HPair a a))] (a ':-> 'HMeasure a)
-> SCon '[LC ('HMeasure (HPair a a))] (a ':-> 'HMeasure a)
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ (TransformImpl
-> Transform '[LC ('HMeasure (HPair a a))] (a ':-> 'HMeasure a)
forall (a :: Hakaru) (b :: Hakaru).
TransformImpl
-> Transform '[LC ('HMeasure (HPair a b))] (a ':-> 'HMeasure b)
Disint TransformImpl
k) SCon '[LC ('HMeasure (HPair a a))] (a ':-> 'HMeasure a)
-> SArgs abt '[LC ('HMeasure (HPair a a))]
-> Term abt (a ':-> 'HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] ('HMeasure (HPair a a))
e1' abt '[] ('HMeasure (HPair a a))
-> SArgs abt '[] -> SArgs abt '[LC ('HMeasure (HPair a a))]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End
checkTransform Maybe SourceSpan
sourceSpan Sing x'
typ0
Transform as x
Simplify
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
abt '[] x'
e1' <- Sing x' -> AST -> TypeCheckMonad (abt '[] x')
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing x'
typ0 U_ABT varsu 'U
AST
e1
abt '[] x' -> TypeCheckMonad (abt '[] x')
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] x' -> TypeCheckMonad (abt '[] x'))
-> abt '[] x' -> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ Term abt x' -> abt '[] x'
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Transform '[ '( '[], x')] x' -> SCon '[ '( '[], x')] x'
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[ '( '[], x')] x'
forall (a :: Hakaru). Transform '[LC a] a
Simplify SCon '[ '( '[], x')] x' -> SArgs abt '[ '( '[], x')] -> Term abt x'
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] x'
e1' abt '[] x' -> SArgs abt '[] -> SArgs abt '[ '( '[], x')]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
checkTransform Maybe SourceSpan
sourceSpan Sing x'
typ0
Transform as x
Reparam
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
abt '[] x'
e1' <- Sing x' -> AST -> TypeCheckMonad (abt '[] x')
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing x'
typ0 U_ABT varsu 'U
AST
e1
abt '[] x' -> TypeCheckMonad (abt '[] x')
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] x' -> TypeCheckMonad (abt '[] x'))
-> abt '[] x' -> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ Term abt x' -> abt '[] x'
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Transform '[ '( '[], x')] x' -> SCon '[ '( '[], x')] x'
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[ '( '[], x')] x'
forall (a :: Hakaru). Transform '[LC a] a
Reparam SCon '[ '( '[], x')] x' -> SArgs abt '[ '( '[], x')] -> Term abt x'
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] x'
e1' abt '[] x' -> SArgs abt '[] -> SArgs abt '[ '( '[], x')]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
checkTransform Maybe SourceSpan
sourceSpan Sing x'
typ0
Transform as x
Summarize
((List2 ToUntyped vars varsu
Nil2, U_ABT varsu 'U
e1) U.:* SArgs (MetaABT SourceSpan Term) args
U.End) = do
abt '[] x'
e1' <- Sing x' -> AST -> TypeCheckMonad (abt '[] x')
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing x'
typ0 U_ABT varsu 'U
AST
e1
abt '[] x' -> TypeCheckMonad (abt '[] x')
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] x' -> TypeCheckMonad (abt '[] x'))
-> abt '[] x' -> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ Term abt x' -> abt '[] x'
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Transform '[ '( '[], x')] x' -> SCon '[ '( '[], x')] x'
forall (as :: [([Hakaru], Hakaru)]) (x :: Hakaru).
Transform as x -> SCon as x
Transform_ Transform '[ '( '[], x')] x'
forall (a :: Hakaru). Transform '[LC a] a
Summarize SCon '[ '( '[], x')] x' -> SArgs abt '[ '( '[], x')] -> Term abt x'
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] x'
e1' abt '[] x' -> SArgs abt '[] -> SArgs abt '[ '( '[], x')]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
checkTransform Maybe SourceSpan
_ Sing x'
_ Transform as x
tr SArgs (MetaABT SourceSpan Term) as
_ = [Char] -> TypeCheckMonad (abt '[] x')
forall a. HasCallStack => [Char] -> a
error ([Char] -> TypeCheckMonad (abt '[] x'))
-> [Char] -> TypeCheckMonad (abt '[] x')
forall a b. (a -> b) -> a -> b
$ [Char]
"checkTransform{" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Transform as x -> [Char]
forall a. Show a => a -> [Char]
show Transform as x
tr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"}: TODO"
checkDatumCode
:: forall xss t
. Sing (HData' t)
-> Sing xss
-> U.DCode_
-> TypeCheckMonad (DatumCode xss (abt '[]) (HData' t))
checkDatumCode :: Sing (HData' t)
-> Sing xss
-> DCode (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumCode xss (abt '[]) (HData' t))
checkDatumCode Sing (HData' t)
typA Sing xss
typ DCode (MetaABT SourceSpan Term)
d =
case DCode (MetaABT SourceSpan Term)
d of
U.Inr DCode (MetaABT SourceSpan Term)
d2 ->
case Sing xss
typ of
SPlus _ typ2 -> DatumCode xss (abt '[]) (HData' t)
-> DatumCode (xs : xss) (abt '[]) (HData' t)
forall (xss :: [[HakaruFun]]) (abt :: Hakaru -> *) (a :: Hakaru)
(xs :: [HakaruFun]).
DatumCode xss abt a -> DatumCode (xs : xss) abt a
Inr (DatumCode xss (abt '[]) (HData' t)
-> DatumCode (xs : xss) (abt '[]) (HData' t))
-> TypeCheckMonad (DatumCode xss (abt '[]) (HData' t))
-> TypeCheckMonad (DatumCode (xs : xss) (abt '[]) (HData' t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing (HData' t)
-> Sing xss
-> DCode (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumCode xss (abt '[]) (HData' t))
forall (xss :: [[HakaruFun]]) (t :: HakaruCon).
Sing (HData' t)
-> Sing xss
-> DCode (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumCode xss (abt '[]) (HData' t))
checkDatumCode Sing (HData' t)
typA Sing xss
typ2 DCode (MetaABT SourceSpan Term)
d2
Sing xss
_ -> TypeCheckError
-> TypeCheckMonad (DatumCode xss (abt '[]) (HData' t))
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected datum of `inr' type"
U.Inl DStruct (MetaABT SourceSpan Term)
d1 ->
case Sing xss
typ of
SPlus typ1 _ -> DatumStruct xs (abt '[]) (HData' t)
-> DatumCode (xs : xss) (abt '[]) (HData' t)
forall (xs :: [HakaruFun]) (abt :: Hakaru -> *) (a :: Hakaru)
(xss :: [[HakaruFun]]).
DatumStruct xs abt a -> DatumCode (xs : xss) abt a
Inl (DatumStruct xs (abt '[]) (HData' t)
-> DatumCode (xs : xss) (abt '[]) (HData' t))
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
-> TypeCheckMonad (DatumCode (xs : xss) (abt '[]) (HData' t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing (HData' t)
-> Sing xs
-> DStruct (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
forall (xs :: [HakaruFun]) (t :: HakaruCon).
Sing (HData' t)
-> Sing xs
-> DStruct (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
checkDatumStruct Sing (HData' t)
typA Sing xs
typ1 DStruct (MetaABT SourceSpan Term)
d1
Sing xss
_ -> TypeCheckError
-> TypeCheckMonad (DatumCode xss (abt '[]) (HData' t))
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected datum of `inl' type"
checkDatumStruct
:: forall xs t
. Sing (HData' t)
-> Sing xs
-> U.DStruct_
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
checkDatumStruct :: Sing (HData' t)
-> Sing xs
-> DStruct (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
checkDatumStruct Sing (HData' t)
typA Sing xs
typ DStruct (MetaABT SourceSpan Term)
d =
case DStruct (MetaABT SourceSpan Term)
d of
U.Et DFun (MetaABT SourceSpan Term)
d1 DStruct (MetaABT SourceSpan Term)
d2 ->
case Sing xs
typ of
SEt typ1 typ2 -> DatumFun x (abt '[]) (HData' t)
-> DatumStruct xs (abt '[]) (HData' t)
-> DatumStruct (x : xs) (abt '[]) (HData' t)
forall (x :: HakaruFun) (abt :: Hakaru -> *) (a :: Hakaru)
(xs :: [HakaruFun]).
DatumFun x abt a
-> DatumStruct xs abt a -> DatumStruct (x : xs) abt a
Et
(DatumFun x (abt '[]) (HData' t)
-> DatumStruct xs (abt '[]) (HData' t)
-> DatumStruct (x : xs) (abt '[]) (HData' t))
-> TypeCheckMonad (DatumFun x (abt '[]) (HData' t))
-> TypeCheckMonad
(DatumStruct xs (abt '[]) (HData' t)
-> DatumStruct (x : xs) (abt '[]) (HData' t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing (HData' t)
-> Sing x
-> DFun (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumFun x (abt '[]) (HData' t))
forall (x :: HakaruFun) (t :: HakaruCon).
Sing (HData' t)
-> Sing x
-> DFun (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumFun x (abt '[]) (HData' t))
checkDatumFun Sing (HData' t)
typA Sing x
typ1 DFun (MetaABT SourceSpan Term)
d1
TypeCheckMonad
(DatumStruct xs (abt '[]) (HData' t)
-> DatumStruct (x : xs) (abt '[]) (HData' t))
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
-> TypeCheckMonad (DatumStruct (x : xs) (abt '[]) (HData' t))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Sing (HData' t)
-> Sing xs
-> DStruct (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
forall (xs :: [HakaruFun]) (t :: HakaruCon).
Sing (HData' t)
-> Sing xs
-> DStruct (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
checkDatumStruct Sing (HData' t)
typA Sing xs
typ2 DStruct (MetaABT SourceSpan Term)
d2
Sing xs
_ -> TypeCheckError
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected datum of `et' type"
DStruct (MetaABT SourceSpan Term)
U.Done ->
case Sing xs
typ of
Sing xs
SDone -> DatumStruct '[] (abt '[]) (HData' t)
-> TypeCheckMonad (DatumStruct '[] (abt '[]) (HData' t))
forall (m :: * -> *) a. Monad m => a -> m a
return DatumStruct '[] (abt '[]) (HData' t)
forall (abt :: Hakaru -> *) (a :: Hakaru). DatumStruct '[] abt a
Done
Sing xs
_ -> TypeCheckError
-> TypeCheckMonad (DatumStruct xs (abt '[]) (HData' t))
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected datum of `done' type"
checkDatumFun
:: forall x t
. Sing (HData' t)
-> Sing x
-> U.DFun_
-> TypeCheckMonad (DatumFun x (abt '[]) (HData' t))
checkDatumFun :: Sing (HData' t)
-> Sing x
-> DFun (MetaABT SourceSpan Term)
-> TypeCheckMonad (DatumFun x (abt '[]) (HData' t))
checkDatumFun Sing (HData' t)
typA Sing x
typ DFun (MetaABT SourceSpan Term)
d =
case DFun (MetaABT SourceSpan Term)
d of
U.Ident AST
e1 ->
case Sing x
typ of
Sing x
SIdent -> abt '[] (HData' t) -> DatumFun 'I (abt '[]) (HData' t)
forall (ast :: Hakaru -> *) (a :: Hakaru).
ast a -> DatumFun 'I ast a
Ident (abt '[] (HData' t) -> DatumFun 'I (abt '[]) (HData' t))
-> TypeCheckMonad (abt '[] (HData' t))
-> TypeCheckMonad (DatumFun 'I (abt '[]) (HData' t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing (HData' t) -> AST -> TypeCheckMonad (abt '[] (HData' t))
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing (HData' t)
typA AST
e1
Sing x
_ -> TypeCheckError -> TypeCheckMonad (DatumFun x (abt '[]) (HData' t))
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected datum of `I' type"
U.Konst AST
e1 ->
case Sing x
typ of
SKonst typ1 -> abt '[] a -> DatumFun ('K a) (abt '[]) (HData' t)
forall (ast :: Hakaru -> *) (b :: Hakaru) (a :: Hakaru).
ast b -> DatumFun ('K b) ast a
Konst (abt '[] a -> DatumFun ('K a) (abt '[]) (HData' t))
-> TypeCheckMonad (abt '[] a)
-> TypeCheckMonad (DatumFun ('K a) (abt '[]) (HData' t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sing a -> AST -> TypeCheckMonad (abt '[] a)
forall (b :: Hakaru). Sing b -> AST -> TypeCheckMonad (abt '[] b)
checkType_ Sing a
typ1 AST
e1
Sing x
_ -> TypeCheckError -> TypeCheckMonad (DatumFun x (abt '[]) (HData' t))
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected datum of `K' type"
checkBranch
:: (ABT Term abt)
=> Sing a
-> Sing b
-> U.Branch
-> TypeCheckMonad (Branch a abt b)
checkBranch :: Sing a
-> Sing b
-> Branch_ (MetaABT SourceSpan Term)
-> TypeCheckMonad (Branch a abt b)
checkBranch Sing a
patTyp Sing b
bodyTyp (U.Branch_ Pattern
pat AST
body) = do
SP Pattern vars a
pat' List1 Variable vars
vars <- Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
forall (a :: Hakaru).
Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
checkPattern Sing a
patTyp Pattern
pat
Pattern vars a -> abt vars b -> Branch a abt b
forall (a :: Hakaru) (abt :: [Hakaru] -> Hakaru -> *) (b :: Hakaru)
(xs :: [Hakaru]).
Pattern xs a -> abt xs b -> Branch a abt b
Branch Pattern vars a
pat' (abt vars b -> Branch a abt b)
-> TypeCheckMonad (abt vars b) -> TypeCheckMonad (Branch a abt b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> List1 Variable vars -> Sing b -> AST -> TypeCheckMonad (abt vars b)
forall (abt :: [Hakaru] -> Hakaru -> *) (xs :: [Hakaru])
(a :: Hakaru).
ABT Term abt =>
List1 Variable xs -> Sing a -> AST -> TypeCheckMonad (abt xs a)
checkBinders List1 Variable vars
vars Sing b
bodyTyp AST
body
checkPattern
:: Sing a
-> U.Pattern
-> TypeCheckMonad (SomePattern a)
checkPattern :: Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
checkPattern = \Sing a
typA Pattern
pat ->
case Pattern
pat of
U.PVar Name
x -> SomePattern a -> TypeCheckMonad (SomePattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePattern a -> TypeCheckMonad (SomePattern a))
-> SomePattern a -> TypeCheckMonad (SomePattern a)
forall a b. (a -> b) -> a -> b
$ Pattern '[a] a -> List1 Variable '[a] -> SomePattern a
forall (a :: Hakaru) (vars :: [Hakaru]).
Pattern vars a -> List1 Variable vars -> SomePattern a
SP Pattern '[a] a
forall (a :: Hakaru). Pattern '[a] a
PVar (Variable a -> List1 Variable '[] -> List1 Variable '[a]
forall a (a :: a -> *) (x :: a) (xs :: [a]).
a x -> List1 a xs -> List1 a (x : xs)
Cons1 (Variable 'U -> Sing a -> Variable a
forall (a :: Hakaru). Variable 'U -> Sing a -> Variable a
makeVar (Name -> Variable 'U
U.nameToVar Name
x) Sing a
typA) List1 Variable '[]
forall k (a :: k -> *). List1 a '[]
Nil1)
Pattern
U.PWild -> SomePattern a -> TypeCheckMonad (SomePattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePattern a -> TypeCheckMonad (SomePattern a))
-> SomePattern a -> TypeCheckMonad (SomePattern a)
forall a b. (a -> b) -> a -> b
$ Pattern '[] a -> List1 Variable '[] -> SomePattern a
forall (a :: Hakaru) (vars :: [Hakaru]).
Pattern vars a -> List1 Variable vars -> SomePattern a
SP Pattern '[] a
forall (a :: Hakaru). Pattern '[] a
PWild List1 Variable '[]
forall k (a :: k -> *). List1 a '[]
Nil1
U.PDatum TypeCheckError
hint PCode
pat1 ->
case Sing a
typA of
SData _ typ1 -> do
SPC PDatumCode (Code t) vars (HData' t)
pat1' List1 Variable vars
xs <- Sing (HData' t)
-> Sing (Code t)
-> PCode
-> TypeCheckMonad (SomePatternCode (Code t) t)
forall (t :: HakaruCon) (xss :: [[HakaruFun]]).
Sing (HData' t)
-> Sing xss -> PCode -> TypeCheckMonad (SomePatternCode xss t)
checkPatternCode Sing a
Sing (HData' t)
typA Sing (Code t)
typ1 PCode
pat1
SomePattern a -> TypeCheckMonad (SomePattern a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePattern a -> TypeCheckMonad (SomePattern a))
-> SomePattern a -> TypeCheckMonad (SomePattern a)
forall a b. (a -> b) -> a -> b
$ Pattern vars a -> List1 Variable vars -> SomePattern a
forall (a :: Hakaru) (vars :: [Hakaru]).
Pattern vars a -> List1 Variable vars -> SomePattern a
SP (TypeCheckError
-> PDatumCode (Code t) vars (HData' t) -> Pattern vars (HData' t)
forall (t :: HakaruCon) (vars :: [Hakaru]).
TypeCheckError
-> PDatumCode (Code t) vars (HData' t) -> Pattern vars (HData' t)
PDatum TypeCheckError
hint PDatumCode (Code t) vars (HData' t)
pat1') List1 Variable vars
xs
Sing a
_ -> Maybe SourceSpan
-> Either TypeCheckError (Sing a)
-> Either TypeCheckError (Sing Any)
-> TypeCheckMonad (SomePattern a)
forall (a :: Hakaru) (b :: Hakaru) r.
Maybe SourceSpan
-> Either TypeCheckError (Sing a)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad r
typeMismatch Maybe SourceSpan
forall a. Maybe a
Nothing (Sing a -> Either TypeCheckError (Sing a)
forall a b. b -> Either a b
Right Sing a
typA) (TypeCheckError -> Either TypeCheckError (Sing Any)
forall a b. a -> Either a b
Left TypeCheckError
"HData")
where
checkPatternCode
:: Sing (HData' t)
-> Sing xss
-> U.PCode
-> TypeCheckMonad (SomePatternCode xss t)
checkPatternCode :: Sing (HData' t)
-> Sing xss -> PCode -> TypeCheckMonad (SomePatternCode xss t)
checkPatternCode Sing (HData' t)
typA Sing xss
typ PCode
pat =
case PCode
pat of
U.PInr PCode
pat2 ->
case Sing xss
typ of
SPlus _ typ2 -> do
SPC PDatumCode xss vars (HData' t)
pat2' List1 Variable vars
xs <- Sing (HData' t)
-> Sing xss -> PCode -> TypeCheckMonad (SomePatternCode xss t)
forall (t :: HakaruCon) (xss :: [[HakaruFun]]).
Sing (HData' t)
-> Sing xss -> PCode -> TypeCheckMonad (SomePatternCode xss t)
checkPatternCode Sing (HData' t)
typA Sing xss
typ2 PCode
pat2
SomePatternCode (xs : xss) t
-> TypeCheckMonad (SomePatternCode (xs : xss) t)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePatternCode (xs : xss) t
-> TypeCheckMonad (SomePatternCode (xs : xss) t))
-> SomePatternCode (xs : xss) t
-> TypeCheckMonad (SomePatternCode (xs : xss) t)
forall a b. (a -> b) -> a -> b
$ PDatumCode (xs : xss) vars (HData' t)
-> List1 Variable vars -> SomePatternCode (xs : xss) t
forall (xss :: [[HakaruFun]]) (t :: HakaruCon) (vars :: [Hakaru]).
PDatumCode xss vars (HData' t)
-> List1 Variable vars -> SomePatternCode xss t
SPC (PDatumCode xss vars (HData' t)
-> PDatumCode (xs : xss) vars (HData' t)
forall (xss :: [[HakaruFun]]) (vars :: [Hakaru]) (a :: Hakaru)
(xs :: [HakaruFun]).
PDatumCode xss vars a -> PDatumCode (xs : xss) vars a
PInr PDatumCode xss vars (HData' t)
pat2') List1 Variable vars
xs
Sing xss
_ -> TypeCheckError -> TypeCheckMonad (SomePatternCode xss t)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected pattern of `sum' type"
U.PInl PStruct
pat1 ->
case Sing xss
typ of
SPlus typ1 _ -> do
SPS PDatumStruct xs vars (HData' t)
pat1' List1 Variable vars
xs <- Sing (HData' t)
-> Sing xs -> PStruct -> TypeCheckMonad (SomePatternStruct xs t)
forall (t :: HakaruCon) (xs :: [HakaruFun]).
Sing (HData' t)
-> Sing xs -> PStruct -> TypeCheckMonad (SomePatternStruct xs t)
checkPatternStruct Sing (HData' t)
typA Sing xs
typ1 PStruct
pat1
SomePatternCode (xs : xss) t
-> TypeCheckMonad (SomePatternCode (xs : xss) t)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePatternCode (xs : xss) t
-> TypeCheckMonad (SomePatternCode (xs : xss) t))
-> SomePatternCode (xs : xss) t
-> TypeCheckMonad (SomePatternCode (xs : xss) t)
forall a b. (a -> b) -> a -> b
$ PDatumCode (xs : xss) vars (HData' t)
-> List1 Variable vars -> SomePatternCode (xs : xss) t
forall (xss :: [[HakaruFun]]) (t :: HakaruCon) (vars :: [Hakaru]).
PDatumCode xss vars (HData' t)
-> List1 Variable vars -> SomePatternCode xss t
SPC (PDatumStruct xs vars (HData' t)
-> PDatumCode (xs : xss) vars (HData' t)
forall (xs :: [HakaruFun]) (vars :: [Hakaru]) (a :: Hakaru)
(xss :: [[HakaruFun]]).
PDatumStruct xs vars a -> PDatumCode (xs : xss) vars a
PInl PDatumStruct xs vars (HData' t)
pat1') List1 Variable vars
xs
Sing xss
_ -> TypeCheckError -> TypeCheckMonad (SomePatternCode xss t)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected pattern of `zero' type"
checkPatternStruct
:: Sing (HData' t)
-> Sing xs
-> U.PStruct
-> TypeCheckMonad (SomePatternStruct xs t)
checkPatternStruct :: Sing (HData' t)
-> Sing xs -> PStruct -> TypeCheckMonad (SomePatternStruct xs t)
checkPatternStruct Sing (HData' t)
typA Sing xs
typ PStruct
pat =
case PStruct
pat of
U.PEt PFun
pat1 PStruct
pat2 ->
case Sing xs
typ of
SEt typ1 typ2 -> do
SPF PDatumFun x vars (HData' t)
pat1' List1 Variable vars
xs <- Sing (HData' t)
-> Sing x -> PFun -> TypeCheckMonad (SomePatternFun x t)
forall (t :: HakaruCon) (x :: HakaruFun).
Sing (HData' t)
-> Sing x -> PFun -> TypeCheckMonad (SomePatternFun x t)
checkPatternFun Sing (HData' t)
typA Sing x
typ1 PFun
pat1
SPS PDatumStruct xs vars (HData' t)
pat2' List1 Variable vars
ys <- Sing (HData' t)
-> Sing xs -> PStruct -> TypeCheckMonad (SomePatternStruct xs t)
forall (t :: HakaruCon) (xs :: [HakaruFun]).
Sing (HData' t)
-> Sing xs -> PStruct -> TypeCheckMonad (SomePatternStruct xs t)
checkPatternStruct Sing (HData' t)
typA Sing xs
typ2 PStruct
pat2
SomePatternStruct (x : xs) t
-> TypeCheckMonad (SomePatternStruct (x : xs) t)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePatternStruct (x : xs) t
-> TypeCheckMonad (SomePatternStruct (x : xs) t))
-> SomePatternStruct (x : xs) t
-> TypeCheckMonad (SomePatternStruct (x : xs) t)
forall a b. (a -> b) -> a -> b
$ PDatumStruct (x : xs) (vars ++ vars) (HData' t)
-> List1 Variable (vars ++ vars) -> SomePatternStruct (x : xs) t
forall (xs :: [HakaruFun]) (t :: HakaruCon) (vars :: [Hakaru]).
PDatumStruct xs vars (HData' t)
-> List1 Variable vars -> SomePatternStruct xs t
SPS (PDatumFun x vars (HData' t)
-> PDatumStruct xs vars (HData' t)
-> PDatumStruct (x : xs) (vars ++ vars) (HData' t)
forall (x :: HakaruFun) (vars1 :: [Hakaru]) (a :: Hakaru)
(xs :: [HakaruFun]) (vars2 :: [Hakaru]).
PDatumFun x vars1 a
-> PDatumStruct xs vars2 a
-> PDatumStruct (x : xs) (vars1 ++ vars2) a
PEt PDatumFun x vars (HData' t)
pat1' PDatumStruct xs vars (HData' t)
pat2') (List1 Variable vars
-> List1 Variable vars -> List1 Variable (vars ++ vars)
forall k (a :: k -> *) (xs :: [k]) (ys :: [k]).
List1 a xs -> List1 a ys -> List1 a (xs ++ ys)
append1 List1 Variable vars
xs List1 Variable vars
ys)
Sing xs
_ -> TypeCheckError -> TypeCheckMonad (SomePatternStruct xs t)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected pattern of `et' type"
PStruct
U.PDone ->
case Sing xs
typ of
Sing xs
SDone -> SomePatternStruct '[] t -> TypeCheckMonad (SomePatternStruct '[] t)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePatternStruct '[] t
-> TypeCheckMonad (SomePatternStruct '[] t))
-> SomePatternStruct '[] t
-> TypeCheckMonad (SomePatternStruct '[] t)
forall a b. (a -> b) -> a -> b
$ PDatumStruct '[] '[] (HData' t)
-> List1 Variable '[] -> SomePatternStruct '[] t
forall (xs :: [HakaruFun]) (t :: HakaruCon) (vars :: [Hakaru]).
PDatumStruct xs vars (HData' t)
-> List1 Variable vars -> SomePatternStruct xs t
SPS PDatumStruct '[] '[] (HData' t)
forall (a :: Hakaru). PDatumStruct '[] '[] a
PDone List1 Variable '[]
forall k (a :: k -> *). List1 a '[]
Nil1
Sing xs
_ -> TypeCheckError -> TypeCheckMonad (SomePatternStruct xs t)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected pattern of `done' type"
checkPatternFun
:: Sing (HData' t)
-> Sing x
-> U.PFun
-> TypeCheckMonad (SomePatternFun x t)
checkPatternFun :: Sing (HData' t)
-> Sing x -> PFun -> TypeCheckMonad (SomePatternFun x t)
checkPatternFun Sing (HData' t)
typA Sing x
typ PFun
pat =
case PFun
pat of
U.PIdent Pattern
pat1 ->
case Sing x
typ of
Sing x
SIdent -> do
SP Pattern vars (HData' t)
pat1' List1 Variable vars
xs <- Sing (HData' t)
-> Pattern -> TypeCheckMonad (SomePattern (HData' t))
forall (a :: Hakaru).
Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
checkPattern Sing (HData' t)
typA Pattern
pat1
SomePatternFun 'I t -> TypeCheckMonad (SomePatternFun 'I t)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePatternFun 'I t -> TypeCheckMonad (SomePatternFun 'I t))
-> SomePatternFun 'I t -> TypeCheckMonad (SomePatternFun 'I t)
forall a b. (a -> b) -> a -> b
$ PDatumFun 'I vars (HData' t)
-> List1 Variable vars -> SomePatternFun 'I t
forall (x :: HakaruFun) (t :: HakaruCon) (vars :: [Hakaru]).
PDatumFun x vars (HData' t)
-> List1 Variable vars -> SomePatternFun x t
SPF (Pattern vars (HData' t) -> PDatumFun 'I vars (HData' t)
forall (vars :: [Hakaru]) (a :: Hakaru).
Pattern vars a -> PDatumFun 'I vars a
PIdent Pattern vars (HData' t)
pat1') List1 Variable vars
xs
Sing x
_ -> TypeCheckError -> TypeCheckMonad (SomePatternFun x t)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected pattern of `I' type"
U.PKonst Pattern
pat1 ->
case Sing x
typ of
SKonst typ1 -> do
SP Pattern vars a
pat1' List1 Variable vars
xs <- Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
forall (a :: Hakaru).
Sing a -> Pattern -> TypeCheckMonad (SomePattern a)
checkPattern Sing a
typ1 Pattern
pat1
SomePatternFun ('K a) t -> TypeCheckMonad (SomePatternFun ('K a) t)
forall (m :: * -> *) a. Monad m => a -> m a
return (SomePatternFun ('K a) t
-> TypeCheckMonad (SomePatternFun ('K a) t))
-> SomePatternFun ('K a) t
-> TypeCheckMonad (SomePatternFun ('K a) t)
forall a b. (a -> b) -> a -> b
$ PDatumFun ('K a) vars (HData' t)
-> List1 Variable vars -> SomePatternFun ('K a) t
forall (x :: HakaruFun) (t :: HakaruCon) (vars :: [Hakaru]).
PDatumFun x vars (HData' t)
-> List1 Variable vars -> SomePatternFun x t
SPF (Pattern vars a -> PDatumFun ('K a) vars (HData' t)
forall (vars :: [Hakaru]) (b :: Hakaru) (a :: Hakaru).
Pattern vars b -> PDatumFun ('K b) vars a
PKonst Pattern vars a
pat1') List1 Variable vars
xs
Sing x
_ -> TypeCheckError -> TypeCheckMonad (SomePatternFun x t)
forall r. TypeCheckError -> TypeCheckMonad r
failwith_ TypeCheckError
"expected pattern of `K' type"
checkOrCoerce
:: (ABT Term abt)
=> Maybe (U.SourceSpan)
-> abt '[] a
-> Sing a
-> Sing b
-> TypeCheckMonad (abt '[] b)
checkOrCoerce :: Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrCoerce Maybe SourceSpan
s abt '[] a
e Sing a
typA Sing b
typB =
case Sing a -> Sing b -> Maybe (Coercion a b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Maybe (Coercion a b)
findCoercion Sing a
typA Sing b
typB of
Just Coercion a b
c -> abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> (LC_ abt a -> abt '[] b)
-> LC_ abt a
-> TypeCheckMonad (abt '[] b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LC_ abt b -> abt '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt b -> abt '[] b)
-> (LC_ abt a -> LC_ abt b) -> LC_ abt a -> abt '[] b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion a b -> LC_ abt a -> LC_ abt b
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion a b
c (LC_ abt a -> TypeCheckMonad (abt '[] b))
-> LC_ abt a -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ abt '[] a -> LC_ abt a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ abt '[] a
e
Maybe (Coercion a b)
Nothing -> Maybe SourceSpan
-> Either TypeCheckError (Sing b)
-> Either TypeCheckError (Sing a)
-> TypeCheckMonad (abt '[] b)
forall (a :: Hakaru) (b :: Hakaru) r.
Maybe SourceSpan
-> Either TypeCheckError (Sing a)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad r
typeMismatch Maybe SourceSpan
s (Sing b -> Either TypeCheckError (Sing b)
forall a b. b -> Either a b
Right Sing b
typB) (Sing a -> Either TypeCheckError (Sing a)
forall a b. b -> Either a b
Right Sing a
typA)
checkOrUnsafeCoerce
:: (ABT Term abt)
=> Maybe (U.SourceSpan)
-> abt '[] a
-> Sing a
-> Sing b
-> TypeCheckMonad (abt '[] b)
checkOrUnsafeCoerce :: Maybe SourceSpan
-> abt '[] a -> Sing a -> Sing b -> TypeCheckMonad (abt '[] b)
checkOrUnsafeCoerce Maybe SourceSpan
s abt '[] a
e Sing a
typA Sing b
typB =
case Sing a -> Sing b -> Maybe (CoercionMode a b)
forall (a :: Hakaru) (b :: Hakaru).
Sing a -> Sing b -> Maybe (CoercionMode a b)
findEitherCoercion Sing a
typA Sing b
typB of
Just (Unsafe Coercion b a
c) ->
abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> (LC_ abt a -> abt '[] b)
-> LC_ abt a
-> TypeCheckMonad (abt '[] b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LC_ abt b -> abt '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt b -> abt '[] b)
-> (LC_ abt a -> LC_ abt b) -> LC_ abt a -> abt '[] b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion b a -> LC_ abt a -> LC_ abt b
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f b -> f a
coerceFrom Coercion b a
c (LC_ abt a -> TypeCheckMonad (abt '[] b))
-> LC_ abt a -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ abt '[] a -> LC_ abt a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ abt '[] a
e
Just (Safe Coercion a b
c) ->
abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> (LC_ abt a -> abt '[] b)
-> LC_ abt a
-> TypeCheckMonad (abt '[] b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LC_ abt b -> abt '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt b -> abt '[] b)
-> (LC_ abt a -> LC_ abt b) -> LC_ abt a -> abt '[] b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion a b -> LC_ abt a -> LC_ abt b
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion a b
c (LC_ abt a -> TypeCheckMonad (abt '[] b))
-> LC_ abt a -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ abt '[] a -> LC_ abt a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ abt '[] a
e
Just (Mixed (Sing c
_, Coercion c a
c1, Coercion c b
c2)) ->
abt '[] b -> TypeCheckMonad (abt '[] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] b -> TypeCheckMonad (abt '[] b))
-> (LC_ abt a -> abt '[] b)
-> LC_ abt a
-> TypeCheckMonad (abt '[] b)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LC_ abt b -> abt '[] b
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
LC_ abt a -> abt '[] a
unLC_ (LC_ abt b -> abt '[] b)
-> (LC_ abt a -> LC_ abt b) -> LC_ abt a -> abt '[] b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion c b -> LC_ abt c -> LC_ abt b
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f a -> f b
coerceTo Coercion c b
c2 (LC_ abt c -> LC_ abt b)
-> (LC_ abt a -> LC_ abt c) -> LC_ abt a -> LC_ abt b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Coercion c a -> LC_ abt a -> LC_ abt c
forall (f :: Hakaru -> *) (a :: Hakaru) (b :: Hakaru).
Coerce f =>
Coercion a b -> f b -> f a
coerceFrom Coercion c a
c1 (LC_ abt a -> TypeCheckMonad (abt '[] b))
-> LC_ abt a -> TypeCheckMonad (abt '[] b)
forall a b. (a -> b) -> a -> b
$ abt '[] a -> LC_ abt a
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru).
abt '[] a -> LC_ abt a
LC_ abt '[] a
e
Maybe (CoercionMode a b)
Nothing ->
case (Sing a
typA, Sing b
typB) of
(SMeasure typ1, SMeasure _) -> do
let x :: Variable 'U
x = TypeCheckError -> Nat -> Sing 'U -> Variable 'U
forall k (a :: k). TypeCheckError -> Nat -> Sing a -> Variable a
Variable ([Char] -> TypeCheckError
pack [Char]
"") Nat
0 Sing 'U
U.SU
abt '[a] b
e2' <- Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
forall (abt :: [Hakaru] -> Hakaru -> *) (a :: Hakaru)
(b :: Hakaru).
ABT Term abt =>
Sing a -> Sing b -> U_ABT '[ 'U] 'U -> TypeCheckMonad (abt '[a] b)
checkBinder Sing a
typ1 Sing b
typB (Variable 'U -> AST -> U_ABT '[ 'U] 'U
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k) (xs :: [k]) (b :: k).
ABT syn abt =>
Variable a -> abt xs b -> abt (a : xs) b
bind Variable 'U
x (AST -> U_ABT '[ 'U] 'U) -> AST -> U_ABT '[ 'U] 'U
forall a b. (a -> b) -> a -> b
$ Term (MetaABT SourceSpan Term) 'U -> AST
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (Term (MetaABT SourceSpan Term) 'U -> AST)
-> Term (MetaABT SourceSpan Term) 'U -> AST
forall a b. (a -> b) -> a -> b
$ AST -> Term (MetaABT SourceSpan Term) 'U
forall (abt :: [Untyped] -> Untyped -> *).
abt '[] 'U -> Term abt 'U
U.Dirac_ (Variable 'U -> AST
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
Variable a -> abt '[] a
var Variable 'U
x))
abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall (m :: * -> *) a. Monad m => a -> m a
return (abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a)))
-> abt '[] ('HMeasure a) -> TypeCheckMonad (abt '[] ('HMeasure a))
forall a b. (a -> b) -> a -> b
$ Term abt ('HMeasure a) -> abt '[] ('HMeasure a)
forall k (syn :: ([k] -> k -> *) -> k -> *) (abt :: [k] -> k -> *)
(a :: k).
ABT syn abt =>
syn abt a -> abt '[] a
syn (SCon '[LC ('HMeasure a), '( '[a], 'HMeasure a)] ('HMeasure a)
forall (a :: Hakaru) (a :: Hakaru).
SCon '[LC ('HMeasure a), '( '[a], 'HMeasure a)] ('HMeasure a)
MBind SCon '[LC ('HMeasure a), '( '[a], 'HMeasure a)] ('HMeasure a)
-> SArgs abt '[LC ('HMeasure a), '( '[a], 'HMeasure a)]
-> Term abt ('HMeasure a)
forall (args :: [([Hakaru], Hakaru)]) (a :: Hakaru)
(abt :: [Hakaru] -> Hakaru -> *).
SCon args a -> SArgs abt args -> Term abt a
:$ abt '[] a
e abt '[] a
-> SArgs abt '[ '( '[a], b)]
-> SArgs abt '[ '( '[], a), '( '[a], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* abt '[a] b
e2' abt '[a] b -> SArgs abt '[] -> SArgs abt '[ '( '[a], b)]
forall (abt :: [Hakaru] -> Hakaru -> *) (vars :: [Hakaru])
(a :: Hakaru) (args :: [([Hakaru], Hakaru)]).
abt vars a -> SArgs abt args -> SArgs abt ('(vars, a) : args)
:* SArgs abt '[]
forall (abt :: [Hakaru] -> Hakaru -> *). SArgs abt '[]
End)
(Sing a
_ , Sing b
_) -> Maybe SourceSpan
-> Either TypeCheckError (Sing b)
-> Either TypeCheckError (Sing a)
-> TypeCheckMonad (abt '[] b)
forall (a :: Hakaru) (b :: Hakaru) r.
Maybe SourceSpan
-> Either TypeCheckError (Sing a)
-> Either TypeCheckError (Sing b)
-> TypeCheckMonad r
typeMismatch Maybe SourceSpan
s (Sing b -> Either TypeCheckError (Sing b)
forall a b. b -> Either a b
Right Sing b
typB) (Sing a -> Either TypeCheckError (Sing a)
forall a b. b -> Either a b
Right Sing a
typA)