{-# language ConstraintKinds #-}
{-# language CPP #-}
{-# language DataKinds #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}

{-# options_ghc -fno-warn-name-shadowing #-}
{-# options_ghc -Wno-missing-methods #-}

module Nix.Lint where

import           Nix.Prelude
import           Relude.Unsafe                 as Unsafe ( head )
import           Control.Exception              ( throw )
import           GHC.Exception                  ( ErrorCall(ErrorCall) )
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
-- Plese, use NonEmpty
import           Data.List                      ( intersect )
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.Types
import           Nix.Expr.Types.Annotated
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
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
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
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 (AttrSet r))
  | TClosure (Params ())
  | TPath
  | TBuiltin Text (Symbolic m -> m r)
  deriving 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 (AttrSet r)
_)       (TSet  Maybe (AttrSet r)
_)      = Ordering
EQ
compareTypes (TSet Maybe (AttrSet r)
_)       NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              (TSet Maybe (AttrSet 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
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
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, NSymbolicF r -> NSymbolicF r -> Bool
NSymbolicF r -> NSymbolicF r -> Ordering
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 -> 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 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
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 = forall (m :: * -> *).
MonadAtomicRef m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic 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 = forall (m :: * -> *).
MonadAtomicRef m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r. [r] -> NSymbolicF r
NMany

mkSymbolic1
  :: MonadAtomicRef m
  => NTypeF m (Symbolic m)
  -> m (Symbolic m)
mkSymbolic1 :: forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 = forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. One x => OneItem x -> x
one

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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). SValue m -> Symbolic m
SV forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Symbolic m -> SValue m
getSV forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
  (\case
    NSymbolicF (NTypeF m (Symbolic m))
NAny     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<any>"
    NMany [NTypeF m (Symbolic m)]
xs ->
      Text -> [Text] -> Text
Text.intercalate Text
", " forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
          (\case
            TConstant [TAtom]
ys ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                Text -> [Text] -> Text
Text.intercalate Text
", "
                  (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                    (\case
                      TAtom
TInt   -> Text
"int"
                      TAtom
TFloat -> Text
"float"
                      TAtom
TBool  -> Text
"bool"
                      TAtom
TNull  -> Text
"null"
                    )
                    [TAtom]
ys
                  )
            NTypeF m (Symbolic m)
TStr    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"string"
            TList Symbolic m
r ->
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
brackets forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
r
            TSet Maybe (AttrSet (Symbolic m))
Nothing  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<any set>"
            TSet (Just AttrSet (Symbolic m)
s) ->
              Text -> Text
braces forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall v (m :: * -> *). MonadValue v m => v -> m v
demand) AttrSet (Symbolic m)
s
            f :: NTypeF m (Symbolic m)
f@(TClosure Params ()
p) ->
              do
                (AttrSet (Symbolic m)
args, Symbolic m
sym) <-
                  do
                    Symbolic m
f' <- forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 NTypeF m (Symbolic m)
f
                    forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp (forall r. Params r -> r -> NExprF r
NAbs Params ()
p forall a. Monoid a => a
mempty) Symbolic m
f' forall (m :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible
                HashMap VarName Text
args' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic AttrSet (Symbolic m)
args
                Text
sym'  <- forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic Symbolic m
sym
                pure $ Text -> Text
parens forall a b. (a -> b) -> a -> b
$ forall b a. (Show a, IsString b) => a -> b
show HashMap VarName Text
args' forall a. Semigroup a => a -> a -> a
<> Text
" -> " forall a. Semigroup a => a -> a -> a
<> Text
sym'
            NTypeF m (Symbolic m)
TPath          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"path"
            TBuiltin Text
_n Symbolic m -> m (Symbolic m)
_f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<builtin function>"
          )
          [NTypeF m (Symbolic m)]
xs
  ) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic
 where
  between :: a -> a -> a -> a
between a
a a
b a
c = a
a forall a. Semigroup a => a -> a -> a
<> a
b forall a. Semigroup a => a -> a -> a
<> a
c
  parens :: Text -> Text
parens   = forall {a}. Semigroup a => a -> a -> a -> a
between Text
"(" Text
")"
  brackets :: Text -> Text
brackets = forall {a}. Semigroup a => a -> a -> a -> a
between Text
"[" Text
"]"
  braces :: Text -> Text
braces   = forall {a}. Semigroup a => a -> a -> a -> a
between Text
"{" Text
"}"

-- This function is order and uniqueness preserving (of types).
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)]
_        = forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
  go [NTypeF m (Symbolic m)]
_        []       = forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
  go xxs :: [NTypeF m (Symbolic m)]
xxs@(NTypeF m (Symbolic m)
x : [NTypeF m (Symbolic m)]
xs) yys :: [NTypeF m (Symbolic m)]
yys@(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 ) -> (forall x. One x => OneItem x -> x
one forall (m :: * -> *) r. NTypeF m r
TStr forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [NTypeF m (Symbolic m)]
rest
    (NTypeF m (Symbolic m)
TPath, NTypeF m (Symbolic m)
TPath) -> (forall x. One x => OneItem x -> x
one forall (m :: * -> *) r. NTypeF m r
TPath forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [NTypeF m (Symbolic m)]
rest
    (TConstant [TAtom]
ls, TConstant [TAtom]
rs) ->
      (forall x. One x => OneItem x -> x
one (forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom]
ls forall a. Eq a => [a] -> [a] -> [a]
`intersect` [TAtom]
rs)) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [NTypeF m (Symbolic m)]
rest
    (TList Symbolic m
l, TList Symbolic m
r) ->
      do
        Symbolic m
l' <- forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
l
        Symbolic m
r' <- forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
r
        Symbolic m
m <- forall v (m :: * -> *). MonadValue v m => m v -> m v
defer forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a.
MonadLint e m =>
NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context Symbolic m
l' Symbolic m
r'
        (forall x. One x => OneItem x -> x
one (forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
m) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [NTypeF m (Symbolic m)]
rest
    (TSet Maybe (AttrSet (Symbolic m))
x       , TSet Maybe (AttrSet (Symbolic m))
Nothing ) -> (forall x. One x => OneItem x -> x
one (forall (m :: * -> *) r. Maybe (AttrSet r) -> NTypeF m r
TSet Maybe (AttrSet (Symbolic m))
x) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [NTypeF m (Symbolic m)]
rest
    (TSet Maybe (AttrSet (Symbolic m))
Nothing , TSet Maybe (AttrSet (Symbolic m))
x       ) -> (forall x. One x => OneItem x -> x
one (forall (m :: * -> *) r. Maybe (AttrSet r) -> NTypeF m r
TSet Maybe (AttrSet (Symbolic m))
x) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [NTypeF m (Symbolic m)]
rest
    (TSet (Just AttrSet (Symbolic m)
l), TSet (Just AttrSet (Symbolic m)
r)) -> do
      AttrSet (Symbolic m)
hm <-
        forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall a b. (a -> b) -> a -> b
$
          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'' <- m (Symbolic m)
i
                Symbolic m
j'' <- m (Symbolic m)
j
                forall v (m :: * -> *). MonadValue v m => m v -> m v
defer forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a.
MonadLint e m =>
NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context Symbolic m
i'' Symbolic m
j''
            )
            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall v (m :: * -> *). MonadValue v m => v -> m v
demand AttrSet (Symbolic m)
l)
            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall v (m :: * -> *). MonadValue v m => v -> m v
demand AttrSet (Symbolic m)
r)
      forall (t :: * -> *) b a. Foldable t => b -> (t a -> b) -> t a -> b
handlePresence
        forall a. a -> a
id
        (forall a b. a -> b -> a
const ((forall x. One x => OneItem x -> x
one (forall (m :: * -> *) r. Maybe (AttrSet r) -> NTypeF m r
TSet forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure AttrSet (Symbolic m)
hm) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>))
        AttrSet (Symbolic m)
hm
        m [NTypeF m (Symbolic m)]
rest

    (TClosure{}, TClosure{}) ->
      forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError 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)
_) ->
      forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Cannot unify builtin functions"
    (NTypeF m (Symbolic m), NTypeF m (Symbolic m))
_ | forall (m :: * -> *) r. NTypeF m r -> NTypeF m r -> Ordering
compareTypes NTypeF m (Symbolic m)
x NTypeF m (Symbolic m)
y 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)]
yys
      | forall (m :: * -> *) r. NTypeF m r -> NTypeF m r -> Ordering
