{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

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

module Nix.Lint where

import           Prelude                 hiding ( head
                                                , force
                                                )
import           Nix.Utils
import           Control.Monad                  ( foldM )
import           Control.Monad.Catch
import           Control.Monad.Fix
import           Control.Monad.Ref
import           Control.Monad.ST
import qualified Data.HashMap.Lazy             as M
-- Plese, use NonEmpty
import           Data.List
import qualified Data.List.NonEmpty            as NE
import qualified Data.Text                     as Text
import qualified Text.Show
import           Nix.Atoms
import           Nix.Context
import           Nix.Convert
import           Nix.Eval                       ( MonadEval(..) )
import qualified Nix.Eval                      as Eval
import           Nix.Expr
import           Nix.Frames
import           Nix.Fresh
import           Nix.String
import           Nix.Options
import           Nix.Scope
import           Nix.Thunk
import           Nix.Thunk.Basic
import           Nix.Value.Monad

data TAtom
  = TInt
  | TFloat
  | TBool
  | TNull
  deriving (Int -> TAtom -> ShowS
[TAtom] -> ShowS
TAtom -> String
(Int -> TAtom -> ShowS)
-> (TAtom -> String) -> ([TAtom] -> ShowS) -> Show TAtom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TAtom] -> ShowS
$cshowList :: [TAtom] -> ShowS
show :: TAtom -> String
$cshow :: TAtom -> String
showsPrec :: Int -> TAtom -> ShowS
$cshowsPrec :: Int -> TAtom -> ShowS
Show, TAtom -> TAtom -> Bool
(TAtom -> TAtom -> Bool) -> (TAtom -> TAtom -> Bool) -> Eq TAtom
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TAtom -> TAtom -> Bool
$c/= :: TAtom -> TAtom -> Bool
== :: TAtom -> TAtom -> Bool
$c== :: TAtom -> TAtom -> Bool
Eq, Eq TAtom
Eq TAtom
-> (TAtom -> TAtom -> Ordering)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> Bool)
-> (TAtom -> TAtom -> TAtom)
-> (TAtom -> TAtom -> TAtom)
-> Ord TAtom
TAtom -> TAtom -> Bool
TAtom -> TAtom -> Ordering
TAtom -> TAtom -> TAtom
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TAtom -> TAtom -> TAtom
$cmin :: TAtom -> TAtom -> TAtom
max :: TAtom -> TAtom -> TAtom
$cmax :: TAtom -> TAtom -> TAtom
>= :: TAtom -> TAtom -> Bool
$c>= :: TAtom -> TAtom -> Bool
> :: TAtom -> TAtom -> Bool
$c> :: TAtom -> TAtom -> Bool
<= :: TAtom -> TAtom -> Bool
$c<= :: TAtom -> TAtom -> Bool
< :: TAtom -> TAtom -> Bool
$c< :: TAtom -> TAtom -> Bool
compare :: TAtom -> TAtom -> Ordering
$ccompare :: TAtom -> TAtom -> Ordering
Ord)

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

compareTypes :: NTypeF m r -> NTypeF m r -> Ordering
compareTypes :: forall (m :: * -> *) r. NTypeF m r -> NTypeF m r -> Ordering
compareTypes (TConstant [TAtom]
_)  (TConstant [TAtom]
_)  = Ordering
EQ
compareTypes (TConstant [TAtom]
_)  NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              (TConstant [TAtom]
_)  = Ordering
GT
compareTypes NTypeF m r
TStr           NTypeF m r
TStr           = Ordering
EQ
compareTypes NTypeF m r
TStr           NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              NTypeF m r
TStr           = Ordering
GT
compareTypes (TList r
_)      (TList r
_)      = Ordering
EQ
compareTypes (TList r
_)      NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              (TList r
_)      = Ordering
GT
compareTypes (TSet Maybe (HashMap Text r)
_)       (TSet  Maybe (HashMap Text r)
_)      = Ordering
EQ
compareTypes (TSet Maybe (HashMap Text r)
_)       NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              (TSet Maybe (HashMap Text r)
_)       = Ordering
GT
compareTypes TClosure{}     TClosure{}     = Ordering
EQ
compareTypes TClosure{}     NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              TClosure{}     = Ordering
GT
compareTypes NTypeF m r
TPath          NTypeF m r
TPath          = Ordering
EQ
compareTypes NTypeF m r
TPath          NTypeF m r
_              = Ordering
LT
compareTypes NTypeF m r
_              NTypeF m r
TPath          = Ordering
GT
compareTypes (TBuiltin Text
_ Symbolic m -> m r
_) (TBuiltin Text
_ Symbolic m -> m r
_) = Ordering
EQ

