{-# language ConstraintKinds #-}
{-# language CPP #-}
{-# language DataKinds #-}
{-# language GADTs #-}
{-# 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
(Int -> TAtom -> ShowS)
-> (TAtom -> String) -> ([TAtom] -> ShowS) -> Show TAtom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TAtom] -> ShowS
$cshowList :: [TAtom] -> ShowS
show :: TAtom -> String
$cshow :: TAtom -> String
showsPrec :: Int -> TAtom -> ShowS
$cshowsPrec :: Int -> TAtom -> ShowS
Show, TAtom -> TAtom -> Bool
(TAtom -> TAtom -> Bool) -> (TAtom -> TAtom -> Bool) -> Eq TAtom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TAtom -> TAtom -> Bool
$c/= :: TAtom -> TAtom -> Bool
== :: TAtom -> TAtom -> Bool
$c== :: TAtom -> TAtom -> Bool
Eq, Eq TAtom
Eq TAtom
-> (TAtom -> TAtom -> Ordering)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> TAtom)
-> (TAtom -> TAtom -> TAtom)
-> Ord TAtom
TAtom -> TAtom -> Bool
TAtom -> TAtom -> Ordering
TAtom -> TAtom -> TAtom
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TAtom -> TAtom -> TAtom
$cmin :: TAtom -> TAtom -> TAtom
max :: TAtom -> TAtom -> TAtom
$cmax :: TAtom -> TAtom -> TAtom
>= :: TAtom -> TAtom -> Bool
$c>= :: TAtom -> TAtom -> Bool
> :: TAtom -> TAtom -> Bool
$c> :: TAtom -> TAtom -> Bool
<= :: TAtom -> TAtom -> Bool
$c<= :: TAtom -> TAtom -> Bool
< :: TAtom -> TAtom -> Bool
$c< :: TAtom -> TAtom -> Bool
compare :: TAtom -> TAtom -> Ordering
$ccompare :: TAtom -> TAtom -> Ordering
$cp1Ord :: Eq TAtom
Ord)

data NTypeF (m :: Type -> Type) r
  = TConstant [TAtom]
  | TStr
  | TList r
  | TSet (Maybe (AttrSet r))
  | TClosure (Params ())
  | TPath
  | TBuiltin Text (Symbolic m -> m r)
  deriving a -> NTypeF m b -> NTypeF m a
(a -> b) -> NTypeF m a -> NTypeF m b
(forall a b. (a -> b) -> NTypeF m a -> NTypeF m b)
-> (forall a b. a -> NTypeF m b -> NTypeF m a)
-> Functor (NTypeF m)
forall a b. a -> NTypeF m b -> NTypeF m a
forall a b. (a -> b) -> NTypeF m a -> NTypeF m b
forall (m :: * -> *) a b.
Functor m =>
a -> NTypeF m b -> NTypeF m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NTypeF m a -> NTypeF m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> NTypeF m b -> NTypeF m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> NTypeF m b -> NTypeF m a
fmap :: (a -> b) -> NTypeF m a -> NTypeF m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> NTypeF m a -> NTypeF m b
Functor

compareTypes :: NTypeF m r -> NTypeF m r -> Ordering
compareTypes :: NTypeF m r -> NTypeF m r -> Ordering
compareTypes (TConstant [TAtom]
_)  (TConstant [TAtom]
_)  = Ordering
EQ
compareTypes (TConstant [TAtom]
_)  NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              (TConstant [TAtom]
_)  = Ordering
GT
compareTypes NTypeF m r
TStr           NTypeF m r
TStr           = Ordering
EQ
compareTypes NTypeF m r
TStr           NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              NTypeF m r
TStr           = Ordering
GT
compareTypes (TList r
_)      (TList r
_)      = Ordering
EQ
compareTypes (TList r
_)      NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              (TList r
_)      = Ordering
GT
compareTypes (TSet Maybe (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
[NSymbolicF r] -> ShowS
NSymbolicF r -> String
(Int -> NSymbolicF r -> ShowS)
-> (NSymbolicF r -> String)
-> ([NSymbolicF r] -> ShowS)
-> Show (NSymbolicF r)
forall r. Show r => Int -> NSymbolicF r -> ShowS
forall r. Show r => [NSymbolicF r] -> ShowS
forall r. Show r => NSymbolicF r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NSymbolicF r] -> ShowS
$cshowList :: forall r. Show r => [NSymbolicF r] -> ShowS
show :: NSymbolicF r -> String
$cshow :: forall r. Show r => NSymbolicF r -> String
showsPrec :: Int -> NSymbolicF r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> NSymbolicF r -> ShowS
Show, NSymbolicF r -> NSymbolicF r -> Bool
(NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool) -> Eq (NSymbolicF r)
forall r. Eq r => NSymbolicF r -> NSymbolicF r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NSymbolicF r -> NSymbolicF r -> Bool
$c/= :: forall r. Eq r => NSymbolicF r -> NSymbolicF r -> Bool
== :: NSymbolicF r -> NSymbolicF r -> Bool
$c== :: forall r. Eq r => NSymbolicF r -> NSymbolicF r -> Bool
Eq, Eq (NSymbolicF r)
Eq (NSymbolicF r)
-> (NSymbolicF r -> NSymbolicF r -> Ordering)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> NSymbolicF r)
-> (NSymbolicF r -> NSymbolicF r -> NSymbolicF r)
-> Ord (NSymbolicF r)
NSymbolicF r -> NSymbolicF r -> Bool
NSymbolicF r -> NSymbolicF r -> Ordering
NSymbolicF r -> NSymbolicF r -> NSymbolicF r
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall r. Ord r => Eq (NSymbolicF r)
forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Ordering
forall r. Ord r => NSymbolicF r -> NSymbolicF r -> NSymbolicF r
min :: NSymbolicF r -> NSymbolicF r -> NSymbolicF r
$cmin :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> NSymbolicF r
max :: NSymbolicF r -> NSymbolicF r -> NSymbolicF r
$cmax :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> NSymbolicF r
>= :: NSymbolicF r -> NSymbolicF r -> Bool
$c>= :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
> :: NSymbolicF r -> NSymbolicF r -> Bool
$c> :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
<= :: NSymbolicF r -> NSymbolicF r -> Bool
$c<= :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
< :: NSymbolicF r -> NSymbolicF r -> Bool
$c< :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
compare :: NSymbolicF r -> NSymbolicF r -> Ordering
$ccompare :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Ordering
$cp1Ord :: forall r. Ord r => Eq (NSymbolicF r)
Ord, a -> NSymbolicF b -> NSymbolicF a
(a -> b) -> NSymbolicF a -> NSymbolicF b
(forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b)
-> (forall a b. a -> NSymbolicF b -> NSymbolicF a)
-> Functor NSymbolicF
forall a b. a -> NSymbolicF b -> NSymbolicF a
forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> NSymbolicF b -> NSymbolicF a
$c<$ :: forall a b. a -> NSymbolicF b -> NSymbolicF a
fmap :: (a -> b) -> NSymbolicF a -> NSymbolicF b
$cfmap :: forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b
Functor, NSymbolicF a -> Bool
(a -> m) -> NSymbolicF a -> m
(a -> b -> b) -> b -> NSymbolicF a -> b
(forall m. Monoid m => NSymbolicF m -> m)
-> (forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m)
-> (forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m)
-> (forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b)
-> (forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b)
-> (forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b)
-> (forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b)
-> (forall a. (a -> a -> a) -> NSymbolicF a -> a)
-> (forall a. (a -> a -> a) -> NSymbolicF a -> a)
-> (forall a. NSymbolicF a -> [a])
-> (forall a. NSymbolicF a -> Bool)
-> (forall a. NSymbolicF a -> Int)
-> (forall a. Eq a => a -> NSymbolicF a -> Bool)
-> (forall a. Ord a => NSymbolicF a -> a)
-> (forall a. Ord a => NSymbolicF a -> a)
-> (forall a. Num a => NSymbolicF a -> a)
-> (forall a. Num a => NSymbolicF a -> a)
-> Foldable NSymbolicF
forall a. Eq a => a -> NSymbolicF a -> Bool
forall a. Num a => NSymbolicF a -> a
forall a. Ord a => NSymbolicF a -> a
forall m. Monoid m => NSymbolicF m -> m
forall a. NSymbolicF a -> Bool
forall a. NSymbolicF a -> Int
forall a. NSymbolicF a -> [a]
forall a. (a -> a -> a) -> NSymbolicF a -> a
forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: NSymbolicF a -> a
$cproduct :: forall a. Num a => NSymbolicF a -> a
sum :: NSymbolicF a -> a
$csum :: forall a. Num a => NSymbolicF a -> a
minimum :: NSymbolicF a -> a
$cminimum :: forall a. Ord a => NSymbolicF a -> a
maximum :: NSymbolicF a -> a
$cmaximum :: forall a. Ord a => NSymbolicF a -> a
elem :: a -> NSymbolicF a -> Bool
$celem :: forall a. Eq a => a -> NSymbolicF a -> Bool
length :: NSymbolicF a -> Int
$clength :: forall a. NSymbolicF a -> Int
null :: NSymbolicF a -> Bool
$cnull :: forall a. NSymbolicF a -> Bool
toList :: NSymbolicF a -> [a]
$ctoList :: forall a. NSymbolicF a -> [a]
foldl1 :: (a -> a -> a) -> NSymbolicF a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
foldr1 :: (a -> a -> a) -> NSymbolicF a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
foldl' :: (b -> a -> b) -> b -> NSymbolicF a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
foldl :: (b -> a -> b) -> b -> NSymbolicF a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
foldr' :: (a -> b -> b) -> b -> NSymbolicF a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
foldr :: (a -> b -> b) -> b -> NSymbolicF a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
foldMap' :: (a -> m) -> NSymbolicF a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
foldMap :: (a -> m) -> NSymbolicF a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
fold :: NSymbolicF m -> m
$cfold :: forall m. Monoid m => NSymbolicF m -> m
Foldable, Functor NSymbolicF
Foldable NSymbolicF
Functor NSymbolicF
-> Foldable NSymbolicF
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> NSymbolicF a -> f (NSymbolicF b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    NSymbolicF (f a) -> f (NSymbolicF a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> NSymbolicF a -> m (NSymbolicF b))
-> (forall (m :: * -> *) a.
    Monad m =>
    NSymbolicF (m a) -> m (NSymbolicF a))
-> Traversable NSymbolicF
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a)
forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
sequence :: NSymbolicF (m a) -> m (NSymbolicF a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a)
mapM :: (a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
sequenceA :: NSymbolicF (f a) -> f (NSymbolicF a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a)
traverse :: (a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
$cp2Traversable :: Foldable NSymbolicF
$cp1Traversable :: Functor NSymbolicF
Traversable)

type SThunk (m :: Type -> Type) = NThunkF m (Symbolic m)

type SValue (m :: Type -> Type) = Ref m (NSymbolicF (NTypeF m (Symbolic m)))

data Symbolic m = SV { Symbolic m -> SValue m
getSV :: SValue m } | ST { Symbolic m -> SThunk m
getST :: SThunk m }

instance Show (Symbolic m) where
  show :: Symbolic m -> String
show Symbolic m
_ = String
"<symbolic>"

everyPossible
  :: MonadAtomicRef m
  => m (Symbolic m)
everyPossible :: 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 :: [NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic = 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)) -> m (Symbolic m))
-> ([NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m)))
-> [NTypeF m (Symbolic m)]
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m))
forall r. [r] -> NSymbolicF r
NMany

