{-# language CPP #-}
{-# language AllowAmbiguousTypes #-}
{-# language ConstraintKinds #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language PartialTypeSignatures #-}
{-# language TypeFamilies #-}

{-# options_ghc -fno-warn-name-shadowing #-}


-- | This module provides a "reducing" expression evaluator, which reduces
--   away pure, non self-referential aspects of an expression tree, yielding a
--   new expression tree. It does not yet attempt to reduce everything
--   possible, and will always yield a tree with the same meaning as the
--   original. It should be seen as an opportunistic simplifier, but which
--   gives up easily if faced with any potential for ambiguity in the result.

module Nix.Reduce
  ( reduceExpr
  , reducingEvalExpr
  ) where

import           Nix.Prelude
import           Control.Monad.Catch            ( MonadCatch(catch) )
#if !MIN_VERSION_base(4,12,0)
import           Prelude                 hiding ( fail )
import           Control.Monad.Fail
#endif
import           Control.Monad.Fix              ( MonadFix )
import           Data.Fix                       ( Fix(..)
                                                , foldFix
                                                , foldFixM
                                                )
import qualified Data.HashMap.Internal         as HM
                                                ( lookup
                                                , insert
                                                , singleton
                                                , fromList
                                                )
import qualified Data.List.NonEmpty            as NE
import qualified Text.Show
import           Nix.Atoms
import           Nix.Effects.Basic              ( pathToDefaultNixFile )
import           Nix.Expr.Types
import           Nix.Expr.Types.Annotated
import           Nix.Frames
import           Nix.Options                    ( Options
                                                , isReduceSets
                                                , isReduceLists
                                                , askOptions
                                                )
import           Nix.Parser
import           Nix.Scope
import           System.Directory

newtype Reducer m a = Reducer
    { forall (m :: * -> *) a.
Reducer m a
-> ReaderT
     (Maybe Path, Scopes (Reducer m) NExprLoc)
     (StateT (HashMap Path NExprLoc, HashMap Text Text) m)
     a
runReducer ::
        ReaderT
          ( Maybe Path
          , Scopes (Reducer m) NExprLoc
          )
          ( StateT
              ( HashMap Path NExprLoc
              , HashMap Text Text
              )
            m
          )
          a
    }
  deriving
    ( forall a b. a -> Reducer m b -> Reducer m a
forall a b. (a -> b) -> Reducer m a -> Reducer m b
forall (m :: * -> *) a b.
Functor m =>
a -> Reducer m b -> Reducer m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Reducer m a -> Reducer 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 -> Reducer m b -> Reducer m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> Reducer m b -> Reducer m a
fmap :: forall a b. (a -> b) -> Reducer m a -> Reducer m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Reducer m a -> Reducer m b
Functor, forall a. a -> Reducer m a
forall a b. Reducer m a -> Reducer m b -> Reducer m a
forall a b. Reducer m a -> Reducer m b -> Reducer m b
forall a b. Reducer m (a -> b) -> Reducer m a -> Reducer m b
forall a b c.
(a -> b -> c) -> Reducer m a -> Reducer m b -> Reducer m c
forall {m :: * -> *}. Monad m => Functor (Reducer m)
forall (m :: * -> *) a. Monad m => a -> Reducer m a
forall (m :: * -> *) a b.
Monad m =>
Reducer m a -> Reducer m b -> Reducer m a
forall (m :: * -> *) a b.
Monad m =>
Reducer m a -> Reducer m b -> Reducer m b
forall (m :: * -> *) a b.
Monad m =>
Reducer m (a -> b) -> Reducer m a -> Reducer m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Reducer m a -> Reducer m b -> Reducer m 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. Reducer m a -> Reducer m b -> Reducer m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
Reducer m a -> Reducer m b -> Reducer m a
*> :: forall a b. Reducer m a -> Reducer m b -> Reducer m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
Reducer m a -> Reducer m b -> Reducer m b
liftA2 :: forall a b c.
(a -> b -> c) -> Reducer m a -> Reducer m b -> Reducer m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> Reducer m a -> Reducer m b -> Reducer m c
<*> :: forall a b. Reducer m (a -> b) -> Reducer m a -> Reducer m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
Reducer m (a -> b) -> Reducer m a -> Reducer m b
pure :: forall a. a -> Reducer m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> Reducer m a
Applicative, forall a. Reducer m a
forall a. Reducer m a -> Reducer m [a]
forall a. Reducer m a -> Reducer m a -> Reducer m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall {m :: * -> *}. MonadPlus m => Applicative (Reducer m)
forall (m :: * -> *) a. MonadPlus m => Reducer m a
forall (m :: * -> *) a. MonadPlus m => Reducer m a -> Reducer m [a]
forall (m :: * -> *) a.
MonadPlus m =>
Reducer m a -> Reducer m a -> Reducer m a
many :: forall a. Reducer m a -> Reducer m [a]
$cmany :: forall (m :: * -> *) a. MonadPlus m => Reducer m a -> Reducer m [a]
some :: forall a. Reducer m a -> Reducer m [a]
$csome :: forall (m :: * -> *) a. MonadPlus m => Reducer m a -> Reducer m [a]
<|> :: forall a. Reducer m a -> Reducer m a -> Reducer m a
$c<|> :: forall (m :: * -> *) a.
MonadPlus m =>
Reducer m a -> Reducer m a -> Reducer m a
empty :: forall a. Reducer m a
$cempty :: forall (m :: * -> *) a. MonadPlus m => Reducer m a
Alternative
    , forall a. a -> Reducer m a
forall a b. Reducer m a -> Reducer m b -> Reducer m b
forall a b. Reducer m a -> (a -> Reducer m b) -> Reducer m b
forall (m :: * -> *). Monad m => Applicative (Reducer m)
forall (m :: * -> *) a. Monad m => a -> Reducer m a
forall (m :: * -> *) a b.
Monad m =>
Reducer m a -> Reducer m b -> Reducer m b
forall (m :: * -> *) a b.
Monad m =>
Reducer m a -> (a -> Reducer m b) -> Reducer m 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 -> Reducer m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> Reducer m a
>> :: forall a b. Reducer m a -> Reducer m b -> Reducer m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
Reducer m a -> Reducer m b -> Reducer m b
>>= :: forall a b. Reducer m a -> (a -> Reducer m b) -> Reducer m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
Reducer m a -> (a -> Reducer m b) -> Reducer m b
Monad, forall a. Reducer m a
forall a. Reducer m a -> Reducer m a -> Reducer m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
forall {m :: * -> *}. MonadPlus m => Monad (Reducer m)
forall (m :: * -> *). MonadPlus m => Alternative (Reducer m)
forall (m :: * -> *) a. MonadPlus m => Reducer m a
forall (m :: * -> *) a.
MonadPlus m =>
Reducer m a -> Reducer m a -> Reducer m a
mplus :: forall a. Reducer m a -> Reducer m a -> Reducer m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
Reducer m a -> Reducer m a -> Reducer m a
mzero :: forall a. Reducer m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => Reducer m a
MonadPlus, forall a. (a -> Reducer m a) -> Reducer m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall {m :: * -> *}. MonadFix m => Monad (Reducer m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> Reducer m a) -> Reducer m a
mfix :: forall a. (a -> Reducer m a) -> Reducer m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> Reducer m a) -> Reducer m a
MonadFix, forall a. IO a -> Reducer m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (Reducer m)
forall (m :: * -> *) a. MonadIO m => IO a -> Reducer m a
liftIO :: forall a. IO a -> Reducer m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> Reducer m a
MonadIO, forall a. String -> Reducer m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall {m :: * -> *}. MonadFail m => Monad (Reducer m)
forall (m :: * -> *) a. MonadFail m => String -> Reducer m a
fail :: forall a. String -> Reducer m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> Reducer m a
MonadFail
    , MonadReader (Maybe Path, Scopes (Reducer m) NExprLoc)
    , MonadState (HashMap Path NExprLoc, HashMap Text Text)
    )

staticImport
  :: forall m
   . ( MonadIO m
     , Scoped NExprLoc m
     , MonadFail m
     , MonadReader (Maybe Path, Scopes m NExprLoc) m
     , MonadState (HashMap Path NExprLoc, HashMap Text Text) m
     )
  => SrcSpan
  -> Path
  -> m NExprLoc
staticImport :: forall (m :: * -> *).
(MonadIO m, Scoped NExprLoc m, MonadFail m,
 MonadReader (Maybe Path, Scopes m NExprLoc) m,
 MonadState (HashMap Path NExprLoc, HashMap Text Text) m) =>
SrcSpan -> Path -> m NExprLoc
staticImport SrcSpan
pann Path
path =
  do
    Maybe Path
mfile <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a, b) -> a
fst
    Path
path'  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadFile m => Path -> m Path
pathToDefaultNixFile Path
path
    Path
path'' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadFile m => Path -> m Path
pathToDefaultNixFile forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< coerce :: forall a b. Coercible a b => a -> b
coerce String -> IO String
canonicalizePath
      (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (Path -> Path -> Path
(</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Path
takeDirectory) Maybe Path
mfile Path
path')

    let
      importIt :: m NExprLoc
      importIt :: m NExprLoc
importIt = do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Importing file " forall a. Semigroup a => a -> a -> a
<> coerce :: forall a b. Coercible a b => a -> b
coerce Path
path''

        Result NExprLoc
eres <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadFile m => Path -> m (Result NExprLoc)
parseNixFileLoc Path
path''
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (\ Doc Void
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Parse failed: " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Doc Void
err)
          (\ NExprLoc
x -> do
            let
              pos :: NSourcePos
pos  = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Path -> NPos -> NPos -> NSourcePos
NSourcePos Path
"Reduce.hs") forall a b. (a -> b) -> a -> b
$ (coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pos
mkPos) Int
1
              span :: SrcSpan
span = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join NSourcePos -> NSourcePos -> SrcSpan
SrcSpan NSourcePos
pos
              cur :: Binding NExprLoc
cur  =
                forall r. NAttrPath r -> r -> NSourcePos -> Binding r
NamedVar
                  (forall x. One x => OneItem x -> x
one forall a b. (a -> b) -> a -> b
$ forall r. VarName -> NKeyName r
StaticKey VarName
"__cur_file")
                  (SrcSpan -> Path -> NExprLoc
NLiteralPathAnn SrcSpan
pann Path
path'')
                  NSourcePos
pos
              x' :: NExprLoc
x' = SrcSpan -> [Binding NExprLoc] -> NExprLoc -> NExprLoc
NLetAnn SrcSpan
span (forall x. One x => OneItem x -> x
one Binding NExprLoc
cur) NExprLoc
x
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Path
path'' NExprLoc
x'
            forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
              (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure Path
path'', forall a. Monoid a => a
mempty)) forall a b. (a -> b) -> a -> b
$
              do
                NExprLoc
x'' <- forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix forall (m :: * -> *).
(MonadIO m, Scoped NExprLoc m, MonadFail m,
 MonadReader (Maybe Path, Scopes m NExprLoc) m,
 MonadState (HashMap Path NExprLoc, HashMap Text Text) m) =>
NExprLocF (m NExprLoc) -> m NExprLoc
reduce NExprLoc
x'
                forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Path
path'' NExprLoc
x''
                pure NExprLoc
x''
          )
          Result NExprLoc
eres

    HashMap Path NExprLoc
imports <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> a
fst
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      m NExprLoc
importIt
      forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Path
path'' HashMap Path NExprLoc
imports)

-- gatherNames :: NExprLoc -> HashSet VarName
-- gatherNames = foldFix $ \case
--     NSymAnnF _ var -> S.singleton var
--     AnnF _ x -> fold x

reduceExpr
  :: (MonadIO m, MonadFail m) => Maybe Path -> NExprLoc -> m NExprLoc
reduceExpr :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Maybe Path -> NExprLoc -> m NExprLoc
reduceExpr Maybe Path
mpath NExprLoc
expr =
  (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` forall a. Monoid a => a
mempty)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` (Maybe Path
mpath, forall a. Monoid a => a
mempty))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Reducer m a
-> ReaderT
     (Maybe Path, Scopes (Reducer m) NExprLoc)
     (StateT (HashMap Path NExprLoc, HashMap Text Text) m)
     a
runReducer
    forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix forall (m :: * -> *).
(MonadIO m, Scoped NExprLoc m, MonadFail m,
 MonadReader (Maybe Path, Scopes m NExprLoc) m,
 MonadState (HashMap Path NExprLoc, HashMap Text Text) m) =>
NExprLocF (m NExprLoc) -> m NExprLoc
reduce NExprLoc
expr

reduce
  :: forall m
   . ( MonadIO m
     , Scoped NExprLoc m
     , MonadFail m
     , MonadReader (Maybe Path, Scopes m NExprLoc) m
     , MonadState (HashMap Path NExprLoc, HashMap Text Text) m
     )
  => NExprLocF (m NExprLoc)
  -> m NExprLoc

-- | Reduce the variable to its value if defined.
--   Leave it as it is otherwise.
reduce :: forall (m :: * -> *).
(MonadIO m, Scoped NExprLoc m, MonadFail m,
 MonadReader (Maybe Path, Scopes m NExprLoc) m,
 MonadState (HashMap Path NExprLoc, HashMap Text Text) m) =>
NExprLocF (m NExprLoc) -> m NExprLoc
reduce (NSymAnnF SrcSpan
ann VarName
var) =
  forall a. a -> Maybe a -> a
fromMaybe (SrcSpan -> VarName -> NExprLoc
NSymAnn SrcSpan
ann VarName
var) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). Scoped a m => VarName -> m (Maybe a)
lookupVar VarName
var

-- | Reduce binary and integer negation.
reduce (NUnaryAnnF SrcSpan
uann NUnaryOp
op m NExprLoc
arg) =
  do
    NExprLoc
x <- m NExprLoc
arg
    pure $
      case (NUnaryOp
op, NExprLoc
x) of
        (NUnaryOp
NNeg, NConstantAnn SrcSpan
cann (NInt  Integer
n)) -> SrcSpan -> NAtom -> NExprLoc
NConstantAnn SrcSpan
cann forall a b. (a -> b) -> a -> b
$ Integer -> NAtom
NInt forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate Integer
n
        (NUnaryOp
NNot, NConstantAnn SrcSpan
cann (NBool Bool
b)) -> SrcSpan -> NAtom -> NExprLoc
NConstantAnn SrcSpan
cann forall a b. (a -> b) -> a -> b
$ Bool -> NAtom
NBool forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
b
        (NUnaryOp, NExprLoc)
_                                   -> SrcSpan -> NUnaryOp -> NExprLoc -> NExprLoc
NUnaryAnn    SrcSpan
uann NUnaryOp
op NExprLoc
x

-- | Reduce function applications.
--
--     * Reduce an import to the actual imported expression.
--
--     * Reduce a lambda function by adding its name to the local
--       scope and recursively reducing its body.
reduce (NAppAnnF SrcSpan
bann m NExprLoc
fun m NExprLoc
arg) =
  (\case
    f :: NExprLoc
f@(NSymAnn SrcSpan
_ VarName
"import") ->
      (\case
          -- NEnvPathAnn     pann origPath -> staticImport pann origPath
        NLiteralPathAnn SrcSpan
pann Path
origPath -> forall (m :: * -> *).
(MonadIO m, Scoped NExprLoc m, MonadFail m,
 MonadReader (Maybe Path, Scopes m NExprLoc) m,
 MonadState (HashMap Path NExprLoc, HashMap Text Text) m) =>
SrcSpan -> Path -> m NExprLoc
staticImport SrcSpan
pann Path
origPath
        NExprLoc
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SrcSpan -> NExprLoc -> NExprLoc -> NExprLoc
NAppAnn SrcSpan
bann NExprLoc
f NExprLoc
v
      ) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m NExprLoc
arg

    NAbsAnn SrcSpan
_ (Param VarName
name) NExprLoc
body ->
      do
        NExprLoc
x <- m NExprLoc
arg
        forall a (m :: * -> *) r. Scoped a m => Scope a -> m r -> m r
pushScope
          (coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton VarName
name NExprLoc
x)
          (forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix forall (m :: * -> *).
(MonadIO m, Scoped NExprLoc m, MonadFail m,
 MonadReader (Maybe Path, Scopes m NExprLoc) m,
 MonadState (HashMap Path NExprLoc, HashMap Text Text) m) =>
NExprLocF (m NExprLoc) -> m NExprLoc
reduce NExprLoc
body)

    NExprLoc
f -> SrcSpan -> NExprLoc -> NExprLoc -> NExprLoc
NAppAnn SrcSpan
bann NExprLoc
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m NExprLoc
arg
  ) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m NExprLoc
fun

-- | Reduce an integer addition to its result.
reduce (NBinaryAnnF SrcSpan
bann NBinaryOp
op m NExprLoc
larg m NExprLoc
rarg) =
  do
    NExprLoc
lval <- m NExprLoc
larg
    NExprLoc
rval <- m NExprLoc
rarg
    pure $
      case (NBinaryOp
op, NExprLoc
lval, NExprLoc
rval) of
        (NBinaryOp
NPlus, NConstantAnn SrcSpan
ann (NInt Integer
x), NConstantAnn SrcSpan
_ (NInt Integer
y)) -> SrcSpan -> NAtom -> NExprLoc
NConstantAnn SrcSpan
ann  forall a b. (a -> b) -> a -> b
$ Integer -> NAtom
NInt forall a b. (a -> b) -> a -> b
$ Integer
x forall a. Num a => a -> a -> a
+ Integer
y
        (NBinaryOp, NExprLoc, NExprLoc)
_                                                           -> SrcSpan -> NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc
NBinaryAnn   SrcSpan
bann NBinaryOp
op NExprLoc
lval NExprLoc
rval

-- | Reduce a select on a Set by substituting the set to the selected value.
--
-- Before applying this reduction, we need to ensure that:
--
--   1. The selected expr is indeed a set.
--   2. The selection AttrPath is a list of StaticKeys.
--   3. The selected AttrPath exists in the set.
reduce base :: NExprLocF (m NExprLoc)
base@(NSelectAnnF SrcSpan
_ Maybe (m NExprLoc)
_ m NExprLoc
_ NAttrPath (m NExprLoc)
attrs)
  | forall {r}. [NKeyName r] -> Bool
sAttrPath forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NAttrPath (m NExprLoc)
attrs = do
    (NSelectAnnF SrcSpan
_ Maybe NExprLoc
_ NExprLoc
aset NAttrPath NExprLoc
attrs) <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA NExprLocF (m NExprLoc)
base
    NExprLocF NExprLoc -> NAttrPath NExprLoc -> m NExprLoc
inspectSet (forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
aset) NAttrPath NExprLoc
attrs
  | Bool
otherwise = m NExprLoc
sId
 where
  sId :: m NExprLoc
sId = forall (f1 :: * -> *) (f2 :: * -> *).
(Traversable f1, Applicative f2) =>
f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer NExprLocF (m NExprLoc)
base
  -- The selection AttrPath is composed of StaticKeys.
  sAttrPath :: [NKeyName r] -> Bool
sAttrPath (StaticKey VarName
_ : [NKeyName r]
xs) = [NKeyName r] -> Bool
sAttrPath [NKeyName r]
xs
  sAttrPath []                 = Bool
True
  sAttrPath [NKeyName r]
_                  = Bool
False
  -- Find appropriate bind in set's binds.
  findBind :: [Binding r] -> NonEmpty (NKeyName r) -> Maybe (Binding r)
findBind []   NonEmpty (NKeyName r)
_              = forall a. Maybe a
Nothing
  findBind (Binding r
x : [Binding r]
xs) attrs :: NonEmpty (NKeyName r)
attrs@(NKeyName r
a :| [NKeyName r]
_) = case Binding r
x of
    n :: Binding r
n@(NamedVar (NKeyName r
a' :| [NKeyName r]
_) r
_ NSourcePos
_) | NKeyName r
a' forall a. Eq a => a -> a -> Bool
== NKeyName r
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Binding r
n
    Binding r
_ -> [Binding r] -> NonEmpty (NKeyName r) -> Maybe (Binding r)
findBind [Binding r]
xs NonEmpty (NKeyName r)
attrs
  -- Follow the attrpath recursively in sets.
  inspectSet :: NExprLocF NExprLoc -> NAttrPath NExprLoc -> m NExprLoc
inspectSet (NSetAnnF SrcSpan
_ Recursivity
NonRecursive [Binding NExprLoc]
binds) NAttrPath NExprLoc
attrs = case forall {r}.
Eq r =>
[Binding r] -> NonEmpty (NKeyName r) -> Maybe (Binding r)
findBind [Binding NExprLoc]
binds NAttrPath NExprLoc
attrs of
    Just (NamedVar NAttrPath NExprLoc
_ NExprLoc
e NSourcePos
_) -> case forall a. NonEmpty a -> (a, Maybe (NonEmpty a))
NE.uncons NAttrPath NExprLoc
attrs of
      (NKeyName NExprLoc
_, Just NAttrPath NExprLoc
attrs) -> NExprLocF NExprLoc -> NAttrPath NExprLoc -> m NExprLoc
inspectSet (forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
e) NAttrPath NExprLoc
attrs
      (NKeyName NExprLoc, Maybe (NAttrPath NExprLoc))
_               -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprLoc
e
    Maybe (Binding NExprLoc)
_ -> m NExprLoc
sId
  inspectSet NExprLocF NExprLoc
_ NAttrPath NExprLoc
_ = m NExprLoc
sId

-- reduce (NHasAttr aset attr) =

-- | Reduce a set by inlining its binds outside of the set
--   if none of the binds inherit the super set.
reduce e :: NExprLocF (m NExprLoc)
e@(NSetAnnF SrcSpan
ann Recursivity
r [Binding (m NExprLoc)]
binds) =
  forall a. a -> a -> Bool -> a
bool
    -- Encountering a 'rec set' construction eliminates any hope of inlining
    -- definitions.
    m NExprLoc
mExprLoc
    (forall a. a -> a -> Bool -> a
bool
      (forall (f1 :: * -> *) (f2 :: * -> *).
(Traversable f1, Applicative f2) =>
f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer NExprLocF (m NExprLoc)
e)
      m NExprLoc
mExprLoc
      Bool
usesInherit
    )
    (Recursivity
r forall a. Eq a => a -> a -> Bool
== Recursivity
NonRecursive)
 where
  mExprLoc :: m NExprLoc
  mExprLoc :: m NExprLoc
mExprLoc =
    forall a (m :: * -> *) r. Scoped a m => m r -> m r
clearScopes @NExprLoc forall a b. (a -> b) -> a -> b
$ SrcSpan -> Recursivity -> [Binding NExprLoc] -> NExprLoc
NSetAnn SrcSpan
ann Recursivity
r forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Binding (m NExprLoc)]
binds

  usesInherit :: Bool