data NSymbolicF r
  = NAny
  | NMany [r]
  deriving (Int -> NSymbolicF r -> ShowS
[NSymbolicF r] -> ShowS
NSymbolicF r -> String
(Int -> NSymbolicF r -> ShowS)
-> (NSymbolicF r -> String)
-> ([NSymbolicF r] -> ShowS)
-> Show (NSymbolicF r)
forall r. Show r => Int -> NSymbolicF r -> ShowS
forall r. Show r => [NSymbolicF r] -> ShowS
forall r. Show r => NSymbolicF r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NSymbolicF r] -> ShowS
$cshowList :: forall r. Show r => [NSymbolicF r] -> ShowS
show :: NSymbolicF r -> String
$cshow :: forall r. Show r => NSymbolicF r -> String
showsPrec :: Int -> NSymbolicF r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> NSymbolicF r -> ShowS
Show, NSymbolicF r -> NSymbolicF r -> Bool
(NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool) -> Eq (NSymbolicF r)
forall r. Eq r => NSymbolicF r -> NSymbolicF r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NSymbolicF r -> NSymbolicF r -> Bool
$c/= :: forall r. Eq r => NSymbolicF r -> NSymbolicF r -> Bool
== :: NSymbolicF r -> NSymbolicF r -> Bool
$c== :: forall r. Eq r => NSymbolicF r -> NSymbolicF r -> Bool
Eq, Eq (NSymbolicF r)
Eq (NSymbolicF r)
-> (NSymbolicF r -> NSymbolicF r -> Ordering)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> Bool)
-> (NSymbolicF r -> NSymbolicF r -> NSymbolicF r)
-> (NSymbolicF r -> NSymbolicF r -> NSymbolicF r)
-> Ord (NSymbolicF r)
NSymbolicF r -> NSymbolicF r -> Bool
NSymbolicF r -> NSymbolicF r -> Ordering
NSymbolicF r -> NSymbolicF r -> NSymbolicF r
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {r}. Ord r => Eq (NSymbolicF r)
forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Ordering
forall r. Ord r => NSymbolicF r -> NSymbolicF r -> NSymbolicF r
min :: NSymbolicF r -> NSymbolicF r -> NSymbolicF r
$cmin :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> NSymbolicF r
max :: NSymbolicF r -> NSymbolicF r -> NSymbolicF r
$cmax :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> NSymbolicF r
>= :: NSymbolicF r -> NSymbolicF r -> Bool
$c>= :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
> :: NSymbolicF r -> NSymbolicF r -> Bool
$c> :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
<= :: NSymbolicF r -> NSymbolicF r -> Bool
$c<= :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
< :: NSymbolicF r -> NSymbolicF r -> Bool
$c< :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Bool
compare :: NSymbolicF r -> NSymbolicF r -> Ordering
$ccompare :: forall r. Ord r => NSymbolicF r -> NSymbolicF r -> Ordering
Ord, (forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b)
-> (forall a b. a -> NSymbolicF b -> NSymbolicF a)
-> Functor NSymbolicF
forall a b. a -> NSymbolicF b -> NSymbolicF a
forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NSymbolicF b -> NSymbolicF a
$c<$ :: forall a b. a -> NSymbolicF b -> NSymbolicF a
fmap :: forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b
$cfmap :: forall a b. (a -> b) -> NSymbolicF a -> NSymbolicF b
Functor, (forall m. Monoid m => NSymbolicF m -> m)
-> (forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m)
-> (forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m)
-> (forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b)
-> (forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b)
-> (forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b)
-> (forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b)
-> (forall a. (a -> a -> a) -> NSymbolicF a -> a)
-> (forall a. (a -> a -> a) -> NSymbolicF a -> a)
-> (forall a. NSymbolicF a -> [a])
-> (forall a. NSymbolicF a -> Bool)
-> (forall a. NSymbolicF a -> Int)
-> (forall a. Eq a => a -> NSymbolicF a -> Bool)
-> (forall a. Ord a => NSymbolicF a -> a)
-> (forall a. Ord a => NSymbolicF a -> a)
-> (forall a. Num a => NSymbolicF a -> a)
-> (forall a. Num a => NSymbolicF a -> a)
-> Foldable NSymbolicF
forall a. Eq a => a -> NSymbolicF a -> Bool
forall a. Num a => NSymbolicF a -> a
forall a. Ord a => NSymbolicF a -> a
forall m. Monoid m => NSymbolicF m -> m
forall a. NSymbolicF a -> Bool
forall a. NSymbolicF a -> Int
forall a. NSymbolicF a -> [a]
forall a. (a -> a -> a) -> NSymbolicF a -> a
forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => NSymbolicF a -> a
$cproduct :: forall a. Num a => NSymbolicF a -> a
sum :: forall a. Num a => NSymbolicF a -> a
$csum :: forall a. Num a => NSymbolicF a -> a
minimum :: forall a. Ord a => NSymbolicF a -> a
$cminimum :: forall a. Ord a => NSymbolicF a -> a
maximum :: forall a. Ord a => NSymbolicF a -> a
$cmaximum :: forall a. Ord a => NSymbolicF a -> a
elem :: forall a. Eq a => a -> NSymbolicF a -> Bool
$celem :: forall a. Eq a => a -> NSymbolicF a -> Bool
length :: forall a. NSymbolicF a -> Int
$clength :: forall a. NSymbolicF a -> Int
null :: forall a. NSymbolicF a -> Bool
$cnull :: forall a. NSymbolicF a -> Bool
toList :: forall a. NSymbolicF a -> [a]
$ctoList :: forall a. NSymbolicF a -> [a]
foldl1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
foldr1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> NSymbolicF a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
foldl :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> NSymbolicF a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
foldr :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> NSymbolicF a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> NSymbolicF a -> m
fold :: forall m. Monoid m => NSymbolicF m -> m
$cfold :: forall m. Monoid m => NSymbolicF m -> m
Foldable, Functor NSymbolicF
Foldable NSymbolicF
Functor NSymbolicF
-> Foldable NSymbolicF
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> NSymbolicF a -> f (NSymbolicF b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    NSymbolicF (f a) -> f (NSymbolicF a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> NSymbolicF a -> m (NSymbolicF b))
-> (forall (m :: * -> *) a.
    Monad m =>
    NSymbolicF (m a) -> m (NSymbolicF a))
-> Traversable NSymbolicF
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a)
forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
sequence :: forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
NSymbolicF (m a) -> m (NSymbolicF a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NSymbolicF a -> m (NSymbolicF b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
NSymbolicF (f a) -> f (NSymbolicF a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NSymbolicF a -> f (NSymbolicF b)
Traversable)

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

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

data Symbolic m = SV { forall (m :: * -> *). Symbolic m -> SValue m
getSV :: SValue m } | ST { forall (m :: * -> *). Symbolic m -> SThunk m
getST :: SThunk m }

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

everyPossible
  :: MonadAtomicRef m
  => m (Symbolic m)
everyPossible :: forall (m :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible = NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic NSymbolicF (NTypeF m (Symbolic m))
forall r. NSymbolicF r
NAny

mkSymbolic
  :: MonadAtomicRef m
  => [NTypeF m (Symbolic m)]
  -> m (Symbolic m)
mkSymbolic :: forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)]
xs = NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic ([NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m))
forall r. [r] -> NSymbolicF r
NMany [NTypeF m (Symbolic m)]
xs)

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