packSymbolic
  :: MonadAtomicRef m
  => NSymbolicF (NTypeF m (Symbolic m))
  -> m (Symbolic m)
packSymbolic :: NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic = (Ref m (NSymbolicF (NTypeF m (Symbolic m))) -> Symbolic m)
-> m (Ref m (NSymbolicF (NTypeF m (Symbolic m)))) -> m (Symbolic m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ref m (NSymbolicF (NTypeF m (Symbolic m))) -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV (m (Ref m (NSymbolicF (NTypeF m (Symbolic m)))) -> m (Symbolic m))
-> (NSymbolicF (NTypeF m (Symbolic m))
    -> m (Ref m (NSymbolicF (NTypeF m (Symbolic m)))))
-> NSymbolicF (NTypeF m (Symbolic m))
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NSymbolicF (NTypeF m (Symbolic m))
-> m (Ref m (NSymbolicF (NTypeF m (Symbolic m))))
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
newRef

unpackSymbolic
  :: (MonadAtomicRef m, MonadThunkId m, MonadCatch m)
  => Symbolic m
  -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic :: 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 :: Text -> m a
symerr = forall v (m :: * -> *) s a.
(MonadEval v m, Exception s) =>
s -> m a
forall (m :: * -> *) s a.
(MonadEval (Symbolic m) m, Exception s) =>
s -> m a
evalError @(Symbolic m) (ErrorCall -> m a) -> (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 :: Symbolic m -> m Text
renderSymbolic =
  (\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] -> Text
Text.intercalate Text
", " ([Text] -> Text) -> m [Text] -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (NTypeF m (Symbolic m) -> m Text)
-> [NTypeF m (Symbolic m)] -> m [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
          (\case
            TConstant [TAtom]
ys ->
              Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$
                Text -> [Text] -> Text
Text.intercalate Text
", "
                  ((TAtom -> Text) -> [TAtom] -> [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    -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"string"
            TList Symbolic m
r ->
              (Text -> Text) -> m Text -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
brackets (m Text -> m Text) -> m Text -> m Text
forall a b. (a -> b) -> a -> b
$ 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
            TSet Maybe (AttrSet (Symbolic m))
Nothing  -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<any set>"
            TSet (Just AttrSet (Symbolic m)
s) ->
              Text -> Text
braces (Text -> Text)
-> (HashMap VarName Text -> Text) -> HashMap VarName Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap VarName Text -> Text
forall b a. (Show a, IsString b) => a -> b
show (HashMap VarName Text -> Text)
-> m (HashMap VarName Text) -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Symbolic m -> m Text)
-> AttrSet (Symbolic m) -> m (HashMap VarName 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) 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' <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic ([NTypeF m (Symbolic m)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one OneItem [NTypeF m (Symbolic m)]
NTypeF m (Symbolic m)
f
                    NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (AttrSet (Symbolic m), Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp (Params () -> () -> NExprF ()
forall r. Params r -> r -> NExprF r
NAbs Params ()
p ()
forall a. Monoid a => a
mempty) Symbolic m
f' m (Symbolic m)
forall (m :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible
                HashMap VarName Text
args' <- (Symbolic m -> m Text)
-> AttrSet (Symbolic m) -> m (HashMap VarName 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 AttrSet (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
parens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ HashMap VarName Text -> Text
forall b a. (Show a, IsString b) => a -> b
show HashMap VarName 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'
            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>"
          )
          [NTypeF m (Symbolic m)]
xs
  ) (NSymbolicF (NTypeF m (Symbolic m)) -> m Text)
-> (Symbolic m -> m (NSymbolicF (NTypeF 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 (NSymbolicF (NTypeF m (Symbolic m)))
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 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c
  parens :: Text -> Text
parens = Text -> Text -> Text -> Text
forall a. Semigroup a => a -> a -> a -> a
between Text
"(" Text
")"
  brackets :: Text -> Text
brackets = Text -> Text -> Text -> Text
forall a. Semigroup a => a -> a -> a -> a
between Text
"[" Text
"]"
  braces :: Text -> Text
braces = Text -> Text -> Text -> Text
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 :: 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 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 ) -> (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one OneItem [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. Semigroup 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
<$> m [NTypeF m (Symbolic m)]
rest
    (NTypeF m (Symbolic m)
TPath, NTypeF m (Symbolic m)
TPath) -> (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one OneItem [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. Semigroup 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
<$> m [NTypeF m (Symbolic m)]
rest
    (TConstant [TAtom]
ls, TConstant [TAtom]
rs) ->
      (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one ([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. Semigroup 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
<$> m [NTypeF m (Symbolic m)]
rest
    (TList Symbolic m
l, TList Symbolic m
r) ->
      do
        Symbolic m
l' <- Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
l
        Symbolic m
r' <- Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
r
        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'
        (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (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. Semigroup 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
<$> m [NTypeF m (Symbolic m)]
rest
    (TSet Maybe (AttrSet (Symbolic m))
x       , TSet Maybe (AttrSet (Symbolic m))
Nothing ) -> (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (Maybe (AttrSet (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (AttrSet r) -> NTypeF m r
TSet Maybe (AttrSet (Symbolic m))
x) [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. Semigroup 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
<$> m [NTypeF m (Symbolic m)]
rest
    (TSet Maybe (AttrSet (Symbolic m))
Nothing , TSet Maybe (AttrSet (Symbolic m))
x       ) -> (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (Maybe (AttrSet (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (AttrSet r) -> NTypeF m r
TSet Maybe (AttrSet (Symbolic m))
x) [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. Semigroup 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
<$> m [NTypeF m (Symbolic m)]
rest
    (TSet (Just AttrSet (Symbolic m)
l), TSet (Just AttrSet (Symbolic m)
r)) -> do
      AttrSet (Symbolic m)
m <- HashMap VarName (m (Symbolic m)) -> m (AttrSet (Symbolic m))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (HashMap VarName (m (Symbolic m)) -> m (AttrSet (Symbolic m)))
-> HashMap VarName (m (Symbolic m)) -> m (AttrSet (Symbolic m))
forall a b. (a -> b) -> a -> b
$ (m (Symbolic m) -> m (Symbolic m) -> m (Symbolic m))
-> HashMap VarName (m (Symbolic m))
-> HashMap VarName (m (Symbolic m))
-> HashMap VarName (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))
-> AttrSet (Symbolic m) -> HashMap VarName (m (Symbolic m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttrSet (Symbolic m)
l)
        (Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbolic m -> m (Symbolic m))
-> AttrSet (Symbolic m) -> HashMap VarName (m (Symbolic m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttrSet (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
        ((OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (Maybe (AttrSet (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (AttrSet r) -> NTypeF m r
TSet (Maybe (AttrSet (Symbolic m)) -> NTypeF m (Symbolic m))
-> Maybe (AttrSet (Symbolic m)) -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ AttrSet (Symbolic m) -> Maybe (AttrSet (Symbolic m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure AttrSet (Symbolic m)
m) [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. Semigroup 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
$ AttrSet (Symbolic m) -> Bool
forall k v. HashMap k v -> Bool
M.null AttrSet (Symbolic m)
m)
        m [NTypeF m (Symbolic m)]
rest

    (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)]
yys
      | 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)]
xxs [NTypeF m (Symbolic m)]
ys
      | Bool
otherwise              -> Text -> m [NTypeF m (Symbolic m)]
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
   . MonadLint e m
  => NExprF ()
  -> Symbolic m
  -> Symbolic m
  -> m (Symbolic m)
unify :: NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context (SV SValue m
x) (SV SValue m
y) = do
  NSymbolicF (NTypeF m (Symbolic m))
x' <- SValue m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
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
          let
           nm :: NSymbolicF (NTypeF m (Symbolic m))
nm = [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
x   NSymbolicF (NTypeF m (Symbolic m))
nm
          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))
nm
          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))
nm
        )
        (
              -- x' <- renderSymbolic (Symbolic x)
              -- y' <- renderSymbolic (Symbolic y)
          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 "
                  -- <> show x' <> " with " <> show y'
                  --  <> " in context: " <> show context
        )
        ([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!"

-- 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 = (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 :: (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 :: VarName -> m (Symbolic m)
freeVariable VarName
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
<> VarName -> Text
coerce VarName
var Text -> Text -> Text
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
forall (m :: * -> *) s a.
(MonadEval (Symbolic m) m, Exception s) =>
s -> m a
evalError @(Symbolic m) (ErrorCall -> m (Symbolic m)) -> ErrorCall -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall (String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$ 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
"." ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Text -> [Text]) -> NonEmpty Text -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty VarName -> NonEmpty Text
coerce NonEmpty VarName
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)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one OneItem [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 ([NTypeF m (Symbolic m)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m (Symbolic m))
-> [TAtom] -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
TAtom
TInt
    Symbolic m
c <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic ([NTypeF m (Symbolic m)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m (Symbolic m))
-> [TAtom] -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
TAtom
TInt
    [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic ([NTypeF m (Symbolic m)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ Maybe (AttrSet (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (AttrSet r) -> NTypeF m r
TSet (AttrSet (Symbolic m) -> Maybe (AttrSet (Symbolic m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(VarName, Symbolic m)] -> AttrSet (Symbolic m)
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 = [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic ([NTypeF m (Symbolic m)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ NAtom -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. NAtom -> NTypeF m r
fun NAtom
c
   where
    fun :: NAtom -> NTypeF m r
fun =
      \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] -> NTypeF m r) -> [TAtom] -> NTypeF m r
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
TAtom
TInt
        NFloat Float
_ -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m r) -> [TAtom] -> NTypeF m r
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
TAtom
TFloat
        NBool  Bool
_ -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m r) -> [TAtom] -> NTypeF m r
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
TAtom
TBool
        NAtom
NNull    -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m r) -> [TAtom] -> NTypeF m r
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
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)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one OneItem [NTypeF m (Symbolic m)]
forall (m :: * -> *) r. NTypeF m r
TStr
  evalLiteralPath :: Path -> m (Symbolic m)
evalLiteralPath = m (Symbolic m) -> Path -> m (Symbolic m)
forall a b. a -> b -> a
const (m (Symbolic m) -> Path -> m (Symbolic m))
-> m (Symbolic m) -> Path -> 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)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one OneItem [NTypeF m (Symbolic m)]
forall (m :: * -> *) r. NTypeF m r
TPath
  evalEnvPath :: Path -> m (Symbolic m)
evalEnvPath     = m (Symbolic m) -> Path -> m (Symbolic m)
forall a b. a -> b -> a
const (m (Symbolic m) -> Path -> m (Symbolic m))
-> m (Symbolic m) -> Path -> 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)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one OneItem [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 (NExprF (Symbolic m) -> NExprF ())
-> NExprF (Symbolic m) -> NExprF ()
forall a b. (a -> b) -> a -> b
$ 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 (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [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

  -- 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 <- 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 (Scope (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
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 (AttrSet (Symbolic m) -> Scope (Symbolic m)
coerce -> Scope (Symbolic m)
scope))] -> Scope (Symbolic m) -> m (Scope (Symbolic m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scope (Symbolic m)
scope
          NMany [TSet Maybe (AttrSet (Symbolic m))
Nothing] -> Text -> m (Scope (Symbolic m))
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"NYI: with unknown"
          NSymbolicF (NTypeF m (Symbolic m))
_ -> ErrorCall -> m (Scope (Symbolic m))
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (Scope (Symbolic m)))
-> ErrorCall -> m (Scope (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 (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m (Symbolic m))
-> [TAtom] -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
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 (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m (Symbolic m))
-> [TAtom] -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
TAtom
TBool)
      pure Symbolic m
body'

  evalApp :: Symbolic m -> m (Symbolic m) -> m (Symbolic m)
evalApp = (((AttrSet (Symbolic m), Symbolic m) -> Symbolic m)
-> m (AttrSet (Symbolic m), Symbolic m) -> m (Symbolic m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AttrSet (Symbolic m), Symbolic m) -> Symbolic m
forall a b. (a, b) -> b
snd (m (AttrSet (Symbolic m), Symbolic m) -> m (Symbolic m))
-> (m (Symbolic m) -> m (AttrSet (Symbolic m), Symbolic m))
-> m (Symbolic m)
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((m (Symbolic m) -> m (AttrSet (Symbolic m), Symbolic m))
 -> m (Symbolic m) -> m (Symbolic m))
-> (Symbolic m
    -> m (Symbolic m) -> m (AttrSet (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 (AttrSet (Symbolic m), Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp ((() -> () -> NExprF ()) -> () -> NExprF ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (NBinaryOp -> () -> () -> NExprF ()
forall r. NBinaryOp -> r -> r -> NExprF r
NBinary NBinaryOp
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)
_ = [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ Params () -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Params () -> NTypeF m r
TClosure (Params () -> NTypeF m (Symbolic m))
-> Params () -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ Params (m (Symbolic m)) -> Params ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Params (m (Symbolic m))
params)

  evalError :: s -> m a
evalError = s -> m a
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError

lintBinaryOp
  :: forall e m
   . (MonadLint e m, MonadEval (Symbolic m) m)
  => NBinaryOp
  -> Symbolic m
  -> m (Symbolic m)
  -> m (Symbolic m)
lintBinaryOp :: NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
lintBinaryOp NBinaryOp
op Symbolic m
lsym m (Symbolic m)
rarg =
  do
    Symbolic m
rsym <- m (Symbolic m)
rarg
    Symbolic m
y    <- m (Symbolic m) -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => m v -> m v
defer m (Symbolic m)
forall (m :: * -> *). 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     -> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]
          NBinaryOp
NLte    -> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]
          NBinaryOp
NGt     -> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]
          NBinaryOp
NGte    -> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]

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

          -- jww (2018-04-01): NYI: Allow Path + Str
          NBinaryOp
NPlus   -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m (Symbolic m))
-> [TAtom] -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
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  -> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m (Symbolic m))
-> [TAtom] -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
TAtom
TInt
          NBinaryOp
NMult   -> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m (Symbolic m))
-> [TAtom] -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
TAtom
TInt
          NBinaryOp
NDiv    -> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ [TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom] -> NTypeF m (Symbolic m))
-> [TAtom] -> NTypeF m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ OneItem [TAtom] -> [TAtom]
forall x. One x => OneItem x -> x
one OneItem [TAtom]
TAtom
TInt

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

          NBinaryOp
NConcat -> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall x. One x => OneItem x -> x
one (OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> OneItem [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a b. (a -> b) -> a -> b
$ Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y
#if __GLASGOW_HASKELL__ < 900
          NBinaryOp
_ -> String -> [NTypeF m (Symbolic m)]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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
        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
        unifyE :: Symbolic m -> Symbolic m -> m (Symbolic m)
unifyE = 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
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
_ <- Symbolic m -> Symbolic m -> m (Symbolic m)
unifyE Symbolic m
lsym Symbolic m
m
      Symbolic m
_ <- Symbolic m -> Symbolic m -> m (Symbolic m)
unifyE Symbolic m
rsym Symbolic m
m
      Symbolic m -> Symbolic m -> m (Symbolic m)
unifyE Symbolic m
lsym Symbolic m
rsym

infixl 1 `lintApp`
lintApp
  :: forall e m
   . MonadLint e m
  => NExprF ()
  -> Symbolic m
  -> m (Symbolic m)
  -> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp :: NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp NExprF ()
context Symbolic m
fun m (Symbolic m)
arg =
  (\case
    NSymbolicF (NTypeF m (Symbolic m))
NAny ->
      ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap VarName (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 VarName (Symbolic m)]
args, [Symbolic m]
ys) <- ([(HashMap VarName (Symbolic m), Symbolic m)]
 -> ([HashMap VarName (Symbolic m)], [Symbolic m]))
-> m [(HashMap VarName (Symbolic m), Symbolic m)]
-> m ([HashMap VarName (Symbolic m)], [Symbolic m])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(HashMap VarName (Symbolic m), Symbolic m)]
-> ([HashMap VarName (Symbolic m)], [Symbolic m])
forall a b. [(a, b)] -> ([a], [b])
unzip (m [(HashMap VarName (Symbolic m), Symbolic m)]
 -> m ([HashMap VarName (Symbolic m)], [Symbolic m]))
-> m [(HashMap VarName (Symbolic m), Symbolic m)]
-> m ([HashMap VarName (Symbolic m)], [Symbolic m])
forall a b. (a -> b) -> a -> b
$ [NTypeF m (Symbolic m)]
-> (NTypeF m (Symbolic m)
    -> m (HashMap VarName (Symbolic m), Symbolic m))
-> m [(HashMap VarName (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 VarName (Symbolic m), Symbolic m))
 -> m [(HashMap VarName (Symbolic m), Symbolic m)])
-> (NTypeF m (Symbolic m)
    -> m (HashMap VarName (Symbolic m), Symbolic m))
-> m [(HashMap VarName (Symbolic m), Symbolic m)]
forall a b. (a -> b) -> a -> b
$ \case
        TClosure Params ()
_params ->
          (\case
            NSymbolicF (NTypeF m (Symbolic m))
NAny -> do
              Text -> m (HashMap VarName (Symbolic m), Symbolic m)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"NYI"

            NMany [TSet (Just HashMap VarName (Symbolic m)
_)] -> do
              Text -> m (HashMap VarName (Symbolic m), Symbolic m)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"NYI"

            NMany [NTypeF m (Symbolic m)]
_ -> ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp NMany not set"
          ) (NSymbolicF (NTypeF m (Symbolic m))
 -> m (HashMap VarName (Symbolic m), Symbolic m))
-> m (NSymbolicF (NTypeF m (Symbolic m)))
-> m (HashMap VarName (Symbolic m), Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> 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 (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
=<< m (Symbolic m)
arg
        TBuiltin Text
_ Symbolic m -> m (Symbolic m)
_f -> ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp builtin"
        TSet Maybe (HashMap VarName (Symbolic m))
_m       -> ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap VarName (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 VarName (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap VarName (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap VarName (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 VarName (Symbolic m)] -> HashMap VarName (Symbolic m)
forall a. [a] -> a
Unsafe.head [HashMap VarName (Symbolic m)]
args, ) (Symbolic m -> (HashMap VarName (Symbolic m), Symbolic m))
-> m (Symbolic m) -> m (HashMap VarName (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
  ) (NSymbolicF (NTypeF m (Symbolic m))
 -> m (HashMap VarName (Symbolic m), Symbolic m))
-> m (NSymbolicF (NTypeF m (Symbolic m)))
-> m (HashMap VarName (Symbolic m), Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> 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 Symbolic m
fun

newtype Lint s a = Lint
  { Lint s a
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
runLint :: ReaderT (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a }
  deriving
    ( a -> Lint s b -> Lint s a
(a -> b) -> Lint s a -> Lint s b
(forall a b. (a -> b) -> Lint s a -> Lint s b)
-> (forall a b. a -> Lint s b -> Lint s a) -> Functor (Lint s)
forall a b. a -> Lint s b -> Lint s a
forall a b. (a -> b) -> Lint s a -> Lint s b
forall s a b. a -> Lint s b -> Lint s a
forall s a b. (a -> b) -> Lint s a -> Lint s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Lint s b -> Lint s a
$c<$ :: forall s a b. a -> Lint s b -> Lint s a
fmap :: (a -> b) -> Lint s a -> Lint s b
$cfmap :: forall s a b. (a -> b) -> Lint s a -> Lint s b
Functor
    , Functor (Lint s)
a -> Lint s a
Functor (Lint s)
-> (forall a. a -> Lint s a)
-> (forall a b. Lint s (a -> b) -> Lint s a -> Lint s b)
-> (forall a b c.
    (a -> b -> c) -> Lint s a -> Lint s b -> Lint s c)
-> (forall a b. Lint s a -> Lint s b -> Lint s b)
-> (forall a b. Lint s a -> Lint s b -> Lint s a)
-> Applicative (Lint s)
Lint s a -> Lint s b -> Lint s b
Lint s a -> Lint s b -> Lint s a
Lint s (a -> b) -> Lint s a -> Lint s b
(a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
forall s. Functor (Lint s)
forall a. a -> Lint s a
forall s a. a -> Lint s a
forall a b. Lint s a -> Lint s b -> Lint s a
forall a b. Lint s a -> Lint s b -> Lint s b
forall a b. Lint s (a -> b) -> Lint s a -> Lint s b
forall s a b. Lint s a -> Lint s b -> Lint s a
forall s a b. Lint s a -> Lint s b -> Lint s b
forall s a b. Lint s (a -> b) -> Lint s a -> Lint s b
forall a b c. (a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
forall s a b c. (a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Lint s a -> Lint s b -> Lint s a
$c<* :: forall s a b. Lint s a -> Lint s b -> Lint s a
*> :: Lint s a -> Lint s b -> Lint s b
$c*> :: forall s a b. Lint s a -> Lint s b -> Lint s b
liftA2 :: (a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
$cliftA2 :: forall s a b c. (a -> b -> c) -> Lint s a -> Lint s b -> Lint s c
<*> :: Lint s (a -> b) -> Lint s a -> Lint s b
$c<*> :: forall s a b. Lint s (a -> b) -> Lint s a -> Lint s b
pure :: a -> Lint s a
$cpure :: forall s a. a -> Lint s a
$cp1Applicative :: forall s. Functor (Lint s)
Applicative
    , Applicative (Lint s)
a -> Lint s a
Applicative (Lint s)
-> (forall a b. Lint s a -> (a -> Lint s b) -> Lint s b)
-> (forall a b. Lint s a -> Lint s b -> Lint s b)
-> (forall a. a -> Lint s a)
-> Monad (Lint s)
Lint s a -> (a -> Lint s b) -> Lint s b
Lint s a -> Lint s b -> Lint s b
forall s. Applicative (Lint s)
forall a. a -> Lint s a
forall s a. a -> Lint s a
forall a b. Lint s a -> Lint s b -> Lint s b
forall a b. Lint s a -> (a -> Lint s b) -> Lint s b
forall s a b. Lint s a -> Lint s b -> Lint s b
forall s a b. Lint s a -> (a -> Lint s b) -> Lint s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Lint s a
$creturn :: forall s a. a -> Lint s a
>> :: Lint s a -> Lint s b -> Lint s b
$c>> :: forall s a b. Lint s a -> Lint s b -> Lint s b
>>= :: Lint s a -> (a -> Lint s b) -> Lint s b
$c>>= :: forall s a b. Lint s a -> (a -> Lint s b) -> Lint s b
$cp1Monad :: forall s. Applicative (Lint s)
Monad
    , Monad (Lint s)
Monad (Lint s)
-> (forall a. (a -> Lint s a) -> Lint s a) -> MonadFix (Lint s)
(a -> Lint s a) -> Lint s a
forall s. Monad (Lint s)
forall a. (a -> Lint s a) -> Lint s a
forall s a. (a -> Lint s a) -> Lint s a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: (a -> Lint s a) -> Lint s a
$cmfix :: forall s a. (a -> Lint s a) -> Lint s a
$cp1MonadFix :: forall s. Monad (Lint s)
MonadFix
    , MonadReader (Context (Lint s) (Symbolic (Lint s)))
    , Eq (ThunkId (Lint s))
Monad (Lint s)
Ord (ThunkId (Lint s))
Show (ThunkId (Lint s))
Typeable (ThunkId (Lint s))
Lint s (ThunkId (Lint s))
Monad (Lint s)
-> Eq (ThunkId (Lint s))
-> Ord (ThunkId (Lint s))
-> Show (ThunkId (Lint s))
-> Typeable (ThunkId (Lint s))
-> Lint s (ThunkId (Lint s))
-> MonadThunkId (Lint s)
forall s. Eq (ThunkId (Lint s))
forall s. Monad (Lint s)
forall s. Ord (ThunkId (Lint s))
forall s. Show (ThunkId (Lint s))
forall s. Typeable (ThunkId (Lint s))
forall s. Lint s (ThunkId (Lint s))
forall (m :: * -> *).
Monad m
-> Eq (ThunkId m)
-> Ord (ThunkId m)
-> Show (ThunkId m)
-> Typeable (ThunkId m)
-> m (ThunkId m)
-> MonadThunkId m
freshId :: Lint s (ThunkId (Lint s))
$cfreshId :: forall s. Lint s (ThunkId (Lint s))
$cp5MonadThunkId :: forall s. Typeable (ThunkId (Lint s))
$cp4MonadThunkId :: forall s. Show (ThunkId (Lint s))
$cp3MonadThunkId :: forall s. Ord (ThunkId (Lint s))
$cp2MonadThunkId :: forall s. Eq (ThunkId (Lint s))
$cp1MonadThunkId :: forall s. Monad (Lint s)
MonadThunkId
    , Monad (Lint s)
a -> Lint s (Ref (Lint s) a)
Monad (Lint s)
-> (forall a. a -> Lint s (Ref (Lint s) a))
-> (forall a. Ref (Lint s) a -> Lint s a)
-> (forall a. Ref (Lint s) a -> a -> Lint s ())
-> (forall a. Ref (Lint s) a -> (a -> a) -> Lint s ())
-> (forall a. Ref (Lint s) a -> (a -> a) -> Lint s ())
-> MonadRef (Lint s)
Ref (Lint s) a -> Lint s a
Ref (Lint s) a -> a -> Lint s ()
Ref (Lint s) a -> (a -> a) -> Lint s ()
Ref (Lint s) a -> (a -> a) -> Lint s ()
forall s. Monad (Lint s)
forall a. a -> Lint s (Ref (Lint s) a)
forall a. Ref (Lint s) a -> Lint s a
forall a. Ref (Lint s) a -> a -> Lint s ()
forall a. Ref (Lint s) a -> (a -> a) -> Lint s ()
forall s a. a -> Lint s (Ref (Lint s) a)
forall s a. Ref (Lint s) a -> Lint s a
forall s a. Ref (Lint s) a -> a -> Lint s ()
forall s a. Ref (Lint s) a -> (a -> a) -> Lint s ()
forall (m :: * -> *).
Monad m
-> (forall a. a -> m (Ref m a))
-> (forall a. Ref m a -> m a)
-> (forall a. Ref m a -> a -> m ())
-> (forall a. Ref m a -> (a -> a) -> m ())
-> (forall a. Ref m a -> (a -> a) -> m ())
-> MonadRef m
modifyRef' :: Ref (Lint s) a -> (a -> a) -> Lint s ()
$cmodifyRef' :: forall s a. Ref (Lint s) a -> (a -> a) -> Lint s ()
modifyRef :: Ref (Lint s) a -> (a -> a) -> Lint s ()
$cmodifyRef :: forall s a. Ref (Lint s) a -> (a -> a) -> Lint s ()
writeRef :: Ref (Lint s) a -> a -> Lint s ()
$cwriteRef :: forall s a. Ref (Lint s) a -> a -> Lint s ()
readRef :: Ref (Lint s) a -> Lint s a
$creadRef :: forall s a. Ref (Lint s) a -> Lint s a
newRef :: a -> Lint s (Ref (Lint s) a)
$cnewRef :: forall s a. a -> Lint s (Ref (Lint s) a)
$cp1MonadRef :: forall s. Monad (Lint s)
MonadRef
    , MonadRef (Lint s)
Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
MonadRef (Lint s)
-> (forall a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b)
-> (forall a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b)
-> MonadAtomicRef (Lint s)
forall s. MonadRef (Lint s)
forall a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
forall s a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
forall (m :: * -> *).
MonadRef m
-> (forall a b. Ref m a -> (a -> (a, b)) -> m b)
-> (forall a b. Ref m a -> (a -> (a, b)) -> m b)
-> MonadAtomicRef m
atomicModifyRef' :: Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
$catomicModifyRef' :: forall s a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
atomicModifyRef :: Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
$catomicModifyRef :: forall s a b. Ref (Lint s) a -> (a -> (a, b)) -> Lint s b
$cp1MonadAtomicRef :: forall s. MonadRef (Lint s)
MonadAtomicRef
    )

instance MonadThrow (Lint s) where
  throwM :: forall e a . Exception e => e -> Lint s a
  throwM :: e -> Lint s a
throwM e
e = ReaderT
  (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall s a.
ReaderT
  (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
Lint (ReaderT
   (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
 -> Lint s a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall a b. (a -> b) -> a -> b
$ (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
 -> ReaderT
      (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a)
-> (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall a b. (a -> b) -> a -> b
$ FreshIdT Int (ST s) a
-> Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a
forall a b. a -> b -> a
const (e -> FreshIdT Int (ST s) a
forall a e. Exception e => e -> a
throw e
e)

instance MonadCatch (Lint s) where
  catch :: Lint s a -> (e -> Lint s a) -> Lint s a
catch Lint s a
_m e -> Lint s a
_h = ReaderT
  (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall s a.
ReaderT
  (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
Lint (ReaderT
   (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
 -> Lint s a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall a b. (a -> b) -> a -> b
$ (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
 -> ReaderT
      (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a)
-> (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall a b. (a -> b) -> a -> b
$ FreshIdT Int (ST s) a
-> Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a
forall a b. a -> b -> a
const (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 :: Options -> Lint s a -> ST s a
runLintM Options
opts Lint s a
action =
  FreshIdT Int (ST s) a -> Ref (ST s) Int -> ST s a
forall (m :: * -> *) i a.
Functor m =>
FreshIdT i m a -> Ref m i -> m a
runFreshIdT ((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) (STRef s Int -> ST s a) -> ST s (STRef s Int) -> ST s a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> ST s (Ref (ST s) Int)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
newRef (Int
1 :: Int)

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

lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
lint Options
opts NExprLoc
expr =
  Options -> Lint s (Symbolic (Lint s)) -> ST s (Symbolic (Lint s))
forall s a. Options -> Lint s a -> ST s a
runLintM Options
opts (Lint s (Symbolic (Lint s)) -> ST s (Symbolic (Lint s)))
-> Lint s (Symbolic (Lint s)) -> ST s (Symbolic (Lint s))
forall a b. (a -> b) -> a -> b
$
    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
  askScopes :: Lint s (Scopes (Lint s) (Symbolic (Lint s)))
askScopes = Lint s (Scopes (Lint s) (Symbolic (Lint s)))
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
m (Scopes m a)
askScopesReader
  clearScopes :: Lint s r -> Lint s r
clearScopes   = forall e r.
(MonadReader e (Lint s),
 Has e (Scopes (Lint s) (Symbolic (Lint s)))) =>
Lint s r -> Lint s r
forall (m :: * -> *) a e r.
(MonadReader e m, Has e (Scopes m a)) =>
m r -> m r
clearScopesReader @(Lint s) @(Symbolic (Lint s))
  pushScopes :: Scopes (Lint s) (Symbolic (Lint s)) -> Lint s r -> Lint s r
pushScopes    = Scopes (Lint s) (Symbolic (Lint s)) -> Lint s r -> Lint s r
forall e (m :: * -> *) a r.
(MonadReader e m, Has e (Scopes m a)) =>
Scopes m a -> m r -> m r
pushScopesReader
  lookupVar :: VarName -> Lint s (Maybe (Symbolic (Lint s)))
lookupVar     = VarName -> Lint s (Maybe (Symbolic (Lint s)))
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
VarName -> m (Maybe a)
lookupVarReader