compareTypes NTypeF m (Symbolic m)
x NTypeF m (Symbolic m)
y 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)]
xxs [NTypeF m (Symbolic m)]
ys
      | Bool
otherwise              -> forall a t. (HasCallStack, IsText t) => t -> a
error Text
"impossible"
   where
    rest :: m [NTypeF m (Symbolic m)]
    rest :: m [NTypeF m (Symbolic m)]
rest = [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys

{-
    mergeFunctions pl nl fl pr fr xs ys = do
        m <- sequenceA $ M.intersectionWith
            (\i j -> i >>= \i' -> j >>= \j' -> case (i', j') of
                    (Nothing, Nothing) -> stub
                    (_, Nothing) -> stub
                    (Nothing, _) -> stub
                    (Just i'', Just j'') ->
                        pure . pure <$> unify context i'' j'')
            (pure <$> pl) (pure <$> pr)
        let Just m' = sequenceA $ M.filter isJust m
        if M.null m'
            then go xs ys
            else do
                g <- unify context fl fr
                (TClosure (ParamSet m' False nl) g :)
                    <$> go xs ys
-}

-- | Result @== NMany []@ -> @unify@ fails.
unify
  :: forall e m a
   . MonadLint e m
  => NExprF a
  -> Symbolic m
  -> Symbolic m
  -> m (Symbolic m)
unify :: forall e (m :: * -> *) a.
MonadLint e m =>
NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (forall (f :: * -> *) a. Functor f => f a -> f ()
void -> NExprF ()
context) (SV SValue m
x) (SV SValue m
y) = do
  NSymbolicF (NTypeF m (Symbolic m))
x' <- forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef SValue m
x
  NSymbolicF (NTypeF m (Symbolic m))
y' <- 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
        forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeRef SValue m
x NSymbolicF (NTypeF m (Symbolic m))
y'
        pure $ forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
y
    (NSymbolicF (NTypeF m (Symbolic m))
_, NSymbolicF (NTypeF m (Symbolic m))
NAny) ->
      do
        forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeRef SValue m
y NSymbolicF (NTypeF m (Symbolic m))
x'
        pure $ forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
x
    (NMany [NTypeF m (Symbolic m)]
xs, NMany [NTypeF m (Symbolic m)]
ys) ->
      forall (t :: * -> *) b a. Foldable t => b -> (t a -> b) -> t a -> b
handlePresence
        (
          -- x' <- renderSymbolic (Symbolic x)
          -- y' <- renderSymbolic (Symbolic y)
          forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Cannot unify "
                  -- <> show x' <> " with " <> show y'
                  --  <> " in context: " <> show context
        )
        (\ [NTypeF m (Symbolic m)]
m ->
          do
            let
              nm :: NSymbolicF (NTypeF m (Symbolic m))
nm = forall r. [r] -> NSymbolicF r
NMany [NTypeF m (Symbolic m)]
m
            forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeRef SValue m
x   NSymbolicF (NTypeF m (Symbolic m))
nm
            forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeRef SValue m
y   NSymbolicF (NTypeF m (Symbolic m))
nm
            forall (m :: * -> *).
MonadAtomicRef m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic NSymbolicF (NTypeF m (Symbolic m))
nm
        )
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
unify NExprF a
_ Symbolic m
_ Symbolic m
_ = forall a t. (HasCallStack, IsText t) => t -> a
error Text
"The unexpected hath transpired!"

-- These aren't worth defining yet, because once we move to Hindley-Milner,
-- we're not going to be managing Symbolic values this way anymore.

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), PositionSet) m (Symbolic m) where

instance ToValue (AttrSet (Symbolic m), PositionSet) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). SThunk m -> Symbolic m
ST forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall v (m :: * -> *). MonadValue v m => v -> m v
demand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force SThunk m
v
  demand (SV SValue m
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (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) = forall v (m :: * -> *) r. MonadValueF v m => (v -> m r) -> v -> m r
demandF Symbolic m -> m r
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 (forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
v)


instance MonadLint e m => MonadEval (Symbolic m) m where
  freeVariable :: VarName -> m (Symbolic m)
freeVariable VarName
var = forall e (m :: * -> *) a. MonadLint e m => Text -> m a
symerr forall a b. (a -> b) -> a -> b
$ Text
"Undefined variable '" forall a. Semigroup a => a -> a -> a
<> coerce :: forall a b. Coercible a b => a -> b
coerce VarName
var forall a. Semigroup a => a -> a -> a
<> Text
"'"

  attrMissing :: NonEmpty VarName -> Maybe (Symbolic m) -> m (Symbolic m)
attrMissing NonEmpty VarName
ks Maybe (Symbolic m)
ms =
    forall v (m :: * -> *) s a.
(MonadEval v m, Exception s) =>
s -> m a
evalError @(Symbolic m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString forall a b. (a -> b) -> a -> b
$
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (Text
"Inheriting unknown attribute: " forall a. Semigroup a => a -> a -> a
<> Text
attr)
        (\ Symbolic m
s ->  Text
"Could not look up attribute " forall a. Semigroup a => a -> a -> a
<> Text
attr forall a. Semigroup a => a -> a -> a
<> Text
" in " forall a. Semigroup a => a -> a -> a
<> 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
"." forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce NonEmpty VarName
ks

  evalCurPos :: m (Symbolic m)
evalCurPos =
    do
      Symbolic m
f <- forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 forall (m :: * -> *) r. NTypeF m r
TPath
      Symbolic m
l <- forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TInt
      Symbolic m
c <- forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TInt
      forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. Maybe (AttrSet r) -> NTypeF m r
TSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(VarName
"file", Symbolic m
f), (VarName
"line", Symbolic m
l), (VarName
"col", Symbolic m
c)]

  evalConstant :: NAtom -> m (Symbolic m)
evalConstant NAtom
c = forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {r}. NAtom -> NTypeF m r
fun NAtom
c
   where
    fun :: NAtom -> NTypeF m r
fun =
      \case
        NURI   Text
_ -> forall (m :: * -> *) r. NTypeF m r
TStr
        NInt   Integer
_ -> forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TInt
        NFloat Float
_ -> forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TFloat
        NBool  Bool
_ -> forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TBool
        NAtom
NNull    -> forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TNull

  evalString :: NString (m (Symbolic m)) -> m (Symbolic m)
evalString      = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 forall (m :: * -> *) r. NTypeF m r
TStr
  evalLiteralPath :: Path -> m (Symbolic m)
evalLiteralPath = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 forall (m :: * -> *) r. NTypeF m r
TPath
  evalEnvPath :: Path -> m (Symbolic m)
evalEnvPath     = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 forall (m :: * -> *) r. NTypeF m r
TPath

  evalUnary :: NUnaryOp -> Symbolic m -> m (Symbolic m)
evalUnary NUnaryOp
op Symbolic m
arg =
    forall e (m :: * -> *) a.
MonadLint e m =>
NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (forall r. NUnaryOp -> r -> NExprF r
NUnary NUnaryOp
op Symbolic m
arg) Symbolic m
arg forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 (forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool])

  evalBinary :: NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
evalBinary = forall e (m :: * -> *).
(MonadLint e m, MonadEval (Symbolic m) m) =>
NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
lintBinaryOp

  -- The scope is deliberately wrapped in a thunk here, since it is evaluated
  -- each time a name is looked up within the weak scope, and we want to be
  -- sure the action it evaluates is to force a thunk, so its value is only
  -- computed once.
  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 <- forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall v (m :: * -> *). MonadValue v m => v -> m v
demand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall v (m :: * -> *). MonadValue v m => m v -> m v
defer m (Symbolic m)
scope

      forall (m :: * -> *) a r.
(Functor m, Scoped a m) =>
m (Scope a) -> m r -> m r
pushWeakScope
        (case NSymbolicF (NTypeF m (Symbolic m))
s of
          NMany [TSet (Just (coerce :: forall a b. Coercible a b => a -> b
coerce -> Scope (Symbolic m)
scope))] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Scope (Symbolic m)
scope
          NMany [TSet Maybe (AttrSet (Symbolic m))
Nothing] -> forall a t. (HasCallStack, IsText t) => t -> a
error Text
"NYI: with unknown"
          NSymbolicF (NTypeF m (Symbolic m))
_ -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError 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 :: Symbolic m -> Symbolic m -> m (Symbolic m)
e = forall e (m :: * -> *) a.
MonadLint e m =>
NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (forall r. r -> r -> r -> NExprF r
NIf Symbolic m
cond Symbolic m
t' Symbolic m
f')
      Symbolic m -> Symbolic m -> m (Symbolic m)
e Symbolic m
t' Symbolic m
f' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Symbolic m -> Symbolic m -> m (Symbolic m)
e Symbolic m
cond forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 (forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TBool))

  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
      Symbolic m
body' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall e (m :: * -> *) a.
MonadLint e m =>
NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (forall r. r -> r -> NExprF r
NAssert Symbolic m
cond Symbolic m
body') Symbolic m
cond forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 (forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TBool))

  evalApp :: Symbolic m -> m (Symbolic m) -> m (Symbolic m)
evalApp = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall r. r -> r -> NExprF r
NApp forall a. Monoid a => a
mempty)
  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)