unpackSymbolic
  :: (MonadAtomicRef m, MonadThunkId m, MonadCatch m)
  => Symbolic m
  -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic :: forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic = Ref m (NSymbolicF (NTypeF m (Symbolic m)))
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef (Ref m (NSymbolicF (NTypeF m (Symbolic m)))
 -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> (Symbolic m -> Ref m (NSymbolicF (NTypeF m (Symbolic m))))
-> Symbolic m
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbolic m -> Ref m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *). Symbolic m -> SValue m
getSV (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> (Symbolic m -> m (Symbolic m))
-> Symbolic m
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand

type MonadLint e m =
  ( Scoped (Symbolic m) m
  , Framed e m
  , MonadAtomicRef m
  , MonadCatch m
  , MonadThunkId m
  )

symerr :: forall e m a . MonadLint e m => Text -> m a
symerr :: forall e (m :: * -> *) a. MonadLint e m => Text -> m a
symerr = forall v (m :: * -> *) s a.
(MonadEval v m, Exception s) =>
s -> m a
evalError @(Symbolic m) (ErrorCall -> m a) -> (Text -> ErrorCall) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall) -> (Text -> String) -> Text -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString

renderSymbolic :: MonadLint e m => Symbolic m -> m Text
renderSymbolic :: forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic = Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> (NSymbolicF (NTypeF m (Symbolic m)) -> m Text)
-> Symbolic m
-> m Text
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
  NSymbolicF (NTypeF m (Symbolic m))
NAny     -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<any>"
  NMany [NTypeF m (Symbolic m)]
xs -> ([Text] -> Text) -> m [Text] -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> Text
Text.intercalate Text
", ") (m [Text] -> m Text) -> m [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ [NTypeF m (Symbolic m)]
-> (NTypeF m (Symbolic m) -> m Text) -> m [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NTypeF m (Symbolic m)]
xs ((NTypeF m (Symbolic m) -> m Text) -> m [Text])
-> (NTypeF m (Symbolic m) -> m Text) -> m [Text]
forall a b. (a -> b) -> a -> b
$ \case
    TConstant [TAtom]
ys -> ([Text] -> Text) -> m [Text] -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> Text
Text.intercalate Text
", ") (m [Text] -> m Text) -> m [Text] -> m Text
forall a b. (a -> b) -> a -> b
$ [TAtom] -> (TAtom -> m Text) -> m [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TAtom]
ys ((TAtom -> m Text) -> m [Text]) -> (TAtom -> m Text) -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> (TAtom -> Text) -> TAtom -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      TAtom
TInt   -> Text
"int"
      TAtom
TFloat -> Text
"float"
      TAtom
TBool  -> Text
"bool"
      TAtom
TNull  -> Text
"null"
    NTypeF m (Symbolic m)
TStr    -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"string"
    TList Symbolic m
r -> do
      Text
x <- Symbolic m -> m Text
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic (Symbolic m -> m Text) -> m (Symbolic m) -> m Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
r
      pure $ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    TSet Maybe (HashMap Text (Symbolic m))
Nothing  -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<any set>"
    TSet (Just HashMap Text (Symbolic m)
s) -> do
      HashMap Text Text
x <- (Symbolic m -> m Text)
-> HashMap Text (Symbolic m) -> m (HashMap Text Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Symbolic m -> m Text
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic (Symbolic m -> m Text)
-> (Symbolic m -> m (Symbolic m)) -> Symbolic m -> m Text
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand) HashMap Text (Symbolic m)
s
      pure $ Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashMap Text Text -> Text
forall b a. (Show a, IsString b) => a -> b
show HashMap Text Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"
    f :: NTypeF m (Symbolic m)
f@(TClosure Params ()
p) -> do
      (HashMap Text (Symbolic m)
args, Symbolic m
sym) <- do
        Symbolic m
f' <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)
f]
        NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
lintApp (Params () -> () -> NExprF ()
forall r. Params r -> r -> NExprF r
NAbs (Params () -> Params ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Params ()
p) ()) Symbolic m
f' m (Symbolic m)
forall (m :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible
      HashMap Text Text
args' <- (Symbolic m -> m Text)
-> HashMap Text (Symbolic m) -> m (HashMap Text Text)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Symbolic m -> m Text
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic HashMap Text (Symbolic m)
args
      Text
sym'  <- Symbolic m -> m Text
forall e (m :: * -> *). MonadLint e m => Symbolic m -> m Text
renderSymbolic Symbolic m
sym
      pure $ Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashMap Text Text -> Text
forall b a. (Show a, IsString b) => a -> b
show HashMap Text Text
args' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sym' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    NTypeF m (Symbolic m)
TPath          -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"path"
    TBuiltin Text
_n Symbolic m -> m (Symbolic m)
_f -> Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"<builtin function>"

-- 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)]
_        = m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
  go [NTypeF m (Symbolic m)]