usesInherit =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
      (\case
        Inherit{} -> Bool
True
        Binding (m NExprLoc)
_         -> Bool
False
      )
      [Binding (m NExprLoc)]
binds

-- Encountering a 'with' construction eliminates any hope of inlining
-- definitions.
reduce (NWithAnnF SrcSpan
ann m NExprLoc
scope m NExprLoc
body) =
  forall a (m :: * -> *) r. Scoped a m => m r -> m r
clearScopes @NExprLoc forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (SrcSpan -> NExprLoc -> NExprLoc -> NExprLoc
NWithAnn SrcSpan
ann) m NExprLoc
scope m NExprLoc
body

-- | Reduce a let binds section by pushing lambdas,
--   constants and strings to the body scope.
reduce (NLetAnnF SrcSpan
ann [Binding (m NExprLoc)]
binds m NExprLoc
body) =
  do
    [Binding NExprLoc]
binds' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Binding (m NExprLoc)]
binds
    NExprLoc
body'  <-
      (forall a (m :: * -> *) r. Scoped a m => Scope a -> m r -> m r
`pushScope` m NExprLoc
body) forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
          (\case
            NamedVar (StaticKey VarName
name :| []) m NExprLoc
def NSourcePos
_pos ->
              let
                defcase :: NExprLoc -> Maybe (VarName, NExprLoc)
defcase =
                  \case
                    d :: NExprLoc
d@NAbsAnn     {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarName
name, NExprLoc
d)
                    d :: NExprLoc
d@NConstantAnn{} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarName
name, NExprLoc
d)
                    d :: NExprLoc
