{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -Wno-missing-methods #-}
module Nix.Lint where
import Prelude hiding ( head
, force
)
import Nix.Utils
import Control.Monad ( foldM )
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.Ref
import Control.Monad.ST
import qualified Data.HashMap.Lazy as M
import Data.List
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as Text
import qualified Text.Show
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.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
Ord)
data NTypeF (m :: Type -> Type) r
= TConstant [TAtom]
| TStr
| TList r
| TSet (Maybe (HashMap Text r))
| TClosure (Params ())
| TPath
| TBuiltin Text (Symbolic m -> m r)
deriving (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
<$ :: forall a b. a -> NTypeF m b -> NTypeF m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> NTypeF m b -> NTypeF m a
fmap :: forall a b. (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 :: forall (m :: * -> *) r. 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 Text
_ Symbolic m -> m r
_) (TBuiltin Text
_ 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
Ord, (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
<$ :: forall a b. a -> NSymbolicF b -> NSymbolicF a
$c<$ :: forall a b. a -> NSymbolicF b -> NSymbolicF a
fmap :: forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b
$cfmap :: forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b
Functor, (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 :: forall a. Num a => NSymbolicF a -> a
$cproduct :: forall a. Num a => NSymbolicF a -> a
sum :: forall a. Num a => NSymbolicF a -> a
$csum :: forall a. Num a => NSymbolicF a -> a
minimum :: forall a. Ord a => NSymbolicF a -> a
$cminimum :: forall a. Ord a => NSymbolicF a -> a
maximum :: forall a. Ord a => NSymbolicF a -> a
$cmaximum :: forall a. Ord a => NSymbolicF a -> a
elem :: forall a. Eq a => a -> NSymbolicF a -> Bool
$celem :: forall a. Eq a => a -> NSymbolicF a -> Bool
length :: forall a. NSymbolicF a -> Int
$clength :: forall a. NSymbolicF a -> Int
null :: forall a. NSymbolicF a -> Bool
$cnull :: forall a. NSymbolicF a -> Bool
toList :: forall a. NSymbolicF a -> [a]
$ctoList :: forall a. NSymbolicF a -> [a]
foldl1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
foldr1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
foldl :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
foldr :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
fold :: forall m. Monoid m => 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
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 :: forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
Traversable)
type SThunk (m :: Type -> Type) = NThunkF m (Symbolic m)
type SValue (m :: Type -> Type) = Ref m (NSymbolicF (NTypeF m (Symbolic m)))
data Symbolic m = SV { forall (m :: * -> *). Symbolic m -> SValue m
getSV :: SValue m } | ST { forall (m :: * -> *). Symbolic m -> SThunk m
getST :: SThunk m }
instance Show (Symbolic m) where
show :: Symbolic m -> String
show Symbolic m
_ = String
"<symbolic>"
everyPossible
:: MonadAtomicRef m
=> m (Symbolic m)
everyPossible :: forall (m :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible = NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic NSymbolicF (NTypeF m (Symbolic m))
forall r. NSymbolicF r
NAny
mkSymbolic
:: MonadAtomicRef m
=> [NTypeF m (Symbolic m)]
-> m (Symbolic m)
mkSymbolic :: forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)]
xs = NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef 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
:: MonadAtomicRef m
=> NSymbolicF (NTypeF m (Symbolic m))
-> m (Symbolic m)
packSymbolic :: forall (m :: * -> *).
MonadAtomicRef m =>
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)
newRef
unpackSymbolic
:: (MonadAtomicRef m, MonadThunkId m, MonadCatch m)
=> Symbolic m
-> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic :: forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic = Ref m (NSymbolicF (NTypeF m (Symbolic m)))
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef (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 (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> (Symbolic m -> m (Symbolic m))
-> Symbolic m
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand
type MonadLint e m =
( Scoped (Symbolic m) m
, Framed e m
, MonadAtomicRef m
, MonadCatch m
, MonadThunkId m
)
symerr :: forall e m a . MonadLint e m => Text -> m a
symerr :: forall e (m :: * -> *) a. MonadLint e m => Text -> m a
symerr = forall v (m :: * -> *) s a.
(MonadEval v m, Exception s) =>
s -> m a
evalError @(Symbolic m) (ErrorCall -> m a) -> (Text -> ErrorCall) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall) -> (Text -> String) -> Text -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString
renderSymbolic :: MonadLint e m => Symbolic m -> m Text
renderSymbolic :: forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic = Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *).
(MonadAtomicRef 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 Text)
-> Symbolic m
-> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
NSymbolicF (NTypeF m (Symbolic m))
NAny -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<any>"
NMany [NTypeF m (Symbolic m)]
xs -> ([Text] -> Text) -> m [Text] -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> Text
Text.intercalate Text
", ") (m [Text] -> m Text) -> m [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ [NTypeF m (Symbolic m)]
-> (NTypeF m (Symbolic m) -> m Text) -> m [Text]
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 Text) -> m [Text])
-> (NTypeF m (Symbolic m) -> m Text) -> m [Text]
forall a b. (a -> b) -> a -> b
$ \case
TConstant [TAtom]
ys -> ([Text] -> Text) -> m [Text] -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> Text
Text.intercalate Text
", ") (m [Text] -> m Text) -> m [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ [TAtom] -> (TAtom -> m Text) -> m [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TAtom]
ys ((TAtom -> m Text) -> m [Text]) -> (TAtom -> m Text) -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> (TAtom -> Text) -> TAtom -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
TAtom
TInt -> Text
"int"
TAtom
TFloat -> Text
"float"
TAtom
TBool -> Text
"bool"
TAtom
TNull -> Text
"null"
NTypeF m (Symbolic m)
TStr -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"string"
TList Symbolic m
r -> do
Text
x <- Symbolic m -> m Text
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic (Symbolic m -> m Text) -> m (Symbolic m) -> m Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
r
pure $ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
TSet Maybe (HashMap Text (Symbolic m))
Nothing -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<any set>"
TSet (Just HashMap Text (Symbolic m)
s) -> do
HashMap Text Text
x <- (Symbolic m -> m Text)
-> HashMap Text (Symbolic m) -> m (HashMap Text Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Symbolic m -> m Text
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic (Symbolic m -> m Text)
-> (Symbolic m -> m (Symbolic m)) -> Symbolic m -> m Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand) HashMap Text (Symbolic m)
s
pure $ Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashMap Text Text -> Text
forall b a. (Show a, IsString b) => a -> b
show HashMap Text Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
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 :: * -> *).
MonadAtomicRef 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 :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible
HashMap Text Text
args' <- (Symbolic m -> m Text)
-> HashMap Text (Symbolic m) -> m (HashMap Text Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Symbolic m -> m Text
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic HashMap Text (Symbolic m)
args
Text
sym' <- Symbolic m -> m Text
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic Symbolic m
sym
pure $ Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashMap Text Text -> Text
forall b a. (Show a, IsString b) => a -> b
show HashMap Text Text
args' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sym' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
NTypeF m (Symbolic m)
TPath -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"path"
TBuiltin Text
_n Symbolic m -> m (Symbolic m)
_f -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<builtin function>"
merge
:: forall e m
. MonadLint e m
=> NExprF ()
-> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
merge :: 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)]
-> [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)]
_ = m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
go [NTypeF m (Symbolic m)]
_ [] = m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
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
l' ->
(\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
) (Symbolic m -> m [NTypeF m (Symbolic m)])
-> m (Symbolic m) -> m [NTypeF m (Symbolic m)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
r
) (Symbolic m -> m [NTypeF m (Symbolic m)])
-> m (Symbolic m) -> m [NTypeF m (Symbolic m)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
l
(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 ->
do
Symbolic m
i'' <- Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Symbolic m)
i
Symbolic m
j'' <- Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (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))
-> (Symbolic m -> m (Symbolic m)) -> Symbolic m -> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
(m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)])
-> (m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)])
-> Bool
-> m [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
forall a. a -> a -> Bool -> a
bool
m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall a. a -> a
id
((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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
<$>)
(Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HashMap Text (Symbolic m) -> Bool
forall k v. HashMap k v -> Bool
M.null HashMap Text (Symbolic m)
m)
([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 Text
_ Symbolic m -> m (Symbolic m)
_, TBuiltin Text
_ 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 -> Text -> m [NTypeF m (Symbolic m)]
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"impossible"
unify
:: forall e m
. MonadLint e m
=> NExprF ()
-> Symbolic m
-> Symbolic m
-> m (Symbolic m)
unify :: forall e (m :: * -> *).
MonadLint e m =>
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
readRef 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
readRef 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 ()
writeRef SValue m
x NSymbolicF (NTypeF m (Symbolic m))
y'
pure $ 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 ()
writeRef SValue m
y NSymbolicF (NTypeF m (Symbolic m))
x'
pure $ 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
m (Symbolic m) -> m (Symbolic m) -> Bool -> m (Symbolic m)
forall a. a -> a -> Bool -> a
bool
(do
SValue m -> NSymbolicF (NTypeF m (Symbolic m)) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeRef 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 ()
writeRef 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 :: * -> *).
MonadAtomicRef 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)
)
(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 "
)
([NTypeF m (Symbolic m)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NTypeF m (Symbolic m)]
m)
unify NExprF ()
_ Symbolic m
_ Symbolic m
_ = Text -> m (Symbolic m)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"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 :: 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 -> m (Symbolic m)
demand :: Symbolic m -> m (Symbolic m)
demand (ST SThunk m
v)= Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SThunk m -> m (Symbolic m)
forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force SThunk m
v
demand (SV SValue m
v)= Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SValue m -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
v)
instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)
=> MonadValueF (Symbolic m) m where
demandF :: (Symbolic m -> m r) -> Symbolic m -> m r
demandF :: forall r. (Symbolic m -> m r) -> Symbolic m -> m r
demandF Symbolic m -> m r
f (ST SThunk m
v)= (Symbolic m -> m r) -> Symbolic m -> m r
forall v (m :: * -> *) r. MonadValueF v m => (v -> m r) -> v -> m r
demandF Symbolic m -> m r
f (Symbolic m -> m r) -> m (Symbolic m) -> m r
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SThunk m -> m (Symbolic m)
forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force SThunk m
v
demandF Symbolic m -> m r
f (SV SValue m
v)= 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 = Text -> m (Symbolic m)
forall e (m :: * -> *) a. MonadLint e m => Text -> m a
symerr (Text -> m (Symbolic m)) -> Text -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ Text
"Undefined variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
attrMissing :: NonEmpty Text -> Maybe (Symbolic m) -> m (Symbolic m)
attrMissing NonEmpty Text
ks Maybe (Symbolic m)
ms =
forall v (m :: * -> *) s a.
(MonadEval v 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
$ Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
Text -> (Symbolic m -> Text) -> Maybe (Symbolic m) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Text
"Inheriting unknown attribute: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attr)
(\ Symbolic m
s -> Text
"Could not look up attribute " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Symbolic m -> Text
forall b a. (Show a, IsString b) => a -> b
show Symbolic m
s)
Maybe (Symbolic m)
ms
where
attr :: Text
attr = Text -> [Text] -> Text
Text.intercalate Text
"." (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Text
ks)
evalCurPos :: m (Symbolic m)
evalCurPos = do
Symbolic m
f <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef 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 :: * -> *).
MonadAtomicRef 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 :: * -> *).
MonadAtomicRef 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 :: * -> *).
MonadAtomicRef 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 (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Symbolic m)] -> HashMap Text (Symbolic m)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Text
"file", Symbolic m
f), (Text
"line", Symbolic m
l), (Text
"col", Symbolic m
c)]))]
evalConstant :: NAtom -> m (Symbolic m)
evalConstant NAtom
c = [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef 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 :: * -> *).
MonadAtomicRef 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 :: * -> *).
MonadAtomicRef 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 :: * -> *).
MonadAtomicRef 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 :: * -> *).
MonadAtomicRef 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
NSymbolicF (NTypeF m (Symbolic m))
s <- Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> m (Symbolic m) -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
(case NSymbolicF (NTypeF m (Symbolic m))
s of
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] -> Text -> m (HashMap Text (Symbolic m))
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"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"
)
m (Symbolic m)
body
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 :: * -> *).
MonadAtomicRef 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 :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
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 :: * -> *).
MonadAtomicRef 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 :: forall s a. Exception s => 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 :: forall e (m :: * -> *).
(MonadLint e m, MonadEval (Symbolic m) m) =>
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 :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible
case NBinaryOp
op of
NBinaryOp
NApp -> Text -> m (Symbolic m)
forall e (m :: * -> *) a. MonadLint e m => Text -> m a
symerr Text
"lintBinaryOp:NApp: should never get here"
NBinaryOp
_ -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym ([NTypeF m (Symbolic m)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$
case NBinaryOp
op of
NBinaryOp
NEq -> [[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 -> [[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 -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
NBinaryOp
NLte -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
NBinaryOp
NGt -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
NBinaryOp
NGte -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
NBinaryOp
NAnd -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
NBinaryOp
NOr -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
NBinaryOp
NImpl -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
NBinaryOp
NPlus -> [[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 -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
NBinaryOp
NMult -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
NBinaryOp
NDiv -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
NBinaryOp
NUpdate -> [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. Monoid a => a
mempty]
NBinaryOp
NConcat -> [Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y]
#if __GLASGOW_HASKELL__ < 900
_ -> fail "Should not be possible"
#endif
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 :: * -> *).
MonadAtomicRef 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 :: forall e (m :: * -> *).
MonadLint e m =>
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 :: * -> *).
(MonadAtomicRef 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 :: * -> *).
(MonadAtomicRef 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
Text -> m (HashMap Text (Symbolic m), Symbolic m)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"NYI"
NMany [TSet (Just HashMap Text (Symbolic m)
_)] -> do
Text -> m (HashMap Text (Symbolic m), Symbolic m)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"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 Text
_ 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 :: * -> *). MonadAtomicRef 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
{ forall s a.
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
( (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
<$ :: forall a b. a -> Lint s b -> Lint s a
$c<$ :: forall s a b. a -> Lint s b -> Lint s a
fmap :: forall a b. (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)
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)
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
<* :: forall a b. Lint s a -> Lint s b -> Lint s a
$c<* :: forall s a b. Lint s a -> Lint s b -> Lint s a
*> :: forall a b. Lint s a -> Lint s b -> Lint s b
$c*> :: forall s a b. Lint s a -> Lint s b -> Lint s b
liftA2 :: forall a b c. (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
<*> :: forall a b. 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 :: forall a. a -> Lint s a
$cpure :: forall s a. a -> Lint s a
Applicative
, Applicative (Lint s)
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)
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 :: forall a. a -> Lint s a
$creturn :: forall s a. a -> Lint s a
>> :: forall a b. Lint s a -> Lint s b -> Lint s b
$c>> :: forall s a b. Lint s a -> Lint s b -> Lint s b
>>= :: forall a 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
Monad
, Monad (Lint s)
Monad (Lint s)
-> (forall a. (a -> Lint s a) -> Lint s a) -> MonadFix (Lint s)
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 :: forall a. (a -> Lint s a) -> Lint s a
$cmfix :: forall s a. (a -> Lint s a) -> Lint s a
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))
MonadThunkId
, Monad (Lint 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 a. Ref (Lint s) a -> (a -> a) -> Lint s ())
-> MonadRef (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' :: forall a. Ref (Lint s) a -> (a -> a) -> Lint s ()
$cmodifyRef' :: forall s a. Ref (Lint s) a -> (a -> a) -> Lint s ()
modifyRef :: forall a. Ref (Lint s) a -> (a -> a) -> Lint s ()
$cmodifyRef :: forall s a. Ref (Lint s) a -> (a -> a) -> Lint s ()
writeRef :: forall a. Ref (Lint s) a -> a -> Lint s ()
$cwriteRef :: forall s a. Ref (Lint s) a -> a -> Lint s ()
readRef :: forall a. Ref (Lint s) a -> Lint s a
$creadRef :: forall s a. Ref (Lint s) a -> Lint s a
newRef :: forall a. a -> Lint s (Ref (Lint s) a)
$cnewRef :: forall s a. a -> Lint s (Ref (Lint s) a)
MonadRef
, MonadRef (Lint s)
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' :: forall a b. 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 :: forall a b. 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
MonadAtomicRef
)
instance MonadThrow (Lint s) where
throwM :: forall e a. Exception e => 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 :: forall e a. Exception e => 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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot catch in 'Lint s'"
runLintM :: Options -> Lint s a -> ST s a
runLintM :: forall s a. 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)
newRef (Int
1 :: Int)
Ref (ST s) Int -> FreshIdT Int (ST s) a -> ST s a
forall (m :: * -> *) i a.
Functor m =>
Ref 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
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 :: forall (m :: * -> *). Monad m => 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 a. Monoid a => a
mempty
lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
lint :: forall s. 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
$
do
Scopes (Lint s) (Symbolic (Lint s))
basis <- Lint s (Scopes (Lint s) (Symbolic (Lint s)))
forall (m :: * -> *). Monad m => m (Scopes m (Symbolic m))
symbolicBaseEnv
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
Scopes (Lint s) (Symbolic (Lint s))
basis
(Transform NExprLocF (Lint s (Symbolic (Lint s)))
-> Alg NExprLocF (Lint s (Symbolic (Lint s)))
-> NExprLoc
-> Lint s (Symbolic (Lint s))
forall (f :: * -> *) a.
Functor f =>
Transform f a -> Alg f a -> Fix f -> a
adi
Transform NExprLocF (Lint s (Symbolic (Lint s)))
forall e (m :: * -> *) a.
(MonadReader e m, Has e SrcSpan) =>
Transform NExprLocF (m a)
Eval.addSourcePositions
Alg NExprLocF (Lint s (Symbolic (Lint s)))
forall v (m :: * -> *) ann.
MonadNixEval v m =>
AnnF ann NExprF (m v) -> m v
Eval.evalContent
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 :: forall r. Lint s r -> Lint s r
clearScopes = forall (m :: * -> *) a e r.
(MonadReader e m, Has e (Scopes m a)) =>
m r -> m r
clearScopesReader @(Lint s) @(Symbolic (Lint s))
pushScopes :: forall r.
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