_        []       = m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a. (Applicative f, Monoid a) => f a
stub
  go (NTypeF m (Symbolic m)
x : [NTypeF m (Symbolic m)]
xs) (NTypeF m (Symbolic m)
y : [NTypeF m (Symbolic m)]
ys) = case (NTypeF m (Symbolic m)
x, NTypeF m (Symbolic m)
y) of
    (NTypeF m (Symbolic m)
TStr , NTypeF m (Symbolic m)
TStr ) -> (NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TStr NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
    (NTypeF m (Symbolic m)
TPath, NTypeF m (Symbolic m)
TPath) -> (NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TPath NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
    (TConstant [TAtom]
ls, TConstant [TAtom]
rs) ->
      ([TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant ([TAtom]
ls [TAtom] -> [TAtom] -> [TAtom]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [TAtom]
rs) NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
    (TList Symbolic m
l, TList Symbolic m
r) ->
      (\Symbolic m
l' ->
        (\Symbolic m
r' -> do
          Symbolic m
m <- m (Symbolic m) -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => m v -> m v
defer (m (Symbolic m) -> m (Symbolic m))
-> m (Symbolic m) -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context Symbolic m
l' Symbolic m
r'
          (Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
m NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
        ) (Symbolic m -> m [NTypeF m (Symbolic m)])
-> m (Symbolic m) -> m [NTypeF m (Symbolic m)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
r
      ) (Symbolic m -> m [NTypeF m (Symbolic m)])
-> m (Symbolic m) -> m [NTypeF m (Symbolic m)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand Symbolic m
l
    (TSet Maybe (HashMap Text (Symbolic m))
x       , TSet Maybe (HashMap Text (Symbolic m))
Nothing ) -> (Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet Maybe (HashMap Text (Symbolic m))
x NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
    (TSet Maybe (HashMap Text (Symbolic m))
Nothing , TSet Maybe (HashMap Text (Symbolic m))
x       ) -> (Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet Maybe (HashMap Text (Symbolic m))
x NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
    (TSet (Just HashMap Text (Symbolic m)
l), TSet (Just HashMap Text (Symbolic m)
r)) -> do
      HashMap Text (Symbolic m)
m <- HashMap Text (m (Symbolic m)) -> m (HashMap Text (Symbolic m))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (HashMap Text (m (Symbolic m)) -> m (HashMap Text (Symbolic m)))
-> HashMap Text (m (Symbolic m)) -> m (HashMap Text (Symbolic m))
forall a b. (a -> b) -> a -> b
$ (m (Symbolic m) -> m (Symbolic m) -> m (Symbolic m))
-> HashMap Text (m (Symbolic m))
-> HashMap Text (m (Symbolic m))
-> HashMap Text (m (Symbolic m))
forall k v1 v2 v3.
(Eq k, Hashable k) =>
(v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3
M.intersectionWith
        (\ m (Symbolic m)
i m (Symbolic m)
j ->
          do
            Symbolic m
i'' <- Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Symbolic m)
i
            Symbolic m
j'' <- Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Symbolic m)
j
            (m (Symbolic m) -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => m v -> m v
defer (m (Symbolic m) -> m (Symbolic m))
-> (Symbolic m -> m (Symbolic m)) -> Symbolic m -> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context Symbolic m
i'') Symbolic m
j''
        )
        (Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbolic m -> m (Symbolic m))
-> HashMap Text (Symbolic m) -> HashMap Text (m (Symbolic m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (Symbolic m)
l)
        (Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Symbolic m -> m (Symbolic m))
-> HashMap Text (Symbolic m) -> HashMap Text (m (Symbolic m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text (Symbolic m)
r)
      (m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)])
-> (m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)])
-> Bool
-> m [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
forall a. a -> a -> Bool -> a
bool
        m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall a. a -> a
id
        ((Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet (HashMap Text (Symbolic m) -> Maybe (HashMap Text (Symbolic m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Text (Symbolic m)
m) NTypeF m (Symbolic m)
-> [NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)]
forall a. a -> [a] -> [a]
:) ([NTypeF m (Symbolic m)] -> [NTypeF m (Symbolic m)])
-> m [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
        (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HashMap Text (Symbolic m) -> Bool
forall k v. HashMap k v -> Bool
M.null HashMap Text (Symbolic m)
m)
        ([NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)] -> m [NTypeF m (Symbolic m)]
go [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys)

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

{-
    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) -> pure $ pure Nothing
                    (_, Nothing) -> pure Nothing
                    (Nothing, _) -> pure Nothing
                    (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 :: forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify NExprF ()
context (SV SValue m
x) (SV SValue m
y) = do
  NSymbolicF (NTypeF m (Symbolic m))
x' <- SValue m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef SValue m
x
  NSymbolicF (NTypeF m (Symbolic m))
y' <- SValue m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a. MonadRef m => Ref m a -> m a
readRef SValue m
y
  case (NSymbolicF (NTypeF m (Symbolic m))
x', NSymbolicF (NTypeF m (Symbolic m))
y') of
    (NSymbolicF (NTypeF m (Symbolic m))
NAny, NSymbolicF (NTypeF m (Symbolic m))
_) -> do
      SValue m -> NSymbolicF (NTypeF m (Symbolic m)) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeRef SValue m
x NSymbolicF (NTypeF m (Symbolic m))
y'
      pure $ SValue m -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
y
    (NSymbolicF (NTypeF m (Symbolic m))
_, NSymbolicF (NTypeF m (Symbolic m))
NAny) -> do
      SValue m -> NSymbolicF (NTypeF m (Symbolic m)) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeRef SValue m
y NSymbolicF (NTypeF m (Symbolic m))
x'
      pure $ SValue m -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
x
    (NMany [NTypeF m (Symbolic m)]
xs, NMany [NTypeF m (Symbolic m)]
ys) -> do
      [NTypeF m (Symbolic m)]
m <- NExprF ()
-> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> [NTypeF m (Symbolic m)]
-> [NTypeF m (Symbolic m)]
-> m [NTypeF m (Symbolic m)]
merge NExprF ()
context [NTypeF m (Symbolic m)]
xs [NTypeF m (Symbolic m)]
ys
      m (Symbolic m) -> m (Symbolic m) -> Bool -> m (Symbolic m)
forall a. a -> a -> Bool -> a
bool
        (do
          SValue m -> NSymbolicF (NTypeF m (Symbolic m)) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeRef SValue m
x   ([NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m))
forall r. [r] -> NSymbolicF r
NMany [NTypeF m (Symbolic m)]
m)
          SValue m -> NSymbolicF (NTypeF m (Symbolic m)) -> m ()
forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> m ()
writeRef SValue m
y   ([NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m))
forall r. [r] -> NSymbolicF r
NMany [NTypeF m (Symbolic m)]
m)
          NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
NSymbolicF (NTypeF m (Symbolic m)) -> m (Symbolic m)
packSymbolic ([NTypeF m (Symbolic m)] -> NSymbolicF (NTypeF m (Symbolic m))
forall r. [r] -> NSymbolicF r
NMany [NTypeF m (Symbolic m)]
m)
        )
        (do
              -- 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), AttrSet SourcePos) m (Symbolic m) where

instance ToValue (AttrSet (Symbolic m), AttrSet SourcePos) m (Symbolic m) where

instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)
  => MonadValue (Symbolic m) m where

  defer :: m (Symbolic m) -> m (Symbolic m)
  defer :: m (Symbolic m) -> m (Symbolic m)
defer = (SThunk m -> Symbolic m) -> m (SThunk m) -> m (Symbolic m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SThunk m -> Symbolic m
forall (m :: * -> *). SThunk m -> Symbolic m
ST (m (SThunk m) -> m (Symbolic m))
-> (m (Symbolic m) -> m (SThunk m))
-> m (Symbolic m)
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Symbolic m) -> m (SThunk m)
forall t (m :: * -> *) a. MonadThunk t m a => m a -> m t
thunk

  demand :: Symbolic m -> m (Symbolic m)
  demand :: Symbolic m -> m (Symbolic m)
demand (ST SThunk m
v)= Symbolic m -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SThunk m -> m (Symbolic m)
forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force SThunk m
v
  demand (SV SValue m
v)= Symbolic m -> m (Symbolic m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SValue m -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
v)


instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)
  => MonadValueF (Symbolic m) m where

  demandF :: (Symbolic m -> m r) -> Symbolic m -> m r
  demandF :: forall r. (Symbolic m -> m r) -> Symbolic m -> m r
demandF Symbolic m -> m r
f (ST SThunk m
v)= (Symbolic m -> m r) -> Symbolic m -> m r
forall v (m :: * -> *) r. MonadValueF v m => (v -> m r) -> v -> m r
demandF Symbolic m -> m r
f (Symbolic m -> m r) -> m (Symbolic m) -> m r
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SThunk m -> m (Symbolic m)
forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force SThunk m
v
  demandF Symbolic m -> m r
f (SV SValue m
v)= Symbolic m -> m r
f (SValue m -> Symbolic m
forall (m :: * -> *). SValue m -> Symbolic m
SV SValue m
v)


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

  attrMissing :: NonEmpty Text -> Maybe (Symbolic m) -> m (Symbolic m)
attrMissing NonEmpty Text
ks Maybe (Symbolic m)
ms =
    forall v (m :: * -> *) s a.
(MonadEval v m, Exception s) =>
s -> m a
evalError @(Symbolic m) (ErrorCall -> m (Symbolic m)) -> ErrorCall -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall (String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
      Text -> (Symbolic m -> Text) -> Maybe (Symbolic m) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (Text
"Inheriting unknown attribute: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attr)
        (\ Symbolic m
s ->  Text
"Could not look up attribute " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Symbolic m -> Text
forall b a. (Show a, IsString b) => a -> b
show Symbolic m
s)
        Maybe (Symbolic m)
ms
   where
    attr :: Text
attr = Text -> [Text] -> Text
Text.intercalate Text
"." (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Text
ks)

  evalCurPos :: m (Symbolic m)
evalCurPos = do
    Symbolic m
f <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TPath]
    Symbolic m
l <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
    Symbolic m
c <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
    [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet (HashMap Text (Symbolic m) -> Maybe (HashMap Text (Symbolic m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Text, Symbolic m)] -> HashMap Text (Symbolic m)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [(Text
"file", Symbolic m
f), (Text
"line", Symbolic m
l), (Text
"col", Symbolic m
c)]))]

  evalConstant :: NAtom -> m (Symbolic m)
evalConstant NAtom
c = [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NAtom -> NTypeF m (Symbolic m)
forall {m :: * -> *} {r}. NAtom -> NTypeF m r
go NAtom
c]
   where
    go :: NAtom -> NTypeF m r
go =
      \case
        NURI   Text
_ -> NTypeF m r
forall (m :: * -> *) r. NTypeF m r
TStr
        NInt   Integer
_ -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]
        NFloat Float
_ -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TFloat]
        NBool  Bool
_ -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]
        NAtom
NNull    -> [TAtom] -> NTypeF m r
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TNull]

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

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

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

  -- 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 (HashMap Text (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a r.
(Functor m, Scoped a m) =>
m (AttrSet a) -> m r -> m r
pushWeakScope
        (case NSymbolicF (NTypeF m (Symbolic m))
s of
          NMany [TSet (Just HashMap Text (Symbolic m)
s')] -> HashMap Text (Symbolic m) -> m (HashMap Text (Symbolic m))
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Text (Symbolic m)
s'
          NMany [TSet Maybe (HashMap Text (Symbolic m))
Nothing] -> Text -> m (HashMap Text (Symbolic m))
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"NYI: with unknown"
          NSymbolicF (NTypeF m (Symbolic m))
_ -> ErrorCall -> m (HashMap Text (Symbolic m))
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m)))
-> ErrorCall -> m (HashMap Text (Symbolic m))
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"scope must be a set in with statement"
        )
        m (Symbolic m)
body

  evalIf :: Symbolic m -> m (Symbolic m) -> m (Symbolic m) -> m (Symbolic m)
evalIf Symbolic m
cond m (Symbolic m)
t m (Symbolic m)
f =
    do
      Symbolic m
t' <- m (Symbolic m)
t
      Symbolic m
f' <- m (Symbolic m)
f
      let e :: NExprF (Symbolic m)
e = Symbolic m -> Symbolic m -> Symbolic m -> NExprF (Symbolic m)
forall r. r -> r -> r -> NExprF r
NIf Symbolic m
cond Symbolic m
t' Symbolic m
f'

      Symbolic m
_ <- NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
cond (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
      NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
t' Symbolic m
f'

  evalAssert :: Symbolic m -> m (Symbolic m) -> m (Symbolic m)
evalAssert Symbolic m
cond m (Symbolic m)
body =
    do
      Symbolic m
body' <- m (Symbolic m)
body
      let e :: NExprF (Symbolic m)
e = Symbolic m -> Symbolic m -> NExprF (Symbolic m)
forall r. r -> r -> NExprF r
NAssert Symbolic m
cond Symbolic m
body'
      Symbolic m
_ <- NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
cond (Symbolic m -> m (Symbolic m)) -> m (Symbolic m) -> m (Symbolic m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
      pure Symbolic m
body'

  evalApp :: Symbolic m -> m (Symbolic m) -> m (Symbolic m)
evalApp = (((HashMap Text (Symbolic m), Symbolic m) -> Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m) -> m (Symbolic m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (HashMap Text (Symbolic m), Symbolic m) -> Symbolic m
forall a b. (a, b) -> b
snd (m (HashMap Text (Symbolic m), Symbolic m) -> m (Symbolic m))
-> (m (Symbolic m) -> m (HashMap Text (Symbolic m), Symbolic m))
-> m (Symbolic m)
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((m (Symbolic m) -> m (HashMap Text (Symbolic m), Symbolic m))
 -> m (Symbolic m) -> m (Symbolic m))
-> (Symbolic m
    -> m (Symbolic m) -> m (HashMap Text (Symbolic m), Symbolic m))
-> Symbolic m
-> m (Symbolic m)
-> m (Symbolic m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
lintApp (NBinaryOp -> () -> () -> NExprF ()
forall r. NBinaryOp -> r -> r -> NExprF r
NBinary NBinaryOp
NApp () ())
  evalAbs :: Params (m (Symbolic m))
-> (forall a.
    m (Symbolic m)
    -> (AttrSet (m (Symbolic m))
        -> m (Symbolic m) -> m (a, Symbolic m))
    -> m (a, Symbolic m))
-> m (Symbolic m)
evalAbs Params (m (Symbolic m))
params forall a.
m (Symbolic m)
-> (AttrSet (m (Symbolic m))
    -> m (Symbolic m) -> m (a, Symbolic m))
-> m (a, Symbolic m)
_ = [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [Params () -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Params () -> NTypeF m r
TClosure (Params (m (Symbolic m)) -> Params ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Params (m (Symbolic m))
params)]

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

lintBinaryOp
  :: forall e m
   . (MonadLint e m, MonadEval (Symbolic m) m)
  => NBinaryOp
  -> Symbolic m
  -> m (Symbolic m)
  -> m (Symbolic m)
lintBinaryOp :: forall e (m :: * -> *).
(MonadLint e m, MonadEval (Symbolic m) m) =>
NBinaryOp -> Symbolic m -> m (Symbolic m) -> m (Symbolic m)
lintBinaryOp NBinaryOp
op Symbolic m
lsym m (Symbolic m)
rarg =
  do
    Symbolic m
rsym <- m (Symbolic m)
rarg
    Symbolic m
y    <- m (Symbolic m) -> m (Symbolic m)
forall v (m :: * -> *). MonadValue v m => m v -> m v
defer m (Symbolic m)
forall (m :: * -> *). MonadAtomicRef m => m (Symbolic m)
everyPossible

    case NBinaryOp
op of
      NBinaryOp
NApp    -> Text -> m (Symbolic m)
forall e (m :: * -> *) a. MonadLint e m => Text -> m a
symerr Text
"lintBinaryOp:NApp: should never get here"
      NBinaryOp
_ -> Symbolic m
-> Symbolic m -> [NTypeF m (Symbolic m)] -> m (Symbolic m)
check Symbolic m
lsym Symbolic m
rsym ([NTypeF m (Symbolic m)] -> m (Symbolic m))
-> [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall a b. (a -> b) -> a -> b
$
        case NBinaryOp
op of
          NBinaryOp
NEq     -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull], NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TStr, Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y]
          NBinaryOp
NNEq    -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull], NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TStr, Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y]

          NBinaryOp
NLt     -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
          NBinaryOp
NLte    -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
          NBinaryOp
NGt     -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]
          NBinaryOp
NGte    -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt, TAtom
TBool, TAtom
TNull]]

          NBinaryOp
NAnd    -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
          NBinaryOp
NOr     -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]
          NBinaryOp
NImpl   -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TBool]]

          -- jww (2018-04-01): NYI: Allow Path + Str
          NBinaryOp
NPlus   -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt], NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TStr, NTypeF m (Symbolic m)
forall (m :: * -> *) r. NTypeF m r
TPath]
          NBinaryOp