d@NStrAnn     {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarName
name, NExprLoc
d)
                    NExprLoc
_                -> forall a. Maybe a
Nothing
              in
              NExprLoc -> Maybe (VarName, NExprLoc)
defcase forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m NExprLoc
def

            Binding (m NExprLoc)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          )
          [Binding (m NExprLoc)]
binds

    -- let names = gatherNames body'
    -- binds' <- traverse sequenceA binds <&> \b -> flip filter b $ \case
    --     NamedVar (StaticKey name _ :| []) _ ->
    --         name `S.member` names
    --     _ -> True
    pure $ SrcSpan -> [Binding NExprLoc] -> NExprLoc -> NExprLoc
NLetAnn SrcSpan
ann [Binding NExprLoc]
binds' NExprLoc
body'
    -- where
    --   go m [] = pure m
    --   go m (x:xs) = case x of
    --       NamedVar (StaticKey name _ :| []) def -> do
    --           v <- pushScope m def
    --           go (M.insert name v m) xs
    --       _ -> go m xs

-- | Reduce an if to the relevant path if
--   the condition is a boolean constant.
reduce e :: NExprLocF (m NExprLoc)
e@(NIfAnnF SrcSpan
_ m NExprLoc
b m NExprLoc
t m NExprLoc
f) =
  (\case
    NConstantAnn SrcSpan
_ (NBool Bool
b') -> forall a. a -> a -> Bool -> a
bool m NExprLoc
f m NExprLoc
t Bool
b'
    NExprLoc
_                         -> forall (f1 :: * -> *) (f2 :: * -> *).
(Traversable f1, Applicative f2) =>
f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer NExprLocF (m NExprLoc)
e
  ) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m NExprLoc
b

-- | Reduce an assert atom to its encapsulated
--   symbol if the assertion is a boolean constant.
reduce e :: NExprLocF (m NExprLoc)
e@(NAssertAnnF SrcSpan
_ m NExprLoc
b m NExprLoc
body) =
  (\case
    NConstantAnn SrcSpan
_ (NBool Bool
True) -> m NExprLoc
body
    NExprLoc
_ -> forall (f1 :: * -> *) (f2 :: * -> *).
(Traversable f1, Applicative f2) =>
f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer NExprLocF (m NExprLoc)
e
  ) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m NExprLoc
b

reduce (NAbsAnnF SrcSpan
ann Params (m NExprLoc)
params m NExprLoc
body) = do
  Params NExprLoc
params' <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA Params (m NExprLoc)
params
  -- Make sure that variable definitions in scope do not override function
  -- arguments.
  let
    scope :: Scope NExprLoc
scope = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$
      case Params NExprLoc
params' of
        Param    VarName
name     -> forall x. One x => OneItem x -> x
one (VarName
name, SrcSpan -> VarName -> NExprLoc
NSymAnn SrcSpan
ann VarName
name)
        ParamSet Maybe VarName
_ Variadic
_ ParamSet NExprLoc
pset ->
          forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall a b. (a -> b) -> a -> b
$ (\(VarName
k, Maybe NExprLoc
_) -> (VarName
k, SrcSpan -> VarName -> NExprLoc
NSymAnn SrcSpan
ann VarName
k)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamSet NExprLoc
pset
  SrcSpan -> Params NExprLoc -> NExprLoc -> NExprLoc
NAbsAnn SrcSpan
ann Params NExprLoc
params' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *) r. Scoped a m => Scope a -> m r -> m r
pushScope Scope NExprLoc
scope m NExprLoc
body

reduce NExprLocF (m NExprLoc)
v = forall (f1 :: * -> *) (f2 :: * -> *).
(Traversable f1, Applicative f2) =>
f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer NExprLocF (m NExprLoc)
v

reduceLayer :: (Traversable f1, Applicative f2) => f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer :: forall (f1 :: * -> *) (f2 :: * -> *).
(Traversable f1, Applicative f2) =>
f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer f1 (f2 (Fix f1))
v = forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA f1 (f2 (Fix f1))
v

-- newtype FlaggedF f r = FlaggedF { flagged :: (IORef Bool, f r) }
newtype FlaggedF f r = FlaggedF (IORef Bool, f r)
  deriving (forall a b. a -> FlaggedF f b -> FlaggedF f a
forall a b. (a -> b) -> FlaggedF f a -> FlaggedF f b
forall (f :: * -> *) a b.
Functor f =>
a -> FlaggedF f b -> FlaggedF f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> FlaggedF f a -> FlaggedF f 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 -> FlaggedF f b -> FlaggedF f a
$c<$ :: forall (f :: * -> *) a b.
Functor f =>
a -> FlaggedF f b -> FlaggedF f a
fmap :: forall a b. (a -> b) -> FlaggedF f a -> FlaggedF f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> FlaggedF f a -> FlaggedF f b
Functor, forall a. FlaggedF f a -> Bool
forall m a. Monoid m => (a -> m) -> FlaggedF f a -> m
forall a b. (a -> b -> b) -> b -> FlaggedF f a -> b
forall (f :: * -> *) a.
(Foldable f, Eq a) =>
a -> FlaggedF f a -> Bool
forall (f :: * -> *) a. (Foldable f, Num a) => FlaggedF f a -> a
forall (f :: * -> *) a. (Foldable f, Ord a) => FlaggedF f a -> a
forall (f :: * -> *) m. (Foldable f, Monoid m) => FlaggedF f m -> m
forall (f :: * -> *) a. Foldable f => FlaggedF f a -> Bool
forall (f :: * -> *) a. Foldable f => FlaggedF f a -> Int
forall (f :: * -> *) a. Foldable f => FlaggedF f a -> [a]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> FlaggedF f a -> a
forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> FlaggedF f a -> m
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> FlaggedF f a -> b
forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> FlaggedF f 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 => FlaggedF f a -> a
$cproduct :: forall (f :: * -> *) a. (Foldable f, Num a) => FlaggedF f a -> a
sum :: forall a. Num a => FlaggedF f a -> a
$csum :: forall (f :: * -> *) a. (Foldable f, Num a) => FlaggedF f a -> a
minimum :: forall a. Ord a => FlaggedF f a -> a
$cminimum :: forall (f :: * -> *) a. (Foldable f, Ord a) => FlaggedF f a -> a
maximum :: forall a. Ord a => FlaggedF f a -> a
$cmaximum :: forall (f :: * -> *) a. (Foldable f, Ord a) => FlaggedF f a -> a
elem :: forall a. Eq a => a -> FlaggedF f a -> Bool
$celem :: forall (f :: * -> *) a.
(Foldable f, Eq a) =>
a -> FlaggedF f a -> Bool
length :: forall a. FlaggedF f a -> Int
$clength :: forall (f :: * -> *) a. Foldable f => FlaggedF f a -> Int
null :: forall a. FlaggedF f a -> Bool
$cnull :: forall (f :: * -> *) a. Foldable f => FlaggedF f a -> Bool
toList :: forall a. FlaggedF f a -> [a]
$ctoList :: forall (f :: * -> *) a. Foldable f => FlaggedF f a -> [a]
foldl1 :: forall a. (a -> a -> a) -> FlaggedF f a -> a
$cfoldl1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> FlaggedF f a -> a
foldr1 :: forall a. (a -> a -> a) -> FlaggedF f a -> a
$cfoldr1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> FlaggedF f a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> FlaggedF f a -> b
$cfoldl' :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> FlaggedF f a -> b
foldl :: forall b a. (b -> a -> b) -> b -> FlaggedF f a -> b
$cfoldl :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> FlaggedF f a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> FlaggedF f a -> b
$cfoldr' :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> FlaggedF f a -> b
foldr :: forall a b. (a -> b -> b) -> b -> FlaggedF f a -> b
$cfoldr :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> FlaggedF f a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> FlaggedF f a -> m
$cfoldMap' :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> FlaggedF f a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> FlaggedF f a -> m
$cfoldMap :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> FlaggedF f a -> m
fold :: forall m. Monoid m => FlaggedF f m -> m
$cfold :: forall (f :: * -> *) m. (Foldable f, Monoid m) => FlaggedF f m -> m
Foldable, 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 {f :: * -> *}. Traversable f => Functor (FlaggedF f)
forall {f :: * -> *}. Traversable f => Foldable (FlaggedF f)
forall (f :: * -> *) (m :: * -> *) a.
(Traversable f, Monad m) =>
FlaggedF f (m a) -> m (FlaggedF f a)
forall (f :: * -> *) (f :: * -> *) a.
(Traversable f, Applicative f) =>
FlaggedF f (f a) -> f (FlaggedF f a)
forall (f :: * -> *) (m :: * -> *) a b.
(Traversable f, Monad m) =>
(a -> m b) -> FlaggedF f a -> m (FlaggedF f b)
forall (f :: * -> *) (f :: * -> *) a b.
(Traversable f, Applicative f) =>
(a -> f b) -> FlaggedF f a -> f (FlaggedF f b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FlaggedF f a -> f (FlaggedF f b)
sequence :: forall (m :: * -> *) a.
Monad m =>
FlaggedF f (m a) -> m (FlaggedF f a)
$csequence :: forall (f :: * -> *) (m :: * -> *) a.
(Traversable f, Monad m) =>
FlaggedF f (m a) -> m (FlaggedF f a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FlaggedF f a -> m (FlaggedF f b)
$cmapM :: forall (f :: * -> *) (m :: * -> *) a b.
(Traversable f, Monad m) =>
(a -> m b) -> FlaggedF f a -> m (FlaggedF f b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
FlaggedF f (f a) -> f (FlaggedF f a)
$csequenceA :: forall (f :: * -> *) (f :: * -> *) a.
(Traversable f, Applicative f) =>
FlaggedF f (f a) -> f (FlaggedF f a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FlaggedF f a -> f (FlaggedF f b)
$ctraverse :: forall (f :: * -> *) (f :: * -> *) a b.
(Traversable f, Applicative f) =>
(a -> f b) -> FlaggedF f a -> f (FlaggedF f b)
Traversable)

instance Show (f r) => Show (FlaggedF f r) where
  show :: FlaggedF f r -> String
show (FlaggedF (IORef Bool
_, f r
x)) = forall b a. (Show a, IsString b) => a -> b
show f r
x

type Flagged f = Fix (FlaggedF f)

flagExprLoc :: (MonadIO n, Traversable f) => Fix f -> n (Flagged f)
flagExprLoc :: forall (n :: * -> *) (f :: * -> *).
(MonadIO n, Traversable f) =>
Fix f -> n (Flagged f)
flagExprLoc = forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
foldFixM forall a b. (a -> b) -> a -> b
$ \f (Flagged f)
x -> do
  IORef Bool
flag <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Bool
False
  pure $ coerce :: forall a b. Coercible a b => a -> b
coerce (IORef Bool
flag, f (Flagged f)
x)

-- stripFlags :: Functor f => Flagged f -> Fix f
-- stripFlags = foldFix $ Fix . snd . flagged

pruneTree :: MonadIO n => Options -> Flagged NExprLocF -> n (Maybe NExprLoc)
pruneTree :: forall (n :: * -> *).
MonadIO n =>
Options
-> Flagged (Compose (AnnUnit SrcSpan) NExprF) -> n (Maybe NExprLoc)
pruneTree Options
opts =
  forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
foldFixM forall a b. (a -> b) -> a -> b
$
    \(FlaggedF (IORef Bool
b, Compose AnnUnit SrcSpan (NExprF (Maybe NExprLoc))
x)) ->
      forall a. a -> a -> Bool -> a
bool
        forall a. Maybe a
Nothing
        (forall ann (f :: * -> *). AnnUnit ann (f (Ann ann f)) -> Ann ann f
annUnitToAnn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc)
prune AnnUnit SrcSpan (NExprF (Maybe NExprLoc))
x)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Bool
b)
 where
  prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc)
  prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc)
prune = \case
    NStr NString (Maybe NExprLoc)
str -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. NString r -> NExprF r
NStr forall a b. (a -> b) -> a -> b
$ NString (Maybe NExprLoc) -> NString NExprLoc
pruneString NString (Maybe NExprLoc)
str
    NHasAttr (Just NExprLoc
aset) NAttrPath (Maybe NExprLoc)
attr ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. r -> NAttrPath r -> NExprF r
NHasAttr NExprLoc
aset forall a b. (a -> b) -> a -> b
$ NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NAttrPath (Maybe NExprLoc)
attr
    NAbs Params (Maybe NExprLoc)
params (Just NExprLoc
body) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. Params r -> r -> NExprF r
NAbs (Params (Maybe NExprLoc) -> Params NExprLoc
pruneParams Params (Maybe NExprLoc)
params) NExprLoc
body

    NList [Maybe NExprLoc]
l -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. [r] -> NExprF r
NList forall a b. (a -> b) -> a -> b
$
      forall a. a -> a -> Bool -> a
bool
        (forall a. a -> Maybe a -> a
fromMaybe NExprLoc
annNNull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
        forall a. [Maybe a] -> [a]
catMaybes
        (Options -> Bool
isReduceLists Options
opts)  -- Reduce list members that aren't used; breaks if elemAt is used
        [Maybe NExprLoc]
l
    NSet Recursivity
recur [Binding (Maybe NExprLoc)]
binds -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. Recursivity -> [Binding r] -> NExprF r
NSet Recursivity
recur forall a b. (a -> b) -> a -> b
$
      forall a. a -> a -> Bool -> a
bool
        (forall a. a -> Maybe a -> a
fromMaybe NExprLoc
annNNull forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>>)
        (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA)
        (Options -> Bool
isReduceSets Options
opts)  -- Reduce set members that aren't used; breaks if hasAttr is used
        [Binding (Maybe NExprLoc)]
binds

    NLet [Binding (Maybe NExprLoc)]
binds (Just body :: NExprLoc
body@(Ann SrcSpan
_ NExprF NExprLoc
x)) ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) b a. Foldable t => b -> (t a -> b) -> t a -> b
handlePresence
          NExprF NExprLoc
x
          (forall r. [Binding r] -> r -> NExprF r
`NLet` NExprLoc
body)
          (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
pruneBinding [Binding (Maybe NExprLoc)]
binds)

    NSelect Maybe (Maybe NExprLoc)
alt (Just NExprLoc
aset) NAttrPath (Maybe NExprLoc)
attr ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. Maybe r -> r -> NAttrPath r -> NExprF r
NSelect (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe NExprLoc)
alt) NExprLoc
aset forall a b. (a -> b) -> a -> b
$ NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NAttrPath (Maybe NExprLoc)
attr

    -- If the function was never called, it means its argument was in a
    -- thunk that was forced elsewhere.
    NApp Maybe NExprLoc
Nothing (Just NExprLoc
_) -> forall a. Maybe a
Nothing

    -- These are the only short-circuiting binary operators
    NBinary NBinaryOp
NAnd (Just (Ann SrcSpan
_ NExprF NExprLoc
larg)) Maybe NExprLoc
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
larg
    NBinary NBinaryOp
NOr  (Just (Ann SrcSpan
_ NExprF NExprLoc
larg)) Maybe NExprLoc
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
larg

    -- The idea behind emitted a binary operator where one side may be
    -- invalid is that we're trying to emit what will reproduce whatever
    -- fail the user encountered, which means providing all aspects of
    -- the evaluation path they ultimately followed.
    NBinary NBinaryOp
op Maybe NExprLoc
Nothing (Just NExprLoc
rarg) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. NBinaryOp -> r -> r -> NExprF r
NBinary NBinaryOp
op NExprLoc
annNNull NExprLoc
rarg
    NBinary NBinaryOp
op (Just NExprLoc
larg) Maybe NExprLoc
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. NBinaryOp -> r -> r -> NExprF r
NBinary NBinaryOp
op NExprLoc
larg NExprLoc
annNNull

    -- If the scope of a with was never referenced, it's not needed
    NWith Maybe NExprLoc
Nothing (Just (Ann SrcSpan
_ NExprF NExprLoc
body)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
body

    NAssert Maybe NExprLoc
Nothing Maybe NExprLoc
_              -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"How can an assert be used, but its condition not?"
    NAssert Maybe NExprLoc
_ (Just (Ann SrcSpan
_ NExprF NExprLoc
body)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
body
    NAssert (Just NExprLoc
cond) Maybe NExprLoc
_          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. r -> r -> NExprF r
NAssert NExprLoc
cond NExprLoc
annNNull

    NIf Maybe NExprLoc
Nothing Maybe NExprLoc
_ Maybe NExprLoc
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"How can an if be used, but its condition not?"

    NIf Maybe NExprLoc
_ Maybe NExprLoc
Nothing (Just (Ann SrcSpan
_ NExprF NExprLoc
f)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
f
    NIf Maybe NExprLoc
_ (Just (Ann SrcSpan
_ NExprF NExprLoc
t)) Maybe NExprLoc
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
t

    NExprF (Maybe NExprLoc)
x                     -> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA NExprF (Maybe NExprLoc)
x

  pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc
  pruneString :: NString (Maybe NExprLoc) -> NString NExprLoc
pruneString (DoubleQuoted [Antiquoted Text (Maybe NExprLoc)]
xs) = forall r. [Antiquoted Text r] -> NString r
DoubleQuoted forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Antiquoted Text (Maybe NExprLoc)
-> Maybe (Antiquoted Text NExprLoc)
pruneAntiquotedText [Antiquoted Text (Maybe NExprLoc)]
xs
  pruneString (Indented Int
n   [Antiquoted Text (Maybe NExprLoc)]
xs) = forall r. Int -> [Antiquoted Text r] -> NString r
Indented Int
n   forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Antiquoted Text (Maybe NExprLoc)
-> Maybe (Antiquoted Text NExprLoc)
pruneAntiquotedText [Antiquoted Text (Maybe NExprLoc)]
xs

  pruneAntiquotedText
    :: Antiquoted Text (Maybe NExprLoc) -> Maybe (Antiquoted Text NExprLoc)
  pruneAntiquotedText :: Antiquoted Text (Maybe NExprLoc)
-> Maybe (Antiquoted Text NExprLoc)
pruneAntiquotedText (Plain Text
v)             = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v r. v -> Antiquoted v r
Plain Text
v
  pruneAntiquotedText Antiquoted Text (Maybe NExprLoc)
EscapedNewline        = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall v r. Antiquoted v r
EscapedNewline
  pruneAntiquotedText (Antiquoted (Just NExprLoc
k)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v r. r -> Antiquoted v r
Antiquoted NExprLoc
k
  pruneAntiquotedText (Antiquoted Maybe NExprLoc
Nothing ) = forall a. Maybe a
Nothing

  pruneAntiquoted
    :: Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc)
    -> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
  pruneAntiquoted :: Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc)
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
pruneAntiquoted (Plain NString (Maybe NExprLoc)
v)             = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v r. v -> Antiquoted v r
Plain forall a b. (a -> b) -> a -> b
$ NString (Maybe NExprLoc) -> NString NExprLoc
pruneString NString (Maybe NExprLoc)
v
  pruneAntiquoted Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc)
EscapedNewline        = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall v r. Antiquoted v r
EscapedNewline
  pruneAntiquoted (Antiquoted (Just NExprLoc
k)) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall v r. r -> Antiquoted v r
Antiquoted NExprLoc
k
  pruneAntiquoted (Antiquoted Maybe NExprLoc
Nothing ) = forall a. Maybe a
Nothing

  pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
  pruneKeyName :: NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName (StaticKey VarName
n) = forall r. VarName -> NKeyName r
StaticKey VarName
n
  pruneKeyName (DynamicKey Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc)
k) | Just Antiquoted (NString NExprLoc) NExprLoc
k' <- Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc)
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
pruneAntiquoted Antiquoted (NString (Maybe NExprLoc)) (Maybe NExprLoc)
k = forall r. Antiquoted (NString r) r -> NKeyName r
DynamicKey Antiquoted (NString NExprLoc) NExprLoc
k'
                              | Bool
otherwise = forall r. VarName -> NKeyName r
StaticKey VarName
"<unused?>"

  pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
  pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
pruneParams (Param VarName
n) = forall r. VarName -> Params r
Param VarName
n
  pruneParams (ParamSet Maybe VarName
mname Variadic
variadic ParamSet (Maybe NExprLoc)
pset) =
    forall r. Maybe VarName -> Variadic -> ParamSet r -> Params r
ParamSet Maybe VarName
mname Variadic
variadic ((VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc)
reduceOrPassMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamSet (Maybe NExprLoc)
pset)
   where
    reduceOrPassMode :: (VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc)
reduceOrPassMode =
      forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. (a -> b) -> a -> b
$
        forall a. a -> a -> Bool -> a
bool
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ((forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe NExprLoc
annNNull)
          (Options -> Bool
isReduceSets Options
opts)  -- Reduce set members that aren't used; breaks if hasAttr is used
          (forall a. a -> Maybe a -> a
fromMaybe NExprLoc
annNNull)

  pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
  pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
pruneBinding (NamedVar NAttrPath (Maybe NExprLoc)
_                 Maybe NExprLoc
Nothing  NSourcePos
_  ) = forall a. Maybe a
Nothing
  pruneBinding (NamedVar NAttrPath (Maybe NExprLoc)
xs                (Just NExprLoc
x) NSourcePos
pos) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. NAttrPath r -> r -> NSourcePos -> Binding r
NamedVar (NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NAttrPath (Maybe NExprLoc)
xs) NExprLoc
x NSourcePos
pos
  pruneBinding (Inherit  Maybe (Maybe NExprLoc)
_                 []       NSourcePos
_  ) = forall a. Maybe a
Nothing
  pruneBinding (Inherit  (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join -> Maybe NExprLoc
Nothing) [VarName]
_        NSourcePos
_  ) = forall a. Maybe a
Nothing
  pruneBinding (Inherit  (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join -> Maybe NExprLoc
m)       [VarName]
xs       NSourcePos
pos) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. Maybe r -> [VarName] -> NSourcePos -> Binding r
Inherit Maybe NExprLoc
m [VarName]
xs NSourcePos
pos

reducingEvalExpr
  :: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m)
  => (NExprLocF (m a) -> m a)
  -> Maybe Path
  -> NExprLoc
  -> m (NExprLoc, Either r a)
reducingEvalExpr :: forall e (m :: * -> *) r a.
(Framed e m, Has e Options, Exception r, MonadCatch m,
 MonadIO m) =>
(NExprLocF (m a) -> m a)
-> Maybe Path -> NExprLoc -> m (NExprLoc, Either r a)
reducingEvalExpr NExprLocF (m a) -> m a
eval Maybe Path
mpath NExprLoc
expr =
  do
    Flagged (Compose (AnnUnit SrcSpan) NExprF)
expr'           <- forall (n :: * -> *) (f :: * -> *).
(MonadIO n, Traversable f) =>
Fix f -> n (Flagged f)
flagExprLoc forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Maybe Path -> NExprLoc -> m NExprLoc
reduceExpr Maybe Path
mpath NExprLoc
expr)
    Either r a