_ = forall (m :: * -> *).
MonadAtomicRef m =>
NTypeF m (Symbolic m) -> m (Symbolic m)
mkSymbolic1 (forall (m :: * -> *) r. Params () -> NTypeF m r
TClosure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void Params (m (Symbolic m))
params)

  evalError :: forall s a. Exception s => s -> m a
evalError = 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    <- forall v (m :: * -> *). MonadValue v m => m v -> m v
defer forall (m :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible

    Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym forall a b. (a -> b) -> a -> b
$
      case NBinaryOp
op of
        NBinaryOp
NEq     -> [forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull], forall (m :: * -> *) r. NTypeF m r
TStr, forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y]
        NBinaryOp
NNEq    -> [forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull], forall (m :: * -> *) r. NTypeF m r
TStr, forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y]

        NBinaryOp
NLt     -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]
        NBinaryOp
NLte    -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]
        NBinaryOp
NGt     -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]
        NBinaryOp
NGte    -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]

        NBinaryOp
NAnd    -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TBool
        NBinaryOp
NOr     -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TBool
        NBinaryOp
NImpl   -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TBool

        -- jww (2018-04-01): NYI: Allow Path + Str
        NBinaryOp
NPlus   -> [forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TInt, forall (m :: * -> *) r. NTypeF m r
TStr, forall (m :: * -> *) r. NTypeF m r
TPath]
        NBinaryOp