NMinus  -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
          NBinaryOp
NMult   -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]
          NBinaryOp
NDiv    -> [[TAtom] -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. [TAtom] -> NTypeF m r
TConstant [TAtom
TInt]]

          NBinaryOp
NUpdate -> [Maybe (HashMap Text (Symbolic m)) -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. Maybe (HashMap Text r) -> NTypeF m r
TSet Maybe (HashMap Text (Symbolic m))
forall a. Monoid a => a
mempty]

          NBinaryOp
NConcat -> [Symbolic m -> NTypeF m (Symbolic m)
forall (m :: * -> *) r. r -> NTypeF m r
TList Symbolic m
y]
#if __GLASGOW_HASKELL__ < 900
          _ -> fail "Should not be possible"  -- 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

      Symbolic m
m <- [NTypeF m (Symbolic m)] -> m (Symbolic m)
forall (m :: * -> *).
MonadAtomicRef m =>
[NTypeF m (Symbolic m)] -> m (Symbolic m)
mkSymbolic [NTypeF m (Symbolic m)]
xs
      Symbolic m
_ <- NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
lsym Symbolic m
m
      Symbolic m
_ <- NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
rsym Symbolic m
m
      NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
forall e (m :: * -> *).
MonadLint e m =>
NExprF () -> Symbolic m -> Symbolic m -> m (Symbolic m)
unify (NExprF (Symbolic m) -> NExprF ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void NExprF (Symbolic m)
e) Symbolic m
lsym Symbolic m
rsym