eres <- (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) forall a b. (a -> b) -> a -> b
$
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix (forall {f :: * -> *} {f :: * -> *} {r} {b}.
MonadIO f =>
(f r -> f b) -> FlaggedF f r -> f b
addEvalFlags NExprLocF (m a) -> m a
eval) Flagged (Compose (AnnUnit SrcSpan) NExprF)
expr'
    Options
opts <- forall e (m :: * -> *).
(MonadReader e m, Has e Options) =>
m Options
askOptions
    Maybe NExprLoc
expr''          <- forall (n :: * -> *).
MonadIO n =>
Options
-> Flagged (Compose (AnnUnit SrcSpan) NExprF) -> n (Maybe NExprLoc)
pruneTree Options
opts Flagged (Compose (AnnUnit SrcSpan) NExprF)
expr'
    pure (forall a. a -> Maybe a -> a
fromMaybe NExprLoc
annNNull Maybe NExprLoc
expr'', Either r a
eres)
 where
  addEvalFlags :: (f r -> f b) -> FlaggedF f r -> f b
addEvalFlags f r -> f b
k (FlaggedF (IORef Bool
b, f r
x)) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef Bool
b Bool
True) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f r -> f b
k f r
x

instance Monad m => Scoped NExprLoc (Reducer m) where
  askScopes :: Reducer m (Scopes (Reducer m) NExprLoc)
askScopes   = forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
m (Scopes m a)
askScopesReader
  clearScopes :: forall r. Reducer m r -> Reducer m r
clearScopes = forall (m :: * -> *) a e r.
(MonadReader e m, Has e (Scopes m a)) =>
m r -> m r
clearScopesReader @(Reducer m) @NExprLoc
  pushScopes :: forall r. Scopes (Reducer m) NExprLoc -> Reducer m r -> Reducer m r
pushScopes  = forall e (m :: * -> *) a r.
(MonadReader e m, Has e (Scopes m a)) =>
Scopes m a -> m r -> m r
pushScopesReader
  lookupVar :: VarName -> Reducer m (Maybe NExprLoc)
lookupVar   = forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
VarName -> m (Maybe a)
lookupVarReader