NMinus  -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TInt
        NBinaryOp
NMult   -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TInt
        NBinaryOp
NDiv    -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant forall a b. (a -> b) -> a -> b
$ forall x. One x => OneItem x -> x
one TAtom
TInt

        NBinaryOp
NUpdate -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. Maybe (AttrSet r) -> NTypeF m r
TSet forall a. Monoid a => a
mempty

        NBinaryOp
NConcat -> forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y
#if __GLASGOW_HASKELL__ < 810
        _ -> fail "Should not be possible"  -- symerr or this fun signature should be changed to work in type scope
#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
        contextUnify :: Symbolic m -> Symbolic m -> m (Symbolic m)
contextUnify = forall e (m :: * -> *) a.
MonadLint e m =>
NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify forall a b. (a -> b) -> a -> b
$ forall r. NBinaryOp -> r -> r -> NExprF r
NBinary NBinaryOp
op Symbolic m
lsym Symbolic m
rsym

      Symbolic m
m <- forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)]
xs
      Symbolic m
_ <- Symbolic m -> Symbolic m -> m (Symbolic m)
contextUnify Symbolic m
lsym Symbolic m
m
      Symbolic m
_ <- Symbolic m -> Symbolic m -> m (Symbolic m)
contextUnify Symbolic m
rsym Symbolic m
m
      Symbolic m -> Symbolic m -> m (Symbolic m)