infixl 1 `lintApp`
lintApp
  :: forall e m
   . MonadLint e m
  => NExprF ()
  -> Symbolic m
  -> m (Symbolic m)
  -> m (HashMap VarName (Symbolic m), Symbolic m)
lintApp :: forall e (m :: * -> *).
MonadLint e m =>
NExprF ()
-> Symbolic m
-> m (Symbolic m)
-> m (HashMap Text (Symbolic m), Symbolic m)
lintApp NExprF ()
context Symbolic m
fun m (Symbolic m)
arg = Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic Symbolic m
fun m (NSymbolicF (NTypeF m (Symbolic m)))
-> (NSymbolicF (NTypeF m (Symbolic m))
    -> m (HashMap Text (Symbolic m), Symbolic m))
-> m (HashMap Text (Symbolic m), Symbolic m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  NSymbolicF (NTypeF m (Symbolic m))
NAny ->
    ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Cannot apply something not known to be a function"
  NMany [NTypeF m (Symbolic m)]
xs -> do
    ([HashMap Text (Symbolic m)]
args, [Symbolic m]
ys) <- ([(HashMap Text (Symbolic m), Symbolic m)]
 -> ([HashMap Text (Symbolic m)], [Symbolic m]))
-> m [(HashMap Text (Symbolic m), Symbolic m)]
-> m ([HashMap Text (Symbolic m)], [Symbolic m])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(HashMap Text (Symbolic m), Symbolic m)]
-> ([HashMap Text (Symbolic m)], [Symbolic m])
forall a b. [(a, b)] -> ([a], [b])
unzip (m [(HashMap Text (Symbolic m), Symbolic m)]
 -> m ([HashMap Text (Symbolic m)], [Symbolic m]))
