{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -Wno-missing-methods #-}
module Nix.Lint where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.Reader ( MonadReader )
import Control.Monad.Ref
import Control.Monad.ST
import Control.Monad.Trans.Reader
import Data.HashMap.Lazy ( HashMap )
import qualified Data.HashMap.Lazy as M
import Data.List
import qualified Data.List.NonEmpty as NE
import Data.Text ( Text )
import qualified Data.Text as Text
import Nix.Atoms
import Nix.Context
import Nix.Convert
import Nix.Eval ( MonadEval(..) )
import qualified Nix.Eval as Eval
import Nix.Expr
import Nix.Frames
import Nix.Fresh
import Nix.String
import Nix.Options
import Nix.Scope
import Nix.Thunk
import Nix.Thunk.Basic
import Nix.Utils
import Nix.Var
import Nix.Value.Monad
data TAtom
= TInt
| TFloat
| TBool
| TNull
deriving (Int -> TAtom -> ShowS
[TAtom] -> ShowS
TAtom -> String
(Int -> TAtom -> ShowS)
-> (TAtom -> String) -> ([TAtom] -> ShowS) -> Show TAtom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TAtom] -> ShowS
$cshowList :: [TAtom] -> ShowS
show :: TAtom -> String
$cshow :: TAtom -> String
showsPrec :: Int -> TAtom -> ShowS
$cshowsPrec :: Int -> TAtom -> ShowS
Show, TAtom -> TAtom -> Bool
(TAtom -> TAtom -> Bool) -> (TAtom -> TAtom -> Bool) -> Eq TAtom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TAtom -> TAtom -> Bool
$c/= :: TAtom -> TAtom -> Bool
== :: TAtom -> TAtom -> Bool
$c== :: TAtom -> TAtom -> Bool
Eq, Eq TAtom
Eq TAtom
-> (TAtom -> TAtom -> Ordering)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> TAtom)
-> (TAtom -> TAtom -> TAtom)
-> Ord TAtom
TAtom -> TAtom -> Bool
TAtom -> TAtom -> Ordering
TAtom -> TAtom -> TAtom
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TAtom -> TAtom -> TAtom
$cmin :: TAtom -> TAtom -> TAtom
max :: TAtom -> TAtom -> TAtom
$cmax :: TAtom -> TAtom -> TAtom
>= :: TAtom -> TAtom -> Bool
$c>= :: TAtom -> TAtom -> Bool
> :: TAtom -> TAtom -> Bool
$c> :: TAtom -> TAtom -> Bool
<= :: TAtom -> TAtom -> Bool
$c<= :: TAtom -> TAtom -> Bool
< :: TAtom -> TAtom -> Bool
$c< :: TAtom -> TAtom -> Bool
compare :: TAtom -> TAtom -> Ordering
$ccompare :: TAtom -> TAtom -> Ordering
$cp1Ord :: Eq TAtom
Ord)
data NTypeF (m :: * -> *) r
= TConstant [TAtom]
| TStr
| TList r
| TSet (Maybe (HashMap Text r))
| TClosure (Params ())
| TPath
| TBuiltin String (Symbolic m -> m r)
deriving a -> NTypeF m b -> NTypeF m a
(a -> b) -> NTypeF m a -> NTypeF m b
(forall a b. (a -> b) -> NTypeF m a -> NTypeF m b)
-> (forall a b. a -> NTypeF m b -> NTypeF m a)
-> Functor (NTypeF m)
forall a b. a -> NTypeF m b -> NTypeF m a
forall a b. (a -> b) -> NTypeF m a -> NTypeF m b
forall (m :: * -> *) a b.
Functor m =>
a -> NTypeF m b -> NTypeF m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NTypeF m a -> NTypeF m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> NTypeF m b -> NTypeF m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> NTypeF m b -> NTypeF m a
fmap :: (a -> b) -> NTypeF m a -> NTypeF m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NTypeF m a -> NTypeF m b
Functor
compareTypes :: NTypeF m r -> NTypeF m r -> Ordering
compareTypes :: NTypeF m r -> NTypeF m r -> Ordering
compareTypes (TConstant [TAtom]
_) (TConstant [TAtom]
_) = Ordering
EQ
compareTypes (TConstant [TAtom]
_) NTypeF m r
_ = Ordering
LT
compareTypes NTypeF m r
_ (TConstant [TAtom]
_) = Ordering
GT
compareTypes NTypeF m r
TStr NTypeF m r
TStr = Ordering
EQ
compareTypes NTypeF m r
TStr NTypeF m r
_ = Ordering
LT
compareTypes NTypeF m r
_ NTypeF m r
TStr = Ordering
GT
compareTypes (TList r
_) (TList r
_) = Ordering
EQ
compareTypes (TList r
_) NTypeF m r
_ = Ordering
LT
compareTypes NTypeF m r
_ (TList r
_) = Ordering
GT
compareTypes (TSet Maybe (HashMap Text r)
_) (TSet Maybe (HashMap Text r)
_) = Ordering
EQ
compareTypes (TSet Maybe (HashMap Text r)
_) NTypeF m r
_ = Ordering
LT
compareTypes NTypeF m r
_ (TSet Maybe (HashMap Text r)
_) = Ordering
GT
compareTypes TClosure{} TClosure{} = Ordering
EQ
compareTypes TClosure{} NTypeF m r
_ = Ordering
LT
compareTypes NTypeF m r
_ TClosure{} = Ordering
GT
compareTypes NTypeF m r
TPath NTypeF m r
TPath = Ordering
EQ
compareTypes NTypeF m r
TPath NTypeF m r
_ = Ordering
LT
compareTypes NTypeF m r
_ NTypeF m r
TPath = Ordering
GT
compareTypes (TBuiltin String
_ Symbolic m -> m r
_) (TBuiltin String
_ Symbolic m -> m r
_) = Ordering
EQ
data NSymbolicF r
= NAny
| NMany [r]
deriving (Int -> NSymbolicF r -> ShowS
[NSymbolicF r] -> ShowS
NSymbolicF r -> String
(Int -> NSymbolicF r -> ShowS)
-> (NSymbolicF r -> String)
-> ([NSymbolicF r] -> ShowS)
-> Show (NSymbolicF r)
forall r. Show r => Int -> NSymbolicF r -> ShowS
forall r. Show r => [NSymbolicF r] -> ShowS
forall r. Show r => NSymbolicF r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NSymbolicF r] -> ShowS
$cshowList :: forall r. Show r => [NSymbolicF r] -> ShowS
show :: NSymbolicF r -> String
$cshow :: forall r. Show r => NSymbolicF r -> String
showsPrec :: Int -> NSymbolicF r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> NSymbolicF r -> ShowS
Show, NSymbolicF r -> NSymbolicF r -> Bool
(NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool) -> Eq (NSymbolicF r)
forall r. Eq r => NSymbolicF r -> NSymbolicF r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NSymbolicF r -> NSymbolicF r -> Bool
$c/= :: forall r. Eq r => NSymbolicF r -> NSymbolicF r -> Bool
== :: NSymbolicF r -> NSymbolicF r -> Bool
$c== :: forall r. Eq r => NSymbolicF r -> NSymbolicF r -> Bool
Eq, Eq (NSymbolicF r)
Eq (NSymbolicF r)
-> (NSymbolicF r -> NSymbolicF r -> Ordering)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> NSymbolicF r)
-> (NSymbolicF r -> NSymbolicF r -> NSymbolicF r)
-> Ord (NSymbolicF r)
NSymbolicF r -> NSymbolicF r -> Bool
NSymbolicF r -> NSymbolicF r -> Ordering
NSymbolicF r -> NSymbolicF r -> NSymbolicF r
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall r. Ord r => Eq (NSymbolicF r)
forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Ordering
forall r. Ord r => NSymbolicF r -> NSymbolicF r -> NSymbolicF r
min :: NSymbolicF r -> NSymbolicF r -> NSymbolicF r
$cmin :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> NSymbolicF r
max :: NSymbolicF r -> NSymbolicF r -> NSymbolicF r
$cmax :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> NSymbolicF r
>= :: NSymbolicF r -> NSymbolicF r -> Bool
$c>= :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
> :: NSymbolicF r -> NSymbolicF r -> Bool
$c> :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
<= :: NSymbolicF r -> NSymbolicF r -> Bool
$c<= :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
< :: NSymbolicF r -> NSymbolicF r -> Bool
$c< :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
compare :: NSymbolicF r -> NSymbolicF r -> Ordering
$ccompare :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Ordering
$cp1Ord :: forall r. Ord r => Eq (NSymbolicF r)
Ord, a -> NSymbolicF b -> NSymbolicF a
(a -> b) -> NSymbolicF a -> NSymbolicF b
(forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b)
-> (forall a b. a -> NSymbolicF b -> NSymbolicF a)
-> Functor NSymbolicF
forall a b. a -> NSymbolicF b -> NSymbolicF a
forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> NSymbolicF b -> NSymbolicF a
$c<$ :: forall a b. a -> NSymbolicF b -> NSymbolicF a
fmap :: (a -> b) -> NSymbolicF a -> NSymbolicF b
$cfmap :: forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b
Functor, NSymbolicF a -> Bool
(a -> m) -> NSymbolicF a -> m
(a -> b -> b) -> b -> NSymbolicF a -> b
(forall m. Monoid m => NSymbolicF m -> m)
-> (forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m)
-> (forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m)
-> (forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b)
-> (forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b)
-> (forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b)
-> (forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b)
-> (forall a. (a -> a -> a) -> NSymbolicF a -> a)
-> (forall a. (a -> a -> a) -> NSymbolicF a -> a)
-> (forall a. NSymbolicF a -> [a])
-> (forall a. NSymbolicF a -> Bool)
-> (forall a. NSymbolicF a -> Int)
-> (forall a. Eq a => a -> NSymbolicF a -> Bool)
-> (forall a. Ord a => NSymbolicF a -> a)
-> (forall a. Ord a => NSymbolicF a -> a)
-> (forall a. Num a => NSymbolicF a -> a)
-> (forall a. Num a => NSymbolicF a -> a)
-> Foldable NSymbolicF
forall a. Eq a => a -> NSymbolicF a -> Bool
forall a. Num a => NSymbolicF a -> a
forall a. Ord a => NSymbolicF a -> a
forall m. Monoid m => NSymbolicF m -> m
forall a. NSymbolicF a -> Bool
forall a. NSymbolicF a -> Int
forall a. NSymbolicF a -> [a]
forall a. (a -> a -> a) -> NSymbolicF a -> a
forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: NSymbolicF a -> a
$cproduct :: forall a. Num a => NSymbolicF a -> a
sum :: NSymbolicF a -> a
$csum :: forall a. Num a => NSymbolicF a -> a
minimum :: NSymbolicF a -> a
$cminimum :: forall a. Ord a => NSymbolicF a -> a
maximum :: NSymbolicF a -> a
$cmaximum :: forall a. Ord a => NSymbolicF a -> a
elem :: a -> NSymbolicF a -> Bool
$celem :: forall a. Eq a => a -> NSymbolicF a -> Bool
length :: NSymbolicF a -> Int
$clength :: forall a. NSymbolicF a -> Int
null :: NSymbolicF a -> Bool
$cnull :: forall a. NSymbolicF a -> Bool
toList :: NSymbolicF a -> [a]
$ctoList :: forall a. NSymbolicF a -> [a]
foldl1 :: (a -> a -> a) -> NSymbolicF a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
foldr1 :: (a -> a -> a) -> NSymbolicF a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
foldl' :: (b -> a -> b) -> b -> NSymbolicF a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
foldl :: (b -> a -> b) -> b -> NSymbolicF a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
foldr' :: (a -> b -> b) -> b -> NSymbolicF a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
foldr :: (a -> b -> b) -> b -> NSymbolicF a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
foldMap' :: (a -> m) -> NSymbolicF a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
foldMap :: (a -> m) -> NSymbolicF a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
fold :: NSymbolicF m -> m
$cfold :: forall m. Monoid m => NSymbolicF m -> m
Foldable, Functor NSymbolicF
Foldable NSymbolicF
Functor NSymbolicF
-> Foldable NSymbolicF
-> (forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b))
-> (forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b))
-> (forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a))
-> Traversable NSymbolicF
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a)
forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
sequence :: NSymbolicF (m a) -> m (NSymbolicF a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a)
mapM :: (a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
sequenceA :: NSymbolicF (f a) -> f (NSymbolicF a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a)
traverse :: (a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
$cp2Traversable :: Foldable NSymbolicF
$cp1Traversable :: Functor NSymbolicF
Traversable)
type SThunk (m :: * -> *) = NThunkF m (Symbolic m)
type SValue (m :: * -> *) = Var m (NSymbolicF (NTypeF m (Symbolic m)))
data Symbolic m = SV { Symbolic m -> SValue m
getSV :: SValue m } | ST { Symbolic m -> SThunk m
getST :: SThunk m }
instance Show (Symbolic m) where
show :: Symbolic m -> String
show Symbolic m
_ = String
"<symbolic>"
everyPossible :: MonadVar m => m (Symbolic m)
everyPossible :: m (Symbolic m)
everyPossible = NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic NSymbolicF (NTypeF m (Symbolic m))
forall r. NSymbolicF r
NAny
mkSymbolic :: MonadVar m => [NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic :: [NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)]
xs = NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic ([NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m))
forall r. [r] -> NSymbolicF r
NMany [NTypeF m (Symbolic m)]
xs)
packSymbolic
:: MonadVar m => NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic :: NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic = (Ref m (NSymbolicF (NTypeF m (Symbolic m))) -> Symbolic m)
-> m (Ref m (NSymbolicF (NTypeF m (Symbolic m)))) -> m (Symbolic m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref m (NSymbolicF (NTypeF m (Symbolic m))) -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV (m (Ref m (NSymbolicF (NTypeF m (Symbolic m)))) -> m (Symbolic m))
-> (NSymbolicF (NTypeF m (Symbolic m))
-> m (Ref m (NSymbolicF (NTypeF m (Symbolic m)))))
-> NSymbolicF (NTypeF m (Symbolic m))
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NSymbolicF (NTypeF m (Symbolic m))
-> m (Ref m (NSymbolicF (NTypeF m (Symbolic m))))
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
newVar
unpackSymbolic
:: (MonadVar m, MonadThunkId m, MonadCatch m)
=> Symbolic m
-> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic :: Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic = (Symbolic m
-> (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> m (NSymbolicF (NTypeF m (Symbolic m))))
-> (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> Symbolic m
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Symbolic m
-> (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand ((Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> Symbolic m
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall a b. (a -> b) -> a -> b
$ Ref m (NSymbolicF (NTypeF m (Symbolic m)))
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readVar (Ref m (NSymbolicF (NTypeF m (Symbolic m)))
-> m (NSymbolicF (NTypeF m (Symbolic m))))
-> (Symbolic m -> Ref m (NSymbolicF (NTypeF m (Symbolic m))))
-> Symbolic m
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbolic m -> Ref m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *). Symbolic m -> SValue m
getSV
type MonadLint e m
= ( Scoped (Symbolic m) m
, Framed e m
, MonadVar m
, MonadCatch m
, MonadThunkId m
)
symerr :: forall e m a . MonadLint e m => String -> m a
symerr :: String -> m a
symerr = forall v (m :: * -> *) s a.
(MonadEval v m, Exception s) =>
s -> m a
forall (m :: * -> *) s a.
(MonadEval (Symbolic m) m, Exception s) =>
s -> m a
evalError @(Symbolic m) (ErrorCall -> m a) -> (String -> ErrorCall) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall
renderSymbolic :: MonadLint e m => Symbolic m -> m String
renderSymbolic :: Symbolic m -> m String
renderSymbolic = Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *).
(MonadVar m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> (NSymbolicF (NTypeF m (Symbolic m)) -> m String)
-> Symbolic m
-> m String
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
NSymbolicF (NTypeF m (Symbolic m))
NAny -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"<any>"
NMany [NTypeF m (Symbolic m)]
xs -> ([String] -> String) -> m [String] -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", ") (m [String] -> m String) -> m [String] -> m String
forall a b. (a -> b) -> a -> b
$ [NTypeF m (Symbolic m)]
-> (NTypeF m (Symbolic m) -> m String) -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NTypeF m (Symbolic m)]
xs ((NTypeF m (Symbolic m) -> m String) -> m [String])
-> (NTypeF m (Symbolic m) -> m String) -> m [String]
forall a b. (a -> b) -> a -> b
$ \case
TConstant [TAtom]
ys -> ([String] -> String) -> m [String] -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", ") (m [String] -> m String) -> m [String] -> m String
forall a b. (a -> b) -> a -> b
$ [TAtom] -> (TAtom -> m String) -> m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TAtom]
ys ((TAtom -> m String) -> m [String])
-> (TAtom -> m String) -> m [String]
forall a b. (a -> b) -> a -> b
$ \case
TAtom
TInt -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"int"
TAtom
TFloat -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"float"
TAtom
TBool -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"bool"
TAtom
TNull -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"null"
NTypeF m (Symbolic m)
TStr -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"string"
TList Symbolic m
r -> do
String
x <- Symbolic m -> (Symbolic m -> m String) -> m String
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand Symbolic m
r Symbolic m -> m String
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m String
renderSymbolic
String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
TSet Maybe (HashMap Text (Symbolic m))
Nothing -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"<any set>"
TSet (Just HashMap Text (Symbolic m)
s) -> do
HashMap Text String
x <- (Symbolic m -> m String)
-> HashMap Text (Symbolic m) -> m (HashMap Text String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Symbolic m -> (Symbolic m -> m String) -> m String
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
`demand` Symbolic m -> m String
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m String
renderSymbolic) HashMap Text (Symbolic m)
s
String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ HashMap Text String -> String
forall a. Show a => a -> String
show HashMap Text String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
f :: NTypeF m (Symbolic m)
f@(TClosure Params ()
p) -> do
(HashMap Text (Symbolic m)
args, Symbolic m
sym) <- do
Symbolic m
f' <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)
f]
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
lintApp (Params () -> () -> NExprF ()
forall r. Params r -> r -> NExprF r
NAbs (Params () -> Params ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Params ()
p) ()) Symbolic m
f' m (Symbolic m)
forall (m :: * -> *). MonadVar m => m (Symbolic m)
everyPossible
HashMap Text String
args' <- (Symbolic m -> m String)
-> HashMap Text (Symbolic m) -> m (HashMap Text String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Symbolic m -> m String
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m String
renderSymbolic HashMap Text (Symbolic m)
args
String
sym' <- Symbolic m -> m String
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m String
renderSymbolic Symbolic m
sym
String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ HashMap Text String -> String
forall a. Show a => a -> String
show HashMap Text String
args' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sym' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
NTypeF m (Symbolic m)
TPath -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"path"
TBuiltin String
_n Symbolic m -> m (Symbolic m)
_f -> String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"<builtin function>"
merge
:: forall e m
. MonadLint e m
=> NExprF ()
-> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
merge :: NExprF ()
-> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
merge NExprF ()
context = [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go
where
go
:: [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
go :: [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [] [NTypeF m (Symbolic m)]
_ = [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
go [NTypeF m (Symbolic m)]
_ [] = [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
go (NTypeF m (Symbolic m)
x : [NTypeF m (Symbolic m)]
xs) (NTypeF m (Symbolic m)
y : [NTypeF m (Symbolic m)]
ys) = case (NTypeF m (Symbolic m)
x, NTypeF m (Symbolic m)
y) of
(NTypeF m (Symbolic m)
TStr , NTypeF m (Symbolic m)
TStr ) -> (NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TStr NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
(NTypeF m (Symbolic m)
TPath, NTypeF m (Symbolic m)
TPath) -> (NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TPath NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
(TConstant [TAtom]
ls, TConstant [TAtom]
rs) ->
([TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom]
ls [TAtom] -> [TAtom] -> [TAtom]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [TAtom]
rs) NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
(TList Symbolic m
l, TList Symbolic m
r) -> Symbolic m
-> (Symbolic m -> m [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)]
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand Symbolic m
l ((Symbolic m -> m [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)])
-> (Symbolic m -> m [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ \Symbolic m
l' -> Symbolic m
-> (Symbolic m -> m [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)]
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand Symbolic m
r ((Symbolic m -> m [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)])
-> (Symbolic m -> m [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ \Symbolic m
r' -> do
Symbolic m
m <- m (Symbolic m) -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => m v -> m v
defer (m (Symbolic m) -> m (Symbolic m))
-> m (Symbolic m) -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context Symbolic m
l' Symbolic m
r'
(Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
m NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
(TSet Maybe (HashMap Text (Symbolic m))
x , TSet Maybe (HashMap Text (Symbolic m))
Nothing ) -> (Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet Maybe (HashMap Text (Symbolic m))
x NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
(TSet Maybe (HashMap Text (Symbolic m))
Nothing , TSet Maybe (HashMap Text (Symbolic m))
x ) -> (Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet Maybe (HashMap Text (Symbolic m))
x NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
(TSet (Just HashMap Text (Symbolic m)
l), TSet (Just HashMap Text (Symbolic m)
r)) -> do
HashMap Text (Symbolic m)
m <- HashMap Text (m (Symbolic m)) -> m (HashMap Text (Symbolic m))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (HashMap Text (m (Symbolic m)) -> m (HashMap Text (Symbolic m)))
-> HashMap Text (m (Symbolic m)) -> m (HashMap Text (Symbolic m))
forall a b. (a -> b) -> a -> b
$ (m (Symbolic m) -> m (Symbolic m) -> m (Symbolic m))
-> HashMap Text (m (Symbolic m))
-> HashMap Text (m (Symbolic m))
-> HashMap Text (m (Symbolic m))
forall k v1 v2 v3.
(Eq k, Hashable k) =>
(v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3
M.intersectionWith
(\m (Symbolic m)
i m (Symbolic m)
j -> m (Symbolic m)
i m (Symbolic m) -> (Symbolic m -> m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Symbolic m
i' ->
m (Symbolic m)
j
m (Symbolic m) -> (Symbolic m -> m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Symbolic m
j' -> Symbolic m -> (Symbolic m -> m (Symbolic m)) -> m (Symbolic m)
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand Symbolic m
i'
((Symbolic m -> m (Symbolic m)) -> m (Symbolic m))
-> (Symbolic m -> m (Symbolic m)) -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ \Symbolic m
i'' -> Symbolic m -> (Symbolic m -> m (Symbolic m)) -> m (Symbolic m)
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand Symbolic m
j' ((Symbolic m -> m (Symbolic m)) -> m (Symbolic m))
-> (Symbolic m -> m (Symbolic m)) -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ \Symbolic m
j'' -> m (Symbolic m) -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => m v -> m v
defer (m (Symbolic m) -> m (Symbolic m))
-> m (Symbolic m) -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context Symbolic m
i'' Symbolic m
j''
)
(Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbolic m -> m (Symbolic m))
-> HashMap Text (Symbolic m) -> HashMap Text (m (Symbolic m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (Symbolic m)
l)
(Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbolic m -> m (Symbolic m))
-> HashMap Text (Symbolic m) -> HashMap Text (m (Symbolic m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (Symbolic m)
r)
if HashMap Text (Symbolic m) -> Bool
forall k v. HashMap k v -> Bool
M.null HashMap Text (Symbolic m)
m then [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys else (Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet (HashMap Text (Symbolic m) -> Maybe (HashMap Text (Symbolic m))
forall a. a -> Maybe a
Just HashMap Text (Symbolic m)
m) NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
(TClosure{}, TClosure{}) ->
ErrorCall -> m [NTypeF m (Symbolic m)]
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m [NTypeF m (Symbolic m)])
-> ErrorCall -> m [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Cannot unify functions"
(TBuiltin String
_ Symbolic m -> m (Symbolic m)
_, TBuiltin String
_ Symbolic m -> m (Symbolic m)
_) ->
ErrorCall -> m [NTypeF m (Symbolic m)]
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m [NTypeF m (Symbolic m)])
-> ErrorCall -> m [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Cannot unify builtin functions"
(NTypeF m (Symbolic m), NTypeF m (Symbolic m))
_ | NTypeF m (Symbolic m) -> NTypeF m (Symbolic m) -> Ordering
forall (m :: * -> *) r. NTypeF m r -> NTypeF m r -> Ordering
compareTypes NTypeF m (Symbolic m)
x NTypeF m (Symbolic m)
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
LT -> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs (NTypeF m (Symbolic m)
y NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
: [NTypeF m (Symbolic m)]
ys)
| NTypeF m (Symbolic m) -> NTypeF m (Symbolic m) -> Ordering
forall (m :: * -> *) r. NTypeF m r -> NTypeF m r -> Ordering
compareTypes NTypeF m (Symbolic m)
x NTypeF m (Symbolic m)
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
GT -> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go (NTypeF m (Symbolic m)
x NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
: [NTypeF m (Symbolic m)]
xs) [NTypeF m (Symbolic m)]
ys
| Bool
otherwise -> String -> m [NTypeF m (Symbolic m)]
forall a. HasCallStack => String -> a
error String
"impossible"
unify
:: forall e m
. MonadLint e m
=> NExprF ()
-> Symbolic m
-> Symbolic m
-> m (Symbolic m)
unify :: NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context (SV SValue m
x) (SV SValue m
y) = do
NSymbolicF (NTypeF m (Symbolic m))
x' <- SValue m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readVar SValue m
x
NSymbolicF (NTypeF m (Symbolic m))
y' <- SValue m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readVar SValue m
y
case (NSymbolicF (NTypeF m (Symbolic m))
x', NSymbolicF (NTypeF m (Symbolic m))
y') of
(NSymbolicF (NTypeF m (Symbolic m))
NAny, NSymbolicF (NTypeF m (Symbolic m))
_) -> do
SValue m -> NSymbolicF (NTypeF m (Symbolic m)) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeVar SValue m
x NSymbolicF (NTypeF m (Symbolic m))
y'
Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbolic m -> m (Symbolic m)) -> Symbolic m -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ SValue m -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
y
(NSymbolicF (NTypeF m (Symbolic m))
_, NSymbolicF (NTypeF m (Symbolic m))
NAny) -> do
SValue m -> NSymbolicF (NTypeF m (Symbolic m)) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeVar SValue m
y NSymbolicF (NTypeF m (Symbolic m))
x'
Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbolic m -> m (Symbolic m)) -> Symbolic m -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ SValue m -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
x
(NMany [NTypeF m (Symbolic m)]
xs, NMany [NTypeF m (Symbolic m)]
ys) -> do
[NTypeF m (Symbolic m)]
m <- NExprF ()
-> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
merge NExprF ()
context [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
if [NTypeF m (Symbolic m)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NTypeF m (Symbolic m)]
m
then do
ErrorCall -> m (Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (Symbolic m)) -> ErrorCall -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Cannot unify "
else do
SValue m -> NSymbolicF (NTypeF m (Symbolic m)) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeVar SValue m
x ([NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m))
forall r. [r] -> NSymbolicF r
NMany [NTypeF m (Symbolic m)]
m)
SValue m -> NSymbolicF (NTypeF m (Symbolic m)) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeVar SValue m
y ([NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m))
forall r. [r] -> NSymbolicF r
NMany [NTypeF m (Symbolic m)]
m)
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic ([NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m))
forall r. [r] -> NSymbolicF r
NMany [NTypeF m (Symbolic m)]
m)
unify NExprF ()
_ Symbolic m
_ Symbolic m
_ = String -> m (Symbolic m)
forall a. HasCallStack => String -> a
error String
"The unexpected hath transpired!"
instance ToValue Bool m (Symbolic m) where
instance ToValue [Symbolic m] m (Symbolic m) where
instance FromValue NixString m (Symbolic m) where
instance FromValue (AttrSet (Symbolic m), AttrSet SourcePos) m (Symbolic m) where
instance ToValue (AttrSet (Symbolic m), AttrSet SourcePos) m (Symbolic m) where
instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)
=> MonadValue (Symbolic m) m where
defer :: m (Symbolic m) -> m (Symbolic m)
defer = (SThunk m -> Symbolic m) -> m (SThunk m) -> m (Symbolic m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SThunk m -> Symbolic m
forall (m :: * -> *). SThunk m -> Symbolic m
ST (m (SThunk m) -> m (Symbolic m))
-> (m (Symbolic m) -> m (SThunk m))
-> m (Symbolic m)
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Symbolic m) -> m (SThunk m)
forall t (m :: * -> *) a. MonadThunk t m a => m a -> m t
thunk
demand :: Symbolic m -> (Symbolic m -> m r) -> m r
demand (ST SThunk m
v) Symbolic m -> m r
f = SThunk m -> (Symbolic m -> m r) -> m r
forall t (m :: * -> *) a r.
MonadThunk t m a =>
t -> (a -> m r) -> m r
force SThunk m
v ((Symbolic m -> (Symbolic m -> m r) -> m r)
-> (Symbolic m -> m r) -> Symbolic m -> m r
forall a b c. (a -> b -> c) -> b -> a -> c
flip Symbolic m -> (Symbolic m -> m r) -> m r
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand Symbolic m -> m r
f)
demand (SV SValue m
v) Symbolic m -> m r
f = Symbolic m -> m r
f (SValue m -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
v)
instance MonadLint e m => MonadEval (Symbolic m) m where
freeVariable :: Text -> m (Symbolic m)
freeVariable Text
var = String -> m (Symbolic m)
forall e (m :: * -> *) a. MonadLint e m => String -> m a
symerr (String -> m (Symbolic m)) -> String -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ String
"Undefined variable '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
var String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
attrMissing :: NonEmpty Text -> Maybe (Symbolic m) -> m (Symbolic m)
attrMissing NonEmpty Text
ks Maybe (Symbolic m)
Nothing =
forall v (m :: * -> *) s a.
(MonadEval v m, Exception s) =>
s -> m a
forall (m :: * -> *) s a.
(MonadEval (Symbolic m) m, Exception s) =>
s -> m a
evalError @(Symbolic m)
(ErrorCall -> m (Symbolic m)) -> ErrorCall -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall
(String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$ String
"Inheriting unknown attribute: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Text
ks))
attrMissing NonEmpty Text
ks (Just Symbolic m
s) =
forall v (m :: * -> *) s a.
(MonadEval v m, Exception s) =>
s -> m a
forall (m :: * -> *) s a.
(MonadEval (Symbolic m) m, Exception s) =>
s -> m a
evalError @(Symbolic m)
(ErrorCall -> m (Symbolic m)) -> ErrorCall -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall
(String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$ String
"Could not look up attribute "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Text
ks))
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Symbolic m -> String
forall a. Show a => a -> String
show Symbolic m
s
evalCurPos :: m (Symbolic m)
evalCurPos = do
Symbolic m
f <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TPath]
Symbolic m
l <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
Symbolic m
c <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
[NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet (HashMap Text (Symbolic m) -> Maybe (HashMap Text (Symbolic m))
forall a. a -> Maybe a
Just ([(Text, Symbolic m)] -> HashMap Text (Symbolic m)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList (Symbolic m -> Symbolic m -> Symbolic m -> [(Text, Symbolic m)]
forall b. b -> b -> b -> [(Text, b)]
go Symbolic m
f Symbolic m
l Symbolic m
c)))]
where
go :: b -> b -> b -> [(Text, b)]
go b
f b
l b
c =
[(String -> Text
Text.pack String
"file", b
f), (String -> Text
Text.pack String
"line", b
l), (String -> Text
Text.pack String
"col", b
c)]
evalConstant :: NAtom -> m (Symbolic m)
evalConstant NAtom
c = [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NAtom -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. NAtom -> NTypeF m r
go NAtom
c]
where
go :: NAtom -> NTypeF m r
go = \case
NURI Text
_ -> NTypeF m r
forall (m :: * -> *) r. NTypeF m r
TStr
NInt Integer
_ -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]
NFloat Float
_ -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TFloat]
NBool Bool
_ -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]
NAtom
NNull -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TNull]
evalString :: NString (m (Symbolic m)) -> m (Symbolic m)
evalString = m (Symbolic m) -> NString (m (Symbolic m)) -> m (Symbolic m)
forall a b. a -> b -> a
const (m (Symbolic m) -> NString (m (Symbolic m)) -> m (Symbolic m))
-> m (Symbolic m) -> NString (m (Symbolic m)) -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TStr]
evalLiteralPath :: String -> m (Symbolic m)
evalLiteralPath = m (Symbolic m) -> String -> m (Symbolic m)
forall a b. a -> b -> a
const (m (Symbolic m) -> String -> m (Symbolic m))
-> m (Symbolic m) -> String -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TPath]
evalEnvPath :: String -> m (Symbolic m)
evalEnvPath = m (Symbolic m) -> String -> m (Symbolic m)
forall a b. a -> b -> a
const (m (Symbolic m) -> String -> m (Symbolic m))
-> m (Symbolic m) -> String -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TPath]
evalUnary :: NUnaryOp -> Symbolic m -> m (Symbolic m)
evalUnary NUnaryOp
op Symbolic m
arg =
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (NUnaryOp -> Symbolic m -> NExprF (Symbolic m)
forall r. NUnaryOp -> r -> NExprF r
NUnary NUnaryOp
op Symbolic m
arg)) Symbolic m
arg (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool]]
evalBinary :: NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
evalBinary = NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
forall e (m :: * -> *).
(MonadLint e m, MonadEval (Symbolic m) m) =>
NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
lintBinaryOp
evalWith :: m (Symbolic m) -> m (Symbolic m) -> m (Symbolic m)
evalWith m (Symbolic m)
scope m (Symbolic m)
body = do
Symbolic m
s <- m (Symbolic m) -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => m v -> m v
defer m (Symbolic m)
scope
m (HashMap Text (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a r.
(Functor m, Scoped a m) =>
m (AttrSet a) -> m r -> m r
pushWeakScope (m (HashMap Text (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m))
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m))
-> m (Symbolic m)
forall (f :: * -> *) a b. Functor f => f (a -> b) -> a -> f b
?? m (Symbolic m)
body (m (HashMap Text (Symbolic m)) -> m (Symbolic m))
-> m (HashMap Text (Symbolic m)) -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ Symbolic m
-> (Symbolic m -> m (HashMap Text (Symbolic m)))
-> m (HashMap Text (Symbolic m))
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand Symbolic m
s ((Symbolic m -> m (HashMap Text (Symbolic m)))
-> m (HashMap Text (Symbolic m)))
-> (Symbolic m -> m (HashMap Text (Symbolic m)))
-> m (HashMap Text (Symbolic m))
forall a b. (a -> b) -> a -> b
$ Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *).
(MonadVar m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> (NSymbolicF (NTypeF m (Symbolic m))
-> m (HashMap Text (Symbolic m)))
-> Symbolic m
-> m (HashMap Text (Symbolic m))
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
NMany [TSet (Just HashMap Text (Symbolic m)
s')] -> HashMap Text (Symbolic m) -> m (HashMap Text (Symbolic m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Text (Symbolic m)
s'
NMany [TSet Maybe (HashMap Text (Symbolic m))
Nothing] -> String -> m (HashMap Text (Symbolic m))
forall a. HasCallStack => String -> a
error String
"NYI: with unknown"
NSymbolicF (NTypeF m (Symbolic m))
_ -> ErrorCall -> m (HashMap Text (Symbolic m))
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m)))
-> ErrorCall -> m (HashMap Text (Symbolic m))
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"scope must be a set in with statement"
evalIf :: Symbolic m -> m (Symbolic m) -> m (Symbolic m) -> m (Symbolic m)
evalIf Symbolic m
cond m (Symbolic m)
t m (Symbolic m)
f = do
Symbolic m
t' <- m (Symbolic m)
t
Symbolic m
f' <- m (Symbolic m)
f
let e :: NExprF (Symbolic m)
e = Symbolic m -> Symbolic m -> Symbolic m -> NExprF (Symbolic m)
forall r. r -> r -> r -> NExprF r
NIf Symbolic m
cond Symbolic m
t' Symbolic m
f'
Symbolic m
_ <- NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
cond (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
t' Symbolic m
f'
evalAssert :: Symbolic m -> m (Symbolic m) -> m (Symbolic m)
evalAssert Symbolic m
cond m (Symbolic m)
body = do
Symbolic m
body' <- m (Symbolic m)
body
let e :: NExprF (Symbolic m)
e = Symbolic m -> Symbolic m -> NExprF (Symbolic m)
forall r. r -> r -> NExprF r
NAssert Symbolic m
cond Symbolic m
body'
Symbolic m
_ <- NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
cond (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Symbolic m
body'
evalApp :: Symbolic m -> m (Symbolic m) -> m (Symbolic m)
evalApp = (((HashMap Text (Symbolic m), Symbolic m) -> Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m) -> m (Symbolic m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HashMap Text (Symbolic m), Symbolic m) -> Symbolic m
forall a b. (a, b) -> b
snd (m (HashMap Text (Symbolic m), Symbolic m) -> m (Symbolic m))
-> (m (Symbolic m) -> m (HashMap Text (Symbolic m), Symbolic m))
-> m (Symbolic m)
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((m (Symbolic m) -> m (HashMap Text (Symbolic m), Symbolic m))
-> m (Symbolic m) -> m (Symbolic m))
-> (Symbolic m
-> m (Symbolic m) -> m (HashMap Text (Symbolic m), Symbolic m))
-> Symbolic m
-> m (Symbolic m)
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
lintApp (NBinaryOp -> () -> () -> NExprF ()
forall r. NBinaryOp -> r -> r -> NExprF r
NBinary NBinaryOp
NApp () ())
evalAbs :: Params (m (Symbolic m))
-> (forall a.
m (Symbolic m)
-> (AttrSet (m (Symbolic m))
-> m (Symbolic m) -> m (a, Symbolic m))
-> m (a, Symbolic m))
-> m (Symbolic m)
evalAbs Params (m (Symbolic m))
params forall a.
m (Symbolic m)
-> (AttrSet (m (Symbolic m))
-> m (Symbolic m) -> m (a, Symbolic m))
-> m (a, Symbolic m)
_ = [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [Params () -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Params () -> NTypeF m r
TClosure (Params (m (Symbolic m)) -> Params ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Params (m (Symbolic m))
params)]
evalError :: s -> m a
evalError = s -> m a
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError
lintBinaryOp
:: forall e m
. (MonadLint e m, MonadEval (Symbolic m) m)
=> NBinaryOp
-> Symbolic m
-> m (Symbolic m)
-> m (Symbolic m)
lintBinaryOp :: NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
lintBinaryOp NBinaryOp
op Symbolic m
lsym m (Symbolic m)
rarg = do
Symbolic m
rsym <- m (Symbolic m)
rarg
Symbolic m
y <- m (Symbolic m) -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => m v -> m v
defer m (Symbolic m)
forall (m :: * -> *). MonadVar m => m (Symbolic m)
everyPossible
case NBinaryOp
op of
NBinaryOp
NApp -> String -> m (Symbolic m)
forall e (m :: * -> *) a. MonadLint e m => String -> m a
symerr String
"lintBinaryOp:NApp: should never get here"
NBinaryOp
NEq -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull], NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TStr, Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y]
NBinaryOp
NNEq -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull], NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TStr, Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y]
NBinaryOp
NLt -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
NBinaryOp
NLte -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
NBinaryOp
NGt -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
NBinaryOp
NGte -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
NBinaryOp
NAnd -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
NBinaryOp
NOr -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
NBinaryOp
NImpl -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
NBinaryOp
NPlus -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt], NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TStr, NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TPath]
NBinaryOp
NMinus -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
NBinaryOp
NMult -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
NBinaryOp
NDiv -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
NBinaryOp
NUpdate -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet Maybe (HashMap Text (Symbolic m))
forall a. Maybe a
Nothing]
NBinaryOp
NConcat -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y]
where
check :: Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym [NTypeF m (Symbolic m)]
xs = do
let e :: NExprF (Symbolic m)
e = NBinaryOp -> Symbolic m -> Symbolic m -> NExprF (Symbolic m)
forall r. NBinaryOp -> r -> r -> NExprF r
NBinary NBinaryOp
op Symbolic m
lsym Symbolic m
rsym
Symbolic m
m <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadVar m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)]
xs
Symbolic m
_ <- NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
lsym Symbolic m
m
Symbolic m
_ <- NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
rsym Symbolic m
m
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
lsym Symbolic m
rsym
infixl 1 `lintApp`
lintApp
:: forall e m
. MonadLint e m
=> NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp :: NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
lintApp NExprF ()
context Symbolic m
fun m (Symbolic m)
arg = Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *).
(MonadVar m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic Symbolic m
fun m (NSymbolicF (NTypeF m (Symbolic m)))
-> (NSymbolicF (NTypeF m (Symbolic m))
-> m (HashMap Text (Symbolic m), Symbolic m))
-> m (HashMap Text (Symbolic m), Symbolic m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
NSymbolicF (NTypeF m (Symbolic m))
NAny ->
ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Cannot apply something not known to be a function"
NMany [NTypeF m (Symbolic m)]
xs -> do
([HashMap Text (Symbolic m)]
args, [Symbolic m]
ys) <- ([(HashMap Text (Symbolic m), Symbolic m)]
-> ([HashMap Text (Symbolic m)], [Symbolic m]))
-> m [(HashMap Text (Symbolic m), Symbolic m)]
-> m ([HashMap Text (Symbolic m)], [Symbolic m])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(HashMap Text (Symbolic m), Symbolic m)]
-> ([HashMap Text (Symbolic m)], [Symbolic m])
forall a b. [(a, b)] -> ([a], [b])
unzip (m [(HashMap Text (Symbolic m), Symbolic m)]
-> m ([HashMap Text (Symbolic m)], [Symbolic m]))
-> m [(HashMap Text (Symbolic m), Symbolic m)]
-> m ([HashMap Text (Symbolic m)], [Symbolic m])
forall a b. (a -> b) -> a -> b
$ [NTypeF m (Symbolic m)]
-> (NTypeF m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m))
-> m [(HashMap Text (Symbolic m), Symbolic m)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NTypeF m (Symbolic m)]
xs ((NTypeF m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m))
-> m [(HashMap Text (Symbolic m), Symbolic m)])
-> (NTypeF m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m))
-> m [(HashMap Text (Symbolic m), Symbolic m)]
forall a b. (a -> b) -> a -> b
$ \case
TClosure Params ()
_params -> m (Symbolic m)
arg m (Symbolic m)
-> (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *).
(MonadVar m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic m (NSymbolicF (NTypeF m (Symbolic m)))
-> (NSymbolicF (NTypeF m (Symbolic m))
-> m (HashMap Text (Symbolic m), Symbolic m))
-> m (HashMap Text (Symbolic m), Symbolic m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
NSymbolicF (NTypeF m (Symbolic m))
NAny -> do
String -> m (HashMap Text (Symbolic m), Symbolic m)
forall a. HasCallStack => String -> a
error String
"NYI"
NMany [TSet (Just HashMap Text (Symbolic m)
_)] -> do
String -> m (HashMap Text (Symbolic m), Symbolic m)
forall a. HasCallStack => String -> a
error String
"NYI"
NMany [NTypeF m (Symbolic m)]
_ -> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp NMany not set"
TBuiltin String
_ Symbolic m -> m (Symbolic m)
_f -> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp builtin"
TSet Maybe (HashMap Text (Symbolic m))
_m -> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp Set"
NTypeF m (Symbolic m)
_x -> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Attempt to call non-function"
Symbolic m
y <- m (Symbolic m)
forall (m :: * -> *). MonadVar m => m (Symbolic m)
everyPossible
([HashMap Text (Symbolic m)] -> HashMap Text (Symbolic m)
forall a. [a] -> a
head [HashMap Text (Symbolic m)]
args, ) (Symbolic m -> (HashMap Text (Symbolic m), Symbolic m))
-> m (Symbolic m) -> m (HashMap Text (Symbolic m), Symbolic m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Symbolic m -> Symbolic m -> m (Symbolic m))
-> Symbolic m -> [Symbolic m] -> m (Symbolic m)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context) Symbolic m
y [Symbolic m]
ys
newtype Lint s a = Lint
{ Lint s a
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
runLint :: ReaderT (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a }
deriving
( a -> Lint s b -> Lint s a
(a -> b) -> Lint s a -> Lint s b
(forall a b. (a -> b) -> Lint s a -> Lint s b)
-> (forall a b. a -> Lint s b -> Lint s a) -> Functor (Lint s)
forall a b. a -> Lint s b -> Lint s a
forall a b. (a -> b) -> Lint s a -> Lint s b
forall s a b. a -> Lint s b -> Lint s a
forall s a b. (a -> b) -> Lint s a -> Lint s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Lint s b -> Lint s a
$c<$ :: forall s a b. a -> Lint s b -> Lint s a
fmap :: (a -> b) -> Lint s a -> Lint s b
$cfmap :: forall s a b. (a -> b) -> Lint s a -> Lint s b
Functor
, Functor (Lint s)
a -> Lint s a
Functor (Lint s)
-> (forall a. a -> Lint s a)
-> (forall a b. Lint s (a -> b) -> Lint s a -> Lint s b)
-> (forall a b c.
(a -> b -> c) -> Lint s a -> Lint s b -> Lint s c)
-> (forall a b. Lint s a -> Lint s b -> Lint s b)
-> (forall a b. Lint s a -> Lint s b -> Lint s a)
-> Applicative (Lint s)
Lint s a -> Lint s b -> Lint s b
Lint s a -> Lint s b -> Lint s a
Lint s (a -> b) -> Lint s a -> Lint s b
(a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
forall s. Functor (Lint s)
forall a. a -> Lint s a
forall s a. a -> Lint s a
forall a b. Lint s a -> Lint s b -> Lint s a
forall a b. Lint s a -> Lint s b -> Lint s b
forall a b. Lint s (a -> b) -> Lint s a -> Lint s b
forall s a b. Lint s a -> Lint s b -> Lint s a
forall s a b. Lint s a -> Lint s b -> Lint s b
forall s a b. Lint s (a -> b) -> Lint s a -> Lint s b
forall a b c. (a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
forall s a b c. (a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Lint s a -> Lint s b -> Lint s a
$c<* :: forall s a b. Lint s a -> Lint s b -> Lint s a
*> :: Lint s a -> Lint s b -> Lint s b
$c*> :: forall s a b. Lint s a -> Lint s b -> Lint s b
liftA2 :: (a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
$cliftA2 :: forall s a b c. (a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
<*> :: Lint s (a -> b) -> Lint s a -> Lint s b
$c<*> :: forall s a b. Lint s (a -> b) -> Lint s a -> Lint s b
pure :: a -> Lint s a
$cpure :: forall s a. a -> Lint s a
$cp1Applicative :: forall s. Functor (Lint s)
Applicative
, Applicative (Lint s)
a -> Lint s a
Applicative (Lint s)
-> (forall a b. Lint s a -> (a -> Lint s b) -> Lint s b)
-> (forall a b. Lint s a -> Lint s b -> Lint s b)
-> (forall a. a -> Lint s a)
-> Monad (Lint s)
Lint s a -> (a -> Lint s b) -> Lint s b
Lint s a -> Lint s b -> Lint s b
forall s. Applicative (Lint s)
forall a. a -> Lint s a
forall s a. a -> Lint s a
forall a b. Lint s a -> Lint s b -> Lint s b
forall a b. Lint s a -> (a -> Lint s b) -> Lint s b
forall s a b. Lint s a -> Lint s b -> Lint s b
forall s a b. Lint s a -> (a -> Lint s b) -> Lint s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Lint s a
$creturn :: forall s a. a -> Lint s a
>> :: Lint s a -> Lint s b -> Lint s b
$c>> :: forall s a b. Lint s a -> Lint s b -> Lint s b
>>= :: Lint s a -> (a -> Lint s b) -> Lint s b
$c>>= :: forall s a b. Lint s a -> (a -> Lint s b) -> Lint s b
$cp1Monad :: forall s. Applicative (Lint s)
Monad
, Monad (Lint s)
Monad (Lint s)
-> (forall a. (a -> Lint s a) -> Lint s a) -> MonadFix (Lint s)
(a -> Lint s a) -> Lint s a
forall s. Monad (Lint s)
forall a. (a -> Lint s a) -> Lint s a
forall s a. (a -> Lint s a) -> Lint s a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: (a -> Lint s a) -> Lint s a
$cmfix :: forall s a. (a -> Lint s a) -> Lint s a
$cp1MonadFix :: forall s. Monad (Lint s)
MonadFix
, MonadReader (Context (Lint s) (Symbolic (Lint s)))
, Eq (ThunkId (Lint s))
Monad (Lint s)
Ord (ThunkId (Lint s))
Show (ThunkId (Lint s))
Typeable (ThunkId (Lint s))
Lint s (ThunkId (Lint s))
Monad (Lint s)
-> Eq (ThunkId (Lint s))
-> Ord (ThunkId (Lint s))
-> Show (ThunkId (Lint s))
-> Typeable (ThunkId (Lint s))
-> Lint s (ThunkId (Lint s))
-> MonadThunkId (Lint s)
forall s. Eq (ThunkId (Lint s))
forall s. Monad (Lint s)
forall s. Ord (ThunkId (Lint s))
forall s. Show (ThunkId (Lint s))
forall s. Typeable (ThunkId (Lint s))
forall s. Lint s (ThunkId (Lint s))
forall (m :: * -> *).
Monad m
-> Eq (ThunkId m)
-> Ord (ThunkId m)
-> Show (ThunkId m)
-> Typeable (ThunkId m)
-> m (ThunkId m)
-> MonadThunkId m
freshId :: Lint s (ThunkId (Lint s))
$cfreshId :: forall s. Lint s (ThunkId (Lint s))
$cp5MonadThunkId :: forall s. Typeable (ThunkId (Lint s))
$cp4MonadThunkId :: forall s. Show (ThunkId (Lint s))
$cp3MonadThunkId :: forall s. Ord (ThunkId (Lint s))
$cp2MonadThunkId :: forall s. Eq (ThunkId (Lint s))
$cp1MonadThunkId :: forall s. Monad (Lint s)
MonadThunkId
, Monad (Lint s)
a -> Lint s (Ref (Lint s) a)
Monad (Lint s)
-> (forall a. a -> Lint s (Ref (Lint s) a))
-> (forall a. Ref (Lint s) a -> Lint s a)
-> (forall a. Ref (Lint s) a -> a -> Lint s ())
-> (forall a. Ref (Lint s) a -> (a -> a) -> Lint s ())
-> (forall a. Ref (Lint s) a -> (a -> a) -> Lint s ())
-> MonadRef (Lint s)
Ref (Lint s) a -> Lint s a
Ref (Lint s) a -> a -> Lint s ()
Ref (Lint s) a -> (a -> a) -> Lint s ()
Ref (Lint s) a -> (a -> a) -> Lint s ()
forall s. Monad (Lint s)
forall a. a -> Lint s (Ref (Lint s) a)
forall a. Ref (Lint s) a -> Lint s a
forall a. Ref (Lint s) a -> a -> Lint s ()
forall a. Ref (Lint s) a -> (a -> a) -> Lint s ()
forall s a. a -> Lint s (Ref (Lint s) a)
forall s a. Ref (Lint s) a -> Lint s a
forall s a. Ref (Lint s) a -> a -> Lint s ()
forall s a. Ref (Lint s) a -> (a -> a) -> Lint s ()
forall (m :: * -> *).
Monad m
-> (forall a. a -> m (Ref m a))
-> (forall a. Ref m a -> m a)
-> (forall a. Ref m a -> a -> m ())
-> (forall a. Ref m a -> (a -> a) -> m ())
-> (forall a. Ref m a -> (a -> a) -> m ())
-> MonadRef m
modifyRef' :: Ref (Lint s) a -> (a -> a) -> Lint s ()
$cmodifyRef' :: forall s a. Ref (Lint s) a -> (a -> a) -> Lint s ()
modifyRef :: Ref (Lint s) a -> (a -> a) -> Lint s ()
$cmodifyRef :: forall s a. Ref (Lint s) a -> (a -> a) -> Lint s ()
writeRef :: Ref (Lint s) a -> a -> Lint s ()
$cwriteRef :: forall s a. Ref (Lint s) a -> a -> Lint s ()
readRef :: Ref (Lint s) a -> Lint s a
$creadRef :: forall s a. Ref (Lint s) a -> Lint s a
newRef :: a -> Lint s (Ref (Lint s) a)
$cnewRef :: forall s a. a -> Lint s (Ref (Lint s) a)
$cp1MonadRef :: forall s. Monad (Lint s)
MonadRef
, MonadRef (Lint s)
Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
MonadRef (Lint s)
-> (forall a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b)
-> (forall a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b)
-> MonadAtomicRef (Lint s)
forall s. MonadRef (Lint s)
forall a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
forall s a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
forall (m :: * -> *).
MonadRef m
-> (forall a b. Ref m a -> (a -> (a, b)) -> m b)
-> (forall a b. Ref m a -> (a -> (a, b)) -> m b)
-> MonadAtomicRef m
atomicModifyRef' :: Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
$catomicModifyRef' :: forall s a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
atomicModifyRef :: Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
$catomicModifyRef :: forall s a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
$cp1MonadAtomicRef :: forall s. MonadRef (Lint s)
MonadAtomicRef
)
instance MonadThrow (Lint s) where
throwM :: e -> Lint s a
throwM e
e = ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall s a.
ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
Lint (ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a)
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall a b. (a -> b) -> a -> b
$ (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a)
-> (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall a b. (a -> b) -> a -> b
$ \Context (Lint s) (Symbolic (Lint s))
_ -> e -> FreshIdT Int (ST s) a
forall a e. Exception e => e -> a
throw e
e
instance MonadCatch (Lint s) where
catch :: Lint s a -> (e -> Lint s a) -> Lint s a
catch Lint s a
_m e -> Lint s a
_h = ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall s a.
ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
Lint (ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a)
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall a b. (a -> b) -> a -> b
$ (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a)
-> (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall a b. (a -> b) -> a -> b
$ \Context (Lint s) (Symbolic (Lint s))
_ -> String -> FreshIdT Int (ST s) a
forall a. HasCallStack => String -> a
error String
"Cannot catch in 'Lint s'"
runLintM :: Options -> Lint s a -> ST s a
runLintM :: Options -> Lint s a -> ST s a
runLintM Options
opts Lint s a
action = do
STRef s Int
i <- Int -> ST s (Ref (ST s) Int)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
newVar (Int
1 :: Int)
Ref (ST s) Int -> FreshIdT Int (ST s) a -> ST s a
forall (m :: * -> *) i a.
Functor m =>
Var m i -> FreshIdT i m a -> m a
runFreshIdT STRef s Int
Ref (ST s) Int
i (FreshIdT Int (ST s) a -> ST s a)
-> FreshIdT Int (ST s) a -> ST s a
forall a b. (a -> b) -> a -> b
$ (ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> Context (Lint s) (Symbolic (Lint s))
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> FreshIdT Int (ST s) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Options -> Context (Lint s) (Symbolic (Lint s))
forall (m :: * -> *) t. Options -> Context m t
newContext Options
opts) (ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> FreshIdT Int (ST s) a)
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> FreshIdT Int (ST s) a
forall a b. (a -> b) -> a -> b
$ Lint s a
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall s a.
Lint s a
-> ReaderT
(Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
runLint Lint s a
action
symbolicBaseEnv :: Monad m => m (Scopes m (Symbolic m))
symbolicBaseEnv :: m (Scopes m (Symbolic m))
symbolicBaseEnv = Scopes m (Symbolic m) -> m (Scopes m (Symbolic m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scopes m (Symbolic m)
forall (m :: * -> *) a. Scopes m a
emptyScopes
lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
lint Options
opts NExprLoc
expr =
Options -> Lint s (Symbolic (Lint s)) -> ST s (Symbolic (Lint s))
forall s a. Options -> Lint s a -> ST s a
runLintM Options
opts
(Lint s (Symbolic (Lint s)) -> ST s (Symbolic (Lint s)))
-> Lint s (Symbolic (Lint s)) -> ST s (Symbolic (Lint s))
forall a b. (a -> b) -> a -> b
$ Lint s (Scopes (Lint s) (Symbolic (Lint s)))
forall (m :: * -> *). Monad m => m (Scopes m (Symbolic m))
symbolicBaseEnv
Lint s (Scopes (Lint s) (Symbolic (Lint s)))
-> (Scopes (Lint s) (Symbolic (Lint s))
-> Lint s (Symbolic (Lint s)))
-> Lint s (Symbolic (Lint s))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Scopes (Lint s) (Symbolic (Lint s))
-> Lint s (Symbolic (Lint s)) -> Lint s (Symbolic (Lint s))
forall a (m :: * -> *) r. Scoped a m => Scopes m a -> m r -> m r
`pushScopes` (Compose (Ann SrcSpan) NExprF (Lint s (Symbolic (Lint s)))
-> Lint s (Symbolic (Lint s)))
-> ((NExprLoc -> Lint s (Symbolic (Lint s)))
-> NExprLoc -> Lint s (Symbolic (Lint s)))
-> NExprLoc
-> Lint s (Symbolic (Lint s))
forall (f :: * -> *) a.
Functor f =>
(f a -> a) -> ((Fix f -> a) -> Fix f -> a) -> Fix f -> a
adi (NExprF (Lint s (Symbolic (Lint s))) -> Lint s (Symbolic (Lint s))
forall v (m :: * -> *). MonadNixEval v m => NExprF (m v) -> m v
Eval.eval (NExprF (Lint s (Symbolic (Lint s))) -> Lint s (Symbolic (Lint s)))
-> (Compose (Ann SrcSpan) NExprF (Lint s (Symbolic (Lint s)))
-> NExprF (Lint s (Symbolic (Lint s))))
-> Compose (Ann SrcSpan) NExprF (Lint s (Symbolic (Lint s)))
-> Lint s (Symbolic (Lint s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann SrcSpan (NExprF (Lint s (Symbolic (Lint s))))
-> NExprF (Lint s (Symbolic (Lint s)))
forall ann a. Ann ann a -> a
annotated (Ann SrcSpan (NExprF (Lint s (Symbolic (Lint s))))
-> NExprF (Lint s (Symbolic (Lint s))))
-> (Compose (Ann SrcSpan) NExprF (Lint s (Symbolic (Lint s)))
-> Ann SrcSpan (NExprF (Lint s (Symbolic (Lint s)))))
-> Compose (Ann SrcSpan) NExprF (Lint s (Symbolic (Lint s)))
-> NExprF (Lint s (Symbolic (Lint s)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose (Ann SrcSpan) NExprF (Lint s (Symbolic (Lint s)))
-> Ann SrcSpan (NExprF (Lint s (Symbolic (Lint s))))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose)
(NExprLoc -> Lint s (Symbolic (Lint s)))
-> NExprLoc -> Lint s (Symbolic (Lint s))
forall e (m :: * -> *) a.
(MonadReader e m, Has e SrcSpan) =>
Transform NExprLocF (m a)
Eval.addSourcePositions
NExprLoc
expr
)
instance Scoped (Symbolic (Lint s)) (Lint s) where
currentScopes :: Lint s (Scopes (Lint s) (Symbolic (Lint s)))
currentScopes = Lint s (Scopes (Lint s) (Symbolic (Lint s)))
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
m (Scopes m a)
currentScopesReader
clearScopes :: Lint s r -> Lint s r
clearScopes = forall e r.
(MonadReader e (Lint s),
Has e (Scopes (Lint s) (Symbolic (Lint s)))) =>
Lint s r -> Lint s r
forall (m :: * -> *) a e r.
(MonadReader e m, Has e (Scopes m a)) =>
m r -> m r
clearScopesReader @(Lint s) @(Symbolic (Lint s))
pushScopes :: Scopes (Lint s) (Symbolic (Lint s)) -> Lint s r -> Lint s r
pushScopes = Scopes (Lint s) (Symbolic (Lint s)) -> Lint s r -> Lint s r
forall e (m :: * -> *) a r.
(MonadReader e m, Has e (Scopes m a)) =>
Scopes m a -> m r -> m r
pushScopesReader
lookupVar :: Text -> Lint s (Maybe (Symbolic (Lint s)))
lookupVar = Text -> Lint s (Maybe (Symbolic (Lint s)))
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
Text -> m (Maybe a)
lookupVarReader