contextUnify 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 VarName (Symbolic m), Symbolic m)
lintApp NExprF ()
context Symbolic m
fun m (Symbolic m)
arg =
  (\case
    NSymbolicF (NTypeF m (Symbolic m))
NAny ->
      forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError 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 VarName (Symbolic m)]
args, [Symbolic m]
ys) <-
          forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
              (\case
                TClosure Params ()
_params ->
                  (\case
                    NSymbolicF (NTypeF m (Symbolic m))
NAny                  -> forall a t. (HasCallStack, IsText t) => t -> a
error Text
"NYI"
                    NMany [TSet (Just HashMap VarName (Symbolic m)
_)] -> forall a t. (HasCallStack, IsText t) => t -> a
error Text
"NYI"
                    NMany [NTypeF m (Symbolic m)]
_               -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp NMany not set"
                  ) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Symbolic m)
arg
                TBuiltin Text
_ Symbolic m -> m (Symbolic m)
_f -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp builtin"
                TSet Maybe (HashMap VarName (Symbolic m))
_m       -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp Set"
                NTypeF m (Symbolic m)
_x            -> forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Attempt to call non-function"
              )
              [NTypeF m (Symbolic m)]
xs

        Symbolic m
y <- forall (m :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible
        (forall a. [a] -> a
Unsafe.head [HashMap VarName (Symbolic m)]
args, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall e (m :: * -> *) a.
MonadLint e m =>
NExprF a -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context) Symbolic m
y [Symbolic m]
ys
  ) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic Symbolic m