-> m [(HashMap Text (Symbolic m), Symbolic m)]
-> m ([HashMap Text (Symbolic m)], [Symbolic m])
forall a b. (a -> b) -> a -> b
$ [NTypeF m (Symbolic m)]
-> (NTypeF m (Symbolic m)
    -> m (HashMap Text (Symbolic m), Symbolic m))
-> m [(HashMap Text (Symbolic m), Symbolic m)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NTypeF m (Symbolic m)]
xs ((NTypeF m (Symbolic m)
  -> m (HashMap Text (Symbolic m), Symbolic m))
 -> m [(HashMap Text (Symbolic m), Symbolic m)])
-> (NTypeF m (Symbolic m)
    -> m (HashMap Text (Symbolic m), Symbolic m))
-> m [(HashMap Text (Symbolic m), Symbolic m)]
forall a b. (a -> b) -> a -> b
$ \case
      TClosure Params ()
_params -> m (Symbolic m)
arg m (Symbolic m)
-> (Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m))))
-> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
forall (m :: * -> *).
(MonadAtomicRef m, MonadThunkId m, MonadCatch m) =>
Symbolic m -> m (NSymbolicF (NTypeF m (Symbolic m)))
unpackSymbolic m (NSymbolicF (NTypeF m (Symbolic m)))
-> (NSymbolicF (NTypeF m (Symbolic m))
    -> m (HashMap Text (Symbolic m), Symbolic m))
-> m (HashMap Text (Symbolic m), Symbolic m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        NSymbolicF (NTypeF m (Symbolic m))
NAny -> do
          Text -> m (HashMap Text (Symbolic m), Symbolic m)
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"NYI"

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

        NMany [NTypeF m (Symbolic m)]
_ -> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp NMany not set"
      TBuiltin Text
_ Symbolic m -> m (Symbolic m)
_f -> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp builtin"
      TSet Maybe (HashMap Text (Symbolic m))
_m       -> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"NYI: lintApp Set"
      NTypeF m (Symbolic m)
_x            -> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m))
-> ErrorCall -> m (HashMap Text (Symbolic m), Symbolic m)
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall String
"Attempt to call non-function"

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

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

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

instance MonadCatch (Lint s) where
  catch :: forall e a. Exception e => Lint s a -> (e -> Lint s a) -> Lint s a
catch Lint s a
_m e -> Lint s a
_h = ReaderT
  (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall s a.
ReaderT
  (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
Lint (ReaderT
   (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
 -> Lint s a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Lint s a
forall a b. (a -> b) -> a -> b
$ (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
 -> ReaderT
      (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a)
-> (Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall a b. (a -> b) -> a -> b
$ \Context (Lint s) (Symbolic (Lint s))
_ -> String -> FreshIdT Int (ST s) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Cannot catch in 'Lint s'"

runLintM :: Options -> Lint s a -> ST s a
runLintM :: forall s a. Options -> Lint s a -> ST s a
runLintM Options
opts Lint s a
action = do
  STRef s Int
i <- Int -> ST s (Ref (ST s) Int)
forall (m :: * -> *) a. MonadRef m => a -> m (Ref m a)
newRef (Int
1 :: Int)
  Ref (ST s) Int -> FreshIdT Int (ST s) a -> ST s a
forall (m :: * -> *) i a.
Functor m =>
Ref m i -> FreshIdT i m a -> m a
runFreshIdT STRef s Int
Ref (ST s) Int
i (FreshIdT Int (ST s) a -> ST s a)
-> FreshIdT Int (ST s) a -> ST s a
forall a b. (a -> b) -> a -> b
$ (ReaderT
  (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> Context (Lint s) (Symbolic (Lint s)) -> FreshIdT Int (ST s) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Options -> Context (Lint s) (Symbolic (Lint s))
forall (m :: * -> *) t. Options -> Context m t
newContext Options
opts) (ReaderT
   (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
 -> FreshIdT Int (ST s) a)
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
-> FreshIdT Int (ST s) a
forall a b. (a -> b) -> a -> b
$ Lint s a
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
forall s a.
Lint s a
-> ReaderT
     (Context (Lint s) (Symbolic (Lint s))) (FreshIdT Int (ST s)) a
runLint Lint s a
action

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

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

      Scopes (Lint s) (Symbolic (Lint s))
-> Lint s (Symbolic (Lint s)) -> Lint s (Symbolic (Lint s))
forall a (m :: * -> *) r. Scoped a m => Scopes m a -> m r -> m r
pushScopes
        Scopes (Lint s) (Symbolic (Lint s))
basis
        (Transform NExprLocF (Lint s (Symbolic (Lint s)))
-> Alg NExprLocF (Lint s (Symbolic (Lint s)))
-> NExprLoc
-> Lint s (Symbolic (Lint s))
forall (f :: * -> *) a.
Functor f =>
Transform f a -> Alg f a -> Fix f -> a
adi
          Transform NExprLocF (Lint s (Symbolic (Lint s)))
forall e (m :: * -> *) a.
(MonadReader e m, Has e SrcSpan) =>
Transform NExprLocF (m a)
Eval.addSourcePositions
          Alg NExprLocF (Lint s (Symbolic (Lint s)))
forall v (m :: * -> *) ann.
MonadNixEval v m =>
AnnF ann NExprF (m v) -> m v
Eval.evalContent
          NExprLoc
expr
        )

instance
  Scoped (Symbolic (Lint s)) (Lint s) where
  currentScopes :: Lint s (Scopes (Lint s) (Symbolic (Lint s)))
currentScopes = Lint s (Scopes (Lint s) (Symbolic (Lint s)))
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
m (Scopes m a)
currentScopesReader
  clearScopes :: forall r. Lint s r -> Lint s r
clearScopes   = forall (m :: * -> *) a e r.
(MonadReader e m, Has e (Scopes m a)) =>
m r -> m r
clearScopesReader @(Lint s) @(Symbolic (Lint s))
  pushScopes :: forall r.
Scopes (Lint s) (Symbolic (Lint s)) -> Lint s r -> Lint s r
pushScopes    = Scopes (Lint s) (Symbolic (Lint s)) -> Lint s r -> Lint s r
forall e (m :: * -> *) a r.
(MonadReader e m, Has e (Scopes m a)) =>
Scopes m a -> m r -> m r
pushScopesReader
  lookupVar :: Text -> Lint s (Maybe (Symbolic (Lint s)))
lookupVar     = Text -> Lint s (Maybe (Symbolic (Lint s)))
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
Text -> m (Maybe a)
lookupVarReader