fun

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 -> 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
    , 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
    , 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
    , 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)))
    , Lint s (ThunkId (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
    , 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
    , 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 :: forall e a. Exception e => e -> Lint s a
throwM e
e = forall s a.
ReaderT
  (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
Lint forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (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 = forall s a.
ReaderT
  (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
Lint forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall a t. (HasCallStack, IsText t) => t -> a
error Text
"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 =
  forall (m :: * -> *) i a.
Functor m =>
FreshIdT i m a -> Ref m i -> m a
runFreshIdT ((forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` forall (m :: * -> *) t. Options -> Context m t
newContext Options
opts) forall a b. (a -> b) -> a -> b
$ forall s a.
Lint s a
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
runLint Lint s a
action) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
newRef (Int
1 :: Int)

symbolicBaseEnv
  :: Monad m
  => m (Scopes m (Symbolic m))
symbolicBaseEnv :: forall (m :: * -> *). Monad m => m (Scopes m (Symbolic m))
symbolicBaseEnv = forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub

lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
lint :: forall s. Options -> NExprLoc -> ST s (Symbolic (Lint s))
lint Options
opts NExprLoc
expr =
  forall s a. Options -> Lint s a -> ST s a
runLintM Options
opts forall a b. (a -> b) -> a -> b
$
    do
      Scopes (Lint s) (Symbolic (Lint s))
basis <- forall (m :: * -> *). Monad m => m (Scopes m (Symbolic m))
symbolicBaseEnv

      forall a (m :: * -> *) r. Scoped a m => Scopes m a -> m r -> m r
pushScopes
        Scopes (Lint s) (Symbolic (Lint s))
basis
        (forall (f :: * -> *) a.
Functor f =>
Transform f a -> Alg f a -> Fix f -> a
adi
          forall e (m :: * -> *) a.
(MonadReader e m, Has e SrcSpan) =>
Transform NExprLocF (m a)
Eval.addSourcePositions
          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
  askScopes :: Lint s (Scopes (Lint s) (Symbolic (Lint s)))
askScopes = forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
m (Scopes m a)
askScopesReader
  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    = forall e (m :: * -> *) a r.
(MonadReader e m, Has e (Scopes m a)) =>
Scopes m a -> m r -> m r
pushScopesReader
  lookupVar :: VarName -> Lint s (Maybe (Symbolic (Lint s)))
lookupVar     = forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
VarName -> m (Maybe a)
lookupVarReader