{-# 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,13,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
    { 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
    ( a -> Reducer m b -> Reducer m a
(a -> b) -> Reducer m a -> Reducer m b
(forall a b. (a -> b) -> Reducer m a -> Reducer m b)
-> (forall a b. a -> Reducer m b -> Reducer m a)
-> Functor (Reducer m)
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
<$ :: a -> Reducer m b -> Reducer m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> Reducer m b -> Reducer m a
fmap :: (a -> b) -> Reducer m a -> Reducer m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Reducer m a -> Reducer m b
Functor, Functor (Reducer m)
a -> Reducer m a
Functor (Reducer m)
-> (forall a. a -> Reducer m a)
-> (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 a b. Reducer m a -> Reducer m b -> Reducer m b)
-> (forall a b. Reducer m a -> Reducer m b -> Reducer m a)
-> Applicative (Reducer m)
Reducer m a -> Reducer m b -> Reducer m b
Reducer m a -> Reducer m b -> Reducer m a
Reducer m (a -> b) -> Reducer m a -> Reducer m b
(a -> b -> c) -> Reducer m a -> Reducer m b -> Reducer m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> Reducer m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> Reducer m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (Reducer m)
Applicative, Applicative (Reducer m)
Reducer m a
Applicative (Reducer m)
-> (forall a. Reducer m a)
-> (forall a. Reducer m a -> Reducer m a -> Reducer m a)
-> (forall a. Reducer m a -> Reducer m [a])
-> (forall a. Reducer m a -> Reducer m [a])
-> Alternative (Reducer m)
Reducer m a -> Reducer m a -> Reducer m a
Reducer m a -> Reducer m [a]
Reducer m a -> Reducer m [a]
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 :: Reducer m a -> Reducer m [a]
$cmany :: forall (m :: * -> *) a. MonadPlus m => Reducer m a -> Reducer m [a]
some :: Reducer m a -> Reducer m [a]
$csome :: forall (m :: * -> *) a. MonadPlus m => Reducer m a -> Reducer m [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 :: Reducer m a
$cempty :: forall (m :: * -> *) a. MonadPlus m => Reducer m a
$cp1Alternative :: forall (m :: * -> *). MonadPlus m => Applicative (Reducer m)
Alternative
    , Applicative (Reducer m)
a -> Reducer m a
Applicative (Reducer m)
-> (forall a b. Reducer m a -> (a -> Reducer m b) -> Reducer m b)
-> (forall a b. Reducer m a -> Reducer m b -> Reducer m b)
-> (forall a. a -> Reducer m a)
-> Monad (Reducer m)
Reducer m a -> (a -> Reducer m b) -> Reducer m b
Reducer m a -> Reducer m b -> Reducer m b
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 :: a -> Reducer m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> Reducer m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (Reducer m)
Monad, Monad (Reducer m)
Alternative (Reducer m)
Reducer m a
Alternative (Reducer m)
-> Monad (Reducer m)
-> (forall a. Reducer m a)
-> (forall a. Reducer m a -> Reducer m a -> Reducer m a)
-> MonadPlus (Reducer m)
Reducer m a -> Reducer m a -> Reducer m a
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 :: 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 :: Reducer m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => Reducer m a
$cp2MonadPlus :: forall (m :: * -> *). MonadPlus m => Monad (Reducer m)
$cp1MonadPlus :: forall (m :: * -> *). MonadPlus m => Alternative (Reducer m)
MonadPlus, Monad (Reducer m)
Monad (Reducer m)
-> (forall a. (a -> Reducer m a) -> Reducer m a)
-> MonadFix (Reducer m)
(a -> Reducer m a) -> Reducer m a
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 :: (a -> Reducer m a) -> Reducer m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> Reducer m a) -> Reducer m a
$cp1MonadFix :: forall (m :: * -> *). MonadFix m => Monad (Reducer m)
MonadFix, Monad (Reducer m)
Monad (Reducer m)
-> (forall a. IO a -> Reducer m a) -> MonadIO (Reducer m)
IO a -> Reducer m a
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 :: IO a -> Reducer m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> Reducer m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (Reducer m)
MonadIO, Monad (Reducer m)
Monad (Reducer m)
-> (forall a. String -> Reducer m a) -> MonadFail (Reducer m)
String -> Reducer m a
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 :: String -> Reducer m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> Reducer m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (Reducer m)
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 :: SrcSpan -> Path -> m NExprLoc
staticImport SrcSpan
pann Path
path =
  do
    Maybe Path
mfile <- ((Maybe Path, Scopes m NExprLoc) -> Maybe Path) -> m (Maybe Path)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Maybe Path, Scopes m NExprLoc) -> Maybe Path
forall a b. (a, b) -> a
fst
    Path
path'  <- IO Path -> m Path
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Path -> m Path) -> IO Path -> m Path
forall a b. (a -> b) -> a -> b
$ Path -> IO Path
forall (m :: * -> *). MonadFile m => Path -> m Path
pathToDefaultNixFile Path
path
    Path
path'' <- IO Path -> m Path
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Path -> m Path) -> IO Path -> m Path
forall a b. (a -> b) -> a -> b
$ Path -> IO Path
forall (m :: * -> *). MonadFile m => Path -> m Path
pathToDefaultNixFile (Path -> IO Path) -> IO Path -> IO Path
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> IO String) -> Path -> IO Path
coerce String -> IO String
canonicalizePath
      ((Path -> Path)
-> (Path -> Path -> Path) -> Maybe Path -> Path -> Path
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Path -> Path
forall a. a -> a
id (Path -> Path -> Path
(</>) (Path -> Path -> Path) -> (Path -> Path) -> 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
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Importing file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Path -> String
coerce Path
path''

        Result NExprLoc
eres <- IO (Result NExprLoc) -> m (Result NExprLoc)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result NExprLoc) -> m (Result NExprLoc))
-> IO (Result NExprLoc) -> m (Result NExprLoc)
forall a b. (a -> b) -> a -> b
$ Path -> IO (Result NExprLoc)
forall (m :: * -> *). MonadFile m => Path -> m (Result NExprLoc)
parseNixFileLoc Path
path''
        (Doc Void -> m NExprLoc)
-> (NExprLoc -> m NExprLoc) -> Result NExprLoc -> m NExprLoc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (\ Doc Void
err -> String -> m NExprLoc
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m NExprLoc) -> String -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ String
"Parse failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Doc Void -> String
forall b a. (Show a, IsString b) => a -> b
show Doc Void
err)
          (\ NExprLoc
x -> do
            let
              pos :: SourcePos
pos  = (Pos -> Pos -> SourcePos) -> Pos -> SourcePos
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (String -> Pos -> Pos -> SourcePos
SourcePos String
"Reduce.hs") (Pos -> SourcePos) -> Pos -> SourcePos
forall a b. (a -> b) -> a -> b
$ Int -> Pos
mkPos Int
1
              span :: SrcSpan
span = (SourcePos -> SourcePos -> SrcSpan) -> SourcePos -> SrcSpan
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join SourcePos -> SourcePos -> SrcSpan
SrcSpan SourcePos
pos
              cur :: Binding NExprLoc
cur  =
                NAttrPath NExprLoc -> NExprLoc -> SourcePos -> Binding NExprLoc
forall r. NAttrPath r -> r -> SourcePos -> Binding r
NamedVar
                  (OneItem (NAttrPath NExprLoc) -> NAttrPath NExprLoc
forall x. One x => OneItem x -> x
one (OneItem (NAttrPath NExprLoc) -> NAttrPath NExprLoc)
-> OneItem (NAttrPath NExprLoc) -> NAttrPath NExprLoc
forall a b. (a -> b) -> a -> b
$ VarName -> NKeyName NExprLoc
forall r. VarName -> NKeyName r
StaticKey VarName
"__cur_file")
                  (SrcSpan -> Path -> NExprLoc
NLiteralPathAnn SrcSpan
pann Path
path'')
                  SourcePos
pos
              x' :: NExprLoc
x' = SrcSpan -> [Binding NExprLoc] -> NExprLoc -> NExprLoc
NLetAnn SrcSpan
span (OneItem [Binding NExprLoc] -> [Binding NExprLoc]
forall x. One x => OneItem x -> x
one OneItem [Binding NExprLoc]
Binding NExprLoc
cur) NExprLoc
x
            ((HashMap Path NExprLoc, HashMap Text Text)
 -> (HashMap Path NExprLoc, HashMap Text Text))
-> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((HashMap Path NExprLoc, HashMap Text Text)
  -> (HashMap Path NExprLoc, HashMap Text Text))
 -> m ())
-> ((HashMap Path NExprLoc, HashMap Text Text)
    -> (HashMap Path NExprLoc, HashMap Text Text))
-> m ()
forall a b. (a -> b) -> a -> b
$ (HashMap Path NExprLoc -> HashMap Path NExprLoc)
-> (HashMap Path NExprLoc, HashMap Text Text)
-> (HashMap Path NExprLoc, HashMap Text Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((HashMap Path NExprLoc -> HashMap Path NExprLoc)
 -> (HashMap Path NExprLoc, HashMap Text Text)
 -> (HashMap Path NExprLoc, HashMap Text Text))
-> (HashMap Path NExprLoc -> HashMap Path NExprLoc)
-> (HashMap Path NExprLoc, HashMap Text Text)
-> (HashMap Path NExprLoc, HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ Path -> NExprLoc -> HashMap Path NExprLoc -> HashMap Path NExprLoc
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Path
path'' NExprLoc
x'
            ((Maybe Path, Scopes m NExprLoc)
 -> (Maybe Path, Scopes m NExprLoc))
-> m NExprLoc -> m NExprLoc
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
              ((Maybe Path, Scopes m NExprLoc)
-> (Maybe Path, Scopes m NExprLoc)
-> (Maybe Path, Scopes m NExprLoc)
forall a b. a -> b -> a
const (Path -> Maybe Path
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path
path'', Scopes m NExprLoc
forall a. Monoid a => a
mempty)) (m NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$
              do
                NExprLoc
x'' <- (Compose (AnnUnit SrcSpan) NExprF (m NExprLoc) -> m NExprLoc)
-> NExprLoc -> m NExprLoc
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix Compose (AnnUnit SrcSpan) NExprF (m NExprLoc) -> m NExprLoc
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'
                ((HashMap Path NExprLoc, HashMap Text Text)
 -> (HashMap Path NExprLoc, HashMap Text Text))
-> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((HashMap Path NExprLoc, HashMap Text Text)
  -> (HashMap Path NExprLoc, HashMap Text Text))
 -> m ())
-> ((HashMap Path NExprLoc, HashMap Text Text)
    -> (HashMap Path NExprLoc, HashMap Text Text))
-> m ()
forall a b. (a -> b) -> a -> b
$ (HashMap Path NExprLoc -> HashMap Path NExprLoc)
-> (HashMap Path NExprLoc, HashMap Text Text)
-> (HashMap Path NExprLoc, HashMap Text Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((HashMap Path NExprLoc -> HashMap Path NExprLoc)
 -> (HashMap Path NExprLoc, HashMap Text Text)
 -> (HashMap Path NExprLoc, HashMap Text Text))
-> (HashMap Path NExprLoc -> HashMap Path NExprLoc)
-> (HashMap Path NExprLoc, HashMap Text Text)
-> (HashMap Path NExprLoc, HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ Path -> NExprLoc -> HashMap Path NExprLoc -> HashMap Path NExprLoc
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 <- ((HashMap Path NExprLoc, HashMap Text Text)
 -> HashMap Path NExprLoc)
-> m (HashMap Path NExprLoc)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (HashMap Path NExprLoc, HashMap Text Text) -> HashMap Path NExprLoc
forall a b. (a, b) -> a
fst
    m NExprLoc
-> (NExprLoc -> m NExprLoc) -> Maybe NExprLoc -> m NExprLoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      m NExprLoc
importIt
      NExprLoc -> m NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Path -> HashMap Path NExprLoc -> Maybe NExprLoc
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 :: Maybe Path -> NExprLoc -> m NExprLoc
reduceExpr Maybe Path
mpath NExprLoc
expr =
  (StateT (HashMap Path NExprLoc, HashMap Text Text) m NExprLoc
-> (HashMap Path NExprLoc, HashMap Text Text) -> m NExprLoc
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` (HashMap Path NExprLoc, HashMap Text Text)
forall a. Monoid a => a
mempty)
    (StateT (HashMap Path NExprLoc, HashMap Text Text) m NExprLoc
 -> m NExprLoc)
-> (Reducer m NExprLoc
    -> StateT (HashMap Path NExprLoc, HashMap Text Text) m NExprLoc)
-> Reducer m NExprLoc
-> m NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT
  (Maybe Path, Scopes (Reducer m) NExprLoc)
  (StateT (HashMap Path NExprLoc, HashMap Text Text) m)
  NExprLoc
-> (Maybe Path, Scopes (Reducer m) NExprLoc)
-> StateT (HashMap Path NExprLoc, HashMap Text Text) m NExprLoc
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` (Maybe Path
mpath, Scopes (Reducer m) NExprLoc
forall a. Monoid a => a
mempty))
    (ReaderT
   (Maybe Path, Scopes (Reducer m) NExprLoc)
   (StateT (HashMap Path NExprLoc, HashMap Text Text) m)
   NExprLoc
 -> StateT (HashMap Path NExprLoc, HashMap Text Text) m NExprLoc)
-> (Reducer m NExprLoc
    -> ReaderT
         (Maybe Path, Scopes (Reducer m) NExprLoc)
         (StateT (HashMap Path NExprLoc, HashMap Text Text) m)
         NExprLoc)
-> Reducer m NExprLoc
-> StateT (HashMap Path NExprLoc, HashMap Text Text) m NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reducer m NExprLoc
-> ReaderT
     (Maybe Path, Scopes (Reducer m) NExprLoc)
     (StateT (HashMap Path NExprLoc, HashMap Text Text) m)
     NExprLoc
forall (m :: * -> *) a.
Reducer m a
-> ReaderT
     (Maybe Path, Scopes (Reducer m) NExprLoc)
     (StateT (HashMap Path NExprLoc, HashMap Text Text) m)
     a
runReducer
    (Reducer m NExprLoc -> m NExprLoc)
-> Reducer m NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ (Compose (AnnUnit SrcSpan) NExprF (Reducer m NExprLoc)
 -> Reducer m NExprLoc)
-> NExprLoc -> Reducer m NExprLoc
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix Compose (AnnUnit SrcSpan) NExprF (Reducer m NExprLoc)
-> Reducer m NExprLoc
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 :: NExprLocF (m NExprLoc) -> m NExprLoc
reduce (NSymAnnF SrcSpan
ann VarName
var) =
  NExprLoc -> Maybe NExprLoc -> NExprLoc
forall a. a -> Maybe a -> a
fromMaybe (SrcSpan -> VarName -> NExprLoc
NSymAnn SrcSpan
ann VarName
var) (Maybe NExprLoc -> NExprLoc) -> m (Maybe NExprLoc) -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VarName -> m (Maybe NExprLoc)
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 (NAtom -> NExprLoc) -> NAtom -> NExprLoc
forall a b. (a -> b) -> a -> b
$ Integer -> NAtom
NInt (Integer -> NAtom) -> Integer -> NAtom
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => a -> a
negate Integer
n
        (NUnaryOp
NNot, NConstantAnn SrcSpan
cann (NBool Bool
b)) -> SrcSpan -> NAtom -> NExprLoc
NConstantAnn SrcSpan
cann (NAtom -> NExprLoc) -> NAtom -> NExprLoc
forall a b. (a -> b) -> a -> b
$ Bool -> NAtom
NBool (Bool -> NAtom) -> Bool -> NAtom
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 (NBinaryAnnF SrcSpan
bann NBinaryOp
NApp 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 -> SrcSpan -> Path -> m NExprLoc
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 -> NExprLoc -> m NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprLoc -> m NExprLoc) -> NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan -> NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc
NBinaryAnn SrcSpan
bann NBinaryOp
NApp NExprLoc
f NExprLoc
v
      ) (NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
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
        Scope NExprLoc -> m NExprLoc -> m NExprLoc
forall a (m :: * -> *) r. Scoped a m => Scope a -> m r -> m r
pushScope
          (HashMap VarName NExprLoc -> Scope NExprLoc
coerce (HashMap VarName NExprLoc -> Scope NExprLoc)
-> HashMap VarName NExprLoc -> Scope NExprLoc
forall a b. (a -> b) -> a -> b
$ VarName -> NExprLoc -> HashMap VarName NExprLoc
forall k v. Hashable k => k -> v -> HashMap k v
HM.singleton VarName
name NExprLoc
x)
          ((NExprLocF (m NExprLoc) -> m NExprLoc) -> NExprLoc -> m NExprLoc
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix NExprLocF (m NExprLoc) -> m NExprLoc
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 -> NBinaryOp -> NExprLoc -> NExprLoc -> NExprLoc
NBinaryAnn SrcSpan
bann NBinaryOp
NApp NExprLoc
f (NExprLoc -> NExprLoc) -> m NExprLoc -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m NExprLoc
arg
  ) (NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
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  (NAtom -> NExprLoc) -> NAtom -> NExprLoc
forall a b. (a -> b) -> a -> b
$ Integer -> NAtom
NInt (Integer -> NAtom) -> Integer -> NAtom
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
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)
  | [NKeyName (m NExprLoc)] -> Bool
forall r. [NKeyName r] -> Bool
sAttrPath ([NKeyName (m NExprLoc)] -> Bool)
-> [NKeyName (m NExprLoc)] -> Bool
forall a b. (a -> b) -> a -> b
$ NAttrPath (m NExprLoc) -> [NKeyName (m NExprLoc)]
forall a. NonEmpty a -> [a]
NE.toList NAttrPath (m NExprLoc)
attrs = do
    (NSelectAnnF SrcSpan
_ Maybe NExprLoc
_ NExprLoc
aset NAttrPath NExprLoc
attrs) <- NExprLocF (m NExprLoc) -> m (NExprLocF NExprLoc)
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 (NExprLoc -> NExprLocF NExprLoc
forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
aset) NAttrPath NExprLoc
attrs
  | Bool
otherwise = m NExprLoc
sId
 where
  sId :: m NExprLoc
sId = NExprLocF (m NExprLoc) -> m NExprLoc
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)
_              = Maybe (Binding 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
_ SourcePos
_) | NKeyName r
a' NKeyName r -> NKeyName r -> Bool
forall a. Eq a => a -> a -> Bool
== NKeyName r
a -> Binding r -> Maybe (Binding r)
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 [Binding NExprLoc]
-> NAttrPath NExprLoc -> Maybe (Binding NExprLoc)
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 SourcePos
_) -> case NAttrPath NExprLoc
-> (NKeyName NExprLoc, Maybe (NAttrPath NExprLoc))
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 (NExprLoc -> NExprLocF NExprLoc
forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
e) NAttrPath NExprLoc
attrs
      (NKeyName NExprLoc, Maybe (NAttrPath NExprLoc))
_               -> NExprLoc -> m 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) =
  m NExprLoc -> m NExprLoc -> Bool -> m NExprLoc
forall a. a -> a -> Bool -> a
bool
    -- Encountering a 'rec set' construction eliminates any hope of inlining
    -- definitions.
    m NExprLoc
mExprLoc
    (m NExprLoc -> m NExprLoc -> Bool -> m NExprLoc
forall a. a -> a -> Bool -> a
bool
      (NExprLocF (m NExprLoc) -> m NExprLoc
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 Recursivity -> Recursivity -> Bool
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
forall (m :: * -> *) r. Scoped NExprLoc m => m r -> m r
clearScopes @NExprLoc (m NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Recursivity -> [Binding NExprLoc] -> NExprLoc
NSetAnn SrcSpan
ann Recursivity
r ([Binding NExprLoc] -> NExprLoc)
-> m [Binding NExprLoc] -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Binding (m NExprLoc) -> m (Binding NExprLoc))
-> [Binding (m NExprLoc)] -> m [Binding NExprLoc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Binding (m NExprLoc) -> m (Binding NExprLoc)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Binding (m NExprLoc)]
binds

  usesInherit :: Bool
usesInherit =
    (Binding (m NExprLoc) -> Bool) -> [Binding (m NExprLoc)] -> Bool
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
forall (m :: * -> *) r. Scoped NExprLoc m => m r -> m r
clearScopes @NExprLoc (m NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ (NExprLoc -> NExprLoc -> NExprLoc)
-> m NExprLoc -> m NExprLoc -> m NExprLoc
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' <- (Binding (m NExprLoc) -> m (Binding NExprLoc))
-> [Binding (m NExprLoc)] -> m [Binding NExprLoc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Binding (m NExprLoc) -> m (Binding NExprLoc)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Binding (m NExprLoc)]
binds
    NExprLoc
body'  <-
      (Scope NExprLoc -> m NExprLoc -> m NExprLoc
forall a (m :: * -> *) r. Scoped a m => Scope a -> m r -> m r
`pushScope` m NExprLoc
body) (Scope NExprLoc -> m NExprLoc)
-> ([Maybe (VarName, NExprLoc)] -> Scope NExprLoc)
-> [Maybe (VarName, NExprLoc)]
-> m NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap VarName NExprLoc -> Scope NExprLoc
coerce (HashMap VarName NExprLoc -> Scope NExprLoc)
-> ([Maybe (VarName, NExprLoc)] -> HashMap VarName NExprLoc)
-> [Maybe (VarName, NExprLoc)]
-> Scope NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(VarName, NExprLoc)] -> HashMap VarName NExprLoc
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(VarName, NExprLoc)] -> HashMap VarName NExprLoc)
-> ([Maybe (VarName, NExprLoc)] -> [(VarName, NExprLoc)])
-> [Maybe (VarName, NExprLoc)]
-> HashMap VarName NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (VarName, NExprLoc)] -> [(VarName, NExprLoc)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (VarName, NExprLoc)] -> m NExprLoc)
-> m [Maybe (VarName, NExprLoc)] -> m NExprLoc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        (Binding (m NExprLoc) -> m (Maybe (VarName, NExprLoc)))
-> [Binding (m NExprLoc)] -> m [Maybe (VarName, NExprLoc)]
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 SourcePos
_pos ->
              let
                defcase :: NExprLoc -> Maybe (VarName, NExprLoc)
defcase =
                  \case
                    d :: NExprLoc
d@NAbsAnn     {} -> (VarName, NExprLoc) -> Maybe (VarName, NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarName
name, NExprLoc
d)
                    d :: NExprLoc
d@NConstantAnn{} -> (VarName, NExprLoc) -> Maybe (VarName, NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarName
name, NExprLoc
d)
                    d :: NExprLoc
d@NStrAnn     {} -> (VarName, NExprLoc) -> Maybe (VarName, NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarName
name, NExprLoc
d)
                    NExprLoc
_                -> Maybe (VarName, NExprLoc)
forall a. Maybe a
Nothing
              in
              NExprLoc -> Maybe (VarName, NExprLoc)
defcase (NExprLoc -> Maybe (VarName, NExprLoc))
-> m NExprLoc -> m (Maybe (VarName, NExprLoc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m NExprLoc
def

            Binding (m NExprLoc)
_ -> Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (VarName, NExprLoc)
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') -> m NExprLoc -> m NExprLoc -> Bool -> m NExprLoc
forall a. a -> a -> Bool -> a
bool m NExprLoc
f m NExprLoc
t Bool
b'
    NExprLoc
_                         -> NExprLocF (m NExprLoc) -> m NExprLoc
forall (f1 :: * -> *) (f2 :: * -> *).
(Traversable f1, Applicative f2) =>
f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer NExprLocF (m NExprLoc)
e
  ) (NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
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
_ -> NExprLocF (m NExprLoc) -> m NExprLoc
forall (f1 :: * -> *) (f2 :: * -> *).
(Traversable f1, Applicative f2) =>
f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer NExprLocF (m NExprLoc)
e
  ) (NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
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' <- Params (m NExprLoc) -> m (Params NExprLoc)
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 = HashMap VarName NExprLoc -> Scope NExprLoc
coerce (HashMap VarName NExprLoc -> Scope NExprLoc)
-> HashMap VarName NExprLoc -> Scope NExprLoc
forall a b. (a -> b) -> a -> b
$
      case Params NExprLoc
params' of
        Param    VarName
name     -> OneItem (HashMap VarName NExprLoc) -> HashMap VarName NExprLoc
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 ->
          [(VarName, NExprLoc)] -> HashMap VarName NExprLoc
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(VarName, NExprLoc)] -> HashMap VarName NExprLoc)
-> [(VarName, NExprLoc)] -> HashMap VarName NExprLoc
forall a b. (a -> b) -> a -> b
$ (\(VarName
k, Maybe NExprLoc
_) -> (VarName
k, SrcSpan -> VarName -> NExprLoc
NSymAnn SrcSpan
ann VarName
k)) ((VarName, Maybe NExprLoc) -> (VarName, NExprLoc))
-> ParamSet NExprLoc -> [(VarName, NExprLoc)]
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' (NExprLoc -> NExprLoc) -> m NExprLoc -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scope NExprLoc -> m NExprLoc -> m NExprLoc
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 = NExprLocF (m NExprLoc) -> m NExprLoc
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 :: f1 (f2 (Fix f1)) -> f2 (Fix f1)
reduceLayer f1 (f2 (Fix f1))
v = f1 (Fix f1) -> Fix f1
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (f1 (Fix f1) -> Fix f1) -> f2 (f1 (Fix f1)) -> f2 (Fix f1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f1 (f2 (Fix f1)) -> f2 (f1 (Fix f1))
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 (a -> FlaggedF f b -> FlaggedF f a
(a -> b) -> FlaggedF f a -> FlaggedF f b
(forall a b. (a -> b) -> FlaggedF f a -> FlaggedF f b)
-> (forall a b. a -> FlaggedF f b -> FlaggedF f a)
-> Functor (FlaggedF f)
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
<$ :: a -> FlaggedF f b -> FlaggedF f a
$c<$ :: forall (f :: * -> *) a b.
Functor f =>
a -> FlaggedF f b -> FlaggedF f a
fmap :: (a -> b) -> FlaggedF f a -> FlaggedF f b
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> FlaggedF f a -> FlaggedF f b
Functor, FlaggedF f a -> Bool
(a -> m) -> FlaggedF f a -> m
(a -> b -> b) -> b -> FlaggedF f a -> b
(forall m. Monoid m => FlaggedF f m -> m)
-> (forall m a. Monoid m => (a -> m) -> FlaggedF f a -> m)
-> (forall m a. Monoid m => (a -> m) -> FlaggedF f a -> m)
-> (forall a b. (a -> b -> b) -> b -> FlaggedF f a -> b)
-> (forall a b. (a -> b -> b) -> b -> FlaggedF f a -> b)
-> (forall b a. (b -> a -> b) -> b -> FlaggedF f a -> b)
-> (forall b a. (b -> a -> b) -> b -> FlaggedF f a -> b)
-> (forall a. (a -> a -> a) -> FlaggedF f a -> a)
-> (forall a. (a -> a -> a) -> FlaggedF f a -> a)
-> (forall a. FlaggedF f a -> [a])
-> (forall a. FlaggedF f a -> Bool)
-> (forall a. FlaggedF f a -> Int)
-> (forall a. Eq a => a -> FlaggedF f a -> Bool)
-> (forall a. Ord a => FlaggedF f a -> a)
-> (forall a. Ord a => FlaggedF f a -> a)
-> (forall a. Num a => FlaggedF f a -> a)
-> (forall a. Num a => FlaggedF f a -> a)
-> Foldable (FlaggedF f)
forall a. Eq a => a -> FlaggedF f a -> Bool
forall a. Num a => FlaggedF f a -> a
forall a. Ord a => FlaggedF f a -> a
forall m. Monoid m => FlaggedF f m -> m
forall a. FlaggedF f a -> Bool
forall a. FlaggedF f a -> Int
forall a. FlaggedF f a -> [a]
forall a. (a -> a -> a) -> FlaggedF f a -> a
forall m a. Monoid m => (a -> m) -> FlaggedF f a -> m
forall b a. (b -> a -> b) -> b -> FlaggedF f a -> b
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 :: FlaggedF f a -> a
$cproduct :: forall (f :: * -> *) a. (Foldable f, Num a) => FlaggedF f a -> a
sum :: FlaggedF f a -> a
$csum :: forall (f :: * -> *) a. (Foldable f, Num a) => FlaggedF f a -> a
minimum :: FlaggedF f a -> a
$cminimum :: forall (f :: * -> *) a. (Foldable f, Ord a) => FlaggedF f a -> a
maximum :: FlaggedF f a -> a
$cmaximum :: forall (f :: * -> *) a. (Foldable f, Ord a) => FlaggedF f a -> a
elem :: a -> FlaggedF f a -> Bool
$celem :: forall (f :: * -> *) a.
(Foldable f, Eq a) =>
a -> FlaggedF f a -> Bool
length :: FlaggedF f a -> Int
$clength :: forall (f :: * -> *) a. Foldable f => FlaggedF f a -> Int
null :: FlaggedF f a -> Bool
$cnull :: forall (f :: * -> *) a. Foldable f => FlaggedF f a -> Bool
toList :: FlaggedF f a -> [a]
$ctoList :: forall (f :: * -> *) a. Foldable f => FlaggedF f a -> [a]
foldl1 :: (a -> a -> a) -> FlaggedF f a -> a
$cfoldl1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> FlaggedF f a -> a
foldr1 :: (a -> a -> a) -> FlaggedF f a -> a
$cfoldr1 :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> a) -> FlaggedF f a -> a
foldl' :: (b -> a -> b) -> b -> FlaggedF f a -> b
$cfoldl' :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> FlaggedF f a -> b
foldl :: (b -> a -> b) -> b -> FlaggedF f a -> b
$cfoldl :: forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> FlaggedF f a -> b
foldr' :: (a -> b -> b) -> b -> FlaggedF f a -> b
$cfoldr' :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> FlaggedF f a -> b
foldr :: (a -> b -> b) -> b -> FlaggedF f a -> b
$cfoldr :: forall (f :: * -> *) a b.
Foldable f =>
(a -> b -> b) -> b -> FlaggedF f a -> b
foldMap' :: (a -> m) -> FlaggedF f a -> m
$cfoldMap' :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> FlaggedF f a -> m
foldMap :: (a -> m) -> FlaggedF f a -> m
$cfoldMap :: forall (f :: * -> *) m a.
(Foldable f, Monoid m) =>
(a -> m) -> FlaggedF f a -> m
fold :: FlaggedF f m -> m
$cfold :: forall (f :: * -> *) m. (Foldable f, Monoid m) => FlaggedF f m -> m
Foldable, Functor (FlaggedF f)
Foldable (FlaggedF f)
Functor (FlaggedF f)
-> Foldable (FlaggedF f)
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> FlaggedF f a -> f (FlaggedF f b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    FlaggedF f (f a) -> f (FlaggedF f a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> FlaggedF f a -> m (FlaggedF f b))
-> (forall (m :: * -> *) a.
    Monad m =>
    FlaggedF f (m a) -> m (FlaggedF f a))
-> Traversable (FlaggedF f)
(a -> f b) -> FlaggedF f a -> f (FlaggedF f b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (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 (m :: * -> *) a.
Monad m =>
FlaggedF f (m a) -> m (FlaggedF f a)
forall (f :: * -> *) a.
Applicative f =>
FlaggedF f (f a) -> f (FlaggedF f a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FlaggedF f a -> m (FlaggedF f b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FlaggedF f a -> f (FlaggedF f b)
sequence :: 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 :: (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 :: 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 :: (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)
$cp2Traversable :: forall (f :: * -> *). Traversable f => Foldable (FlaggedF f)
$cp1Traversable :: forall (f :: * -> *). Traversable f => Functor (FlaggedF f)
Traversable)

instance Show (f r) => Show (FlaggedF f r) where
  show :: FlaggedF f r -> String
show (FlaggedF (IORef Bool
_, f r
x)) = f r -> String
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 :: Fix f -> n (Flagged f)
flagExprLoc = (f (Flagged f) -> n (Flagged f)) -> Fix f -> n (Flagged f)
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
foldFixM ((f (Flagged f) -> n (Flagged f)) -> Fix f -> n (Flagged f))
-> (f (Flagged f) -> n (Flagged f)) -> Fix f -> n (Flagged f)
forall a b. (a -> b) -> a -> b
$ \f (Flagged f)
x -> do
  IORef Bool
flag <- IO (IORef Bool) -> n (IORef Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Bool) -> n (IORef Bool))
-> IO (IORef Bool) -> n (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Bool
False
  pure $ (IORef Bool, f (Flagged f)) -> Flagged f
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 :: Options -> Flagged NExprLocF -> n (Maybe NExprLoc)
pruneTree Options
opts =
  (FlaggedF NExprLocF (Maybe NExprLoc) -> n (Maybe NExprLoc))
-> Flagged NExprLocF -> n (Maybe NExprLoc)
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
foldFixM ((FlaggedF NExprLocF (Maybe NExprLoc) -> n (Maybe NExprLoc))
 -> Flagged NExprLocF -> n (Maybe NExprLoc))
-> (FlaggedF NExprLocF (Maybe NExprLoc) -> n (Maybe NExprLoc))
-> Flagged NExprLocF
-> n (Maybe NExprLoc)
forall a b. (a -> b) -> a -> b
$
    \(FlaggedF (IORef Bool
b, Compose AnnUnit SrcSpan (NExprF (Maybe NExprLoc))
x)) ->
      Maybe NExprLoc -> Maybe NExprLoc -> Bool -> Maybe NExprLoc
forall a. a -> a -> Bool -> a
bool
        Maybe NExprLoc
forall a. Maybe a
Nothing
        (AnnUnit SrcSpan (NExprF NExprLoc) -> NExprLoc
forall ann (f :: * -> *). AnnUnit ann (f (Ann ann f)) -> Ann ann f
annUnitToAnn (AnnUnit SrcSpan (NExprF NExprLoc) -> NExprLoc)
-> Maybe (AnnUnit SrcSpan (NExprF NExprLoc)) -> Maybe NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc))
-> AnnUnit SrcSpan (NExprF (Maybe NExprLoc))
-> Maybe (AnnUnit SrcSpan (NExprF NExprLoc))
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)
        (Bool -> Maybe NExprLoc) -> n Bool -> n (Maybe NExprLoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool -> n Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> IO Bool
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 -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ NString NExprLoc -> NExprF NExprLoc
forall r. NString r -> NExprF r
NStr (NString NExprLoc -> NExprF NExprLoc)
-> NString NExprLoc -> NExprF NExprLoc
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 ->
      NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ NExprLoc -> NAttrPath NExprLoc -> NExprF NExprLoc
forall r. r -> NAttrPath r -> NExprF r
NHasAttr NExprLoc
aset (NAttrPath NExprLoc -> NExprF NExprLoc)
-> NAttrPath NExprLoc -> NExprF NExprLoc
forall a b. (a -> b) -> a -> b
$ NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName (NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc)
-> NAttrPath (Maybe NExprLoc) -> NAttrPath NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NAttrPath (Maybe NExprLoc)
attr
    NAbs Params (Maybe NExprLoc)
params (Just NExprLoc
body) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ Params NExprLoc -> NExprLoc -> NExprF NExprLoc
forall r. Params r -> r -> NExprF r
NAbs (Params (Maybe NExprLoc) -> Params NExprLoc
pruneParams Params (Maybe NExprLoc)
params) NExprLoc
body

    NList [Maybe NExprLoc]
l -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ [NExprLoc] -> NExprF NExprLoc
forall r. [r] -> NExprF r
NList ([NExprLoc] -> NExprF NExprLoc) -> [NExprLoc] -> NExprF NExprLoc
forall a b. (a -> b) -> a -> b
$
      ([Maybe NExprLoc] -> [NExprLoc])
-> ([Maybe NExprLoc] -> [NExprLoc])
-> Bool
-> [Maybe NExprLoc]
-> [NExprLoc]
forall a. a -> a -> Bool -> a
bool
        (NExprLoc -> Maybe NExprLoc -> NExprLoc
forall a. a -> Maybe a -> a
fromMaybe NExprLoc
annNNull (Maybe NExprLoc -> NExprLoc) -> [Maybe NExprLoc] -> [NExprLoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
        [Maybe NExprLoc] -> [NExprLoc]
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 -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ Recursivity -> [Binding NExprLoc] -> NExprF NExprLoc
forall r. Recursivity -> [Binding r] -> NExprF r
NSet Recursivity
recur ([Binding NExprLoc] -> NExprF NExprLoc)
-> [Binding NExprLoc] -> NExprF NExprLoc
forall a b. (a -> b) -> a -> b
$
      ([Binding (Maybe NExprLoc)] -> [Binding NExprLoc])
-> ([Binding (Maybe NExprLoc)] -> [Binding NExprLoc])
-> Bool
-> [Binding (Maybe NExprLoc)]
-> [Binding NExprLoc]
forall a. a -> a -> Bool -> a
bool
        (NExprLoc -> Maybe NExprLoc -> NExprLoc
forall a. a -> Maybe a -> a
fromMaybe NExprLoc
annNNull (Maybe NExprLoc -> NExprLoc)
-> [Binding (Maybe NExprLoc)] -> [Binding NExprLoc]
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>>)
        ((Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc))
-> [Binding (Maybe NExprLoc)] -> [Binding NExprLoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
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)) ->
      NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$
        NExprF NExprLoc
-> ([Binding NExprLoc] -> NExprF NExprLoc)
-> [Binding NExprLoc]
-> NExprF NExprLoc
forall (t :: * -> *) b a. Foldable t => b -> (t a -> b) -> t a -> b
list
          NExprF NExprLoc
x
          ([Binding NExprLoc] -> NExprLoc -> NExprF NExprLoc
forall r. [Binding r] -> r -> NExprF r
`NLet` NExprLoc
body)
          ((Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc))
-> [Binding (Maybe NExprLoc)] -> [Binding NExprLoc]
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 ->
      NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc -> NExprLoc -> NAttrPath NExprLoc -> NExprF NExprLoc
forall r. Maybe r -> r -> NAttrPath r -> NExprF r
NSelect (Maybe (Maybe NExprLoc) -> Maybe NExprLoc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe NExprLoc)
alt) NExprLoc
aset (NAttrPath NExprLoc -> NExprF NExprLoc)
-> NAttrPath NExprLoc -> NExprF NExprLoc
forall a b. (a -> b) -> a -> b
$ NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName (NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc)
-> NAttrPath (Maybe NExprLoc) -> NAttrPath NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NAttrPath (Maybe NExprLoc)
attr

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

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

    -- 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) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ NBinaryOp -> NExprLoc -> NExprLoc -> NExprF NExprLoc
forall r. NBinaryOp -> r -> r -> NExprF r
NBinary NBinaryOp
op NExprLoc
annNNull NExprLoc
rarg
    NBinary NBinaryOp
op (Just NExprLoc
larg) Maybe NExprLoc
Nothing -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ NBinaryOp -> NExprLoc -> NExprLoc -> NExprF NExprLoc
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)) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
body

    NAssert Maybe NExprLoc
Nothing Maybe NExprLoc
_              -> String -> Maybe (NExprF 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)) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
body
    NAssert (Just NExprLoc
cond) Maybe NExprLoc
_          -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ NExprLoc -> NExprLoc -> NExprF NExprLoc
forall r. r -> r -> NExprF r
NAssert NExprLoc
cond NExprLoc
annNNull

    NIf Maybe NExprLoc
Nothing Maybe NExprLoc
_ Maybe NExprLoc
_ -> String -> Maybe (NExprF 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)) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
f
    NIf Maybe NExprLoc
_ (Just (Ann SrcSpan
_ NExprF NExprLoc
t)) Maybe NExprLoc
Nothing -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprF NExprLoc
t

    NExprF (Maybe NExprLoc)
x                     -> NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc)
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) = [Antiquoted Text NExprLoc] -> NString NExprLoc
forall r. [Antiquoted Text r] -> NString r
DoubleQuoted ([Antiquoted Text NExprLoc] -> NString NExprLoc)
-> [Antiquoted Text NExprLoc] -> NString NExprLoc
forall a b. (a -> b) -> a -> b
$ (Antiquoted Text (Maybe NExprLoc)
 -> Maybe (Antiquoted Text NExprLoc))
-> [Antiquoted Text (Maybe NExprLoc)] -> [Antiquoted Text NExprLoc]
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) = Int -> [Antiquoted Text NExprLoc] -> NString NExprLoc
forall r. Int -> [Antiquoted Text r] -> NString r
Indented Int
n   ([Antiquoted Text NExprLoc] -> NString NExprLoc)
-> [Antiquoted Text NExprLoc] -> NString NExprLoc
forall a b. (a -> b) -> a -> b
$ (Antiquoted Text (Maybe NExprLoc)
 -> Maybe (Antiquoted Text NExprLoc))
-> [Antiquoted Text (Maybe NExprLoc)] -> [Antiquoted Text NExprLoc]
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)             = Antiquoted Text NExprLoc -> Maybe (Antiquoted Text NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Antiquoted Text NExprLoc -> Maybe (Antiquoted Text NExprLoc))
-> Antiquoted Text NExprLoc -> Maybe (Antiquoted Text NExprLoc)
forall a b. (a -> b) -> a -> b
$ Text -> Antiquoted Text NExprLoc
forall v r. v -> Antiquoted v r
Plain Text
v
  pruneAntiquotedText Antiquoted Text (Maybe NExprLoc)
EscapedNewline        = Antiquoted Text NExprLoc -> Maybe (Antiquoted Text NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Antiquoted Text NExprLoc
forall v r. Antiquoted v r
EscapedNewline
  pruneAntiquotedText (Antiquoted (Just NExprLoc
k)) = Antiquoted Text NExprLoc -> Maybe (Antiquoted Text NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Antiquoted Text NExprLoc -> Maybe (Antiquoted Text NExprLoc))
-> Antiquoted Text NExprLoc -> Maybe (Antiquoted Text NExprLoc)
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Antiquoted Text NExprLoc
forall v r. r -> Antiquoted v r
Antiquoted NExprLoc
k
  pruneAntiquotedText (Antiquoted Maybe NExprLoc
Nothing ) = Maybe (Antiquoted Text NExprLoc)
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)             = Antiquoted (NString NExprLoc) NExprLoc
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Antiquoted (NString NExprLoc) NExprLoc
 -> Maybe (Antiquoted (NString NExprLoc) NExprLoc))
-> Antiquoted (NString NExprLoc) NExprLoc
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall a b. (a -> b) -> a -> b
$ NString NExprLoc -> Antiquoted (NString NExprLoc) NExprLoc
forall v r. v -> Antiquoted v r
Plain (NString NExprLoc -> Antiquoted (NString NExprLoc) NExprLoc)
-> NString NExprLoc -> Antiquoted (NString NExprLoc) NExprLoc
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        = Antiquoted (NString NExprLoc) NExprLoc
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Antiquoted (NString NExprLoc) NExprLoc
forall v r. Antiquoted v r
EscapedNewline
  pruneAntiquoted (Antiquoted (Just NExprLoc
k)) = Antiquoted (NString NExprLoc) NExprLoc
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Antiquoted (NString NExprLoc) NExprLoc
 -> Maybe (Antiquoted (NString NExprLoc) NExprLoc))
-> Antiquoted (NString NExprLoc) NExprLoc
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall a b. (a -> b) -> a -> b
$ NExprLoc -> Antiquoted (NString NExprLoc) NExprLoc
forall v r. r -> Antiquoted v r
Antiquoted NExprLoc
k
  pruneAntiquoted (Antiquoted Maybe NExprLoc
Nothing ) = Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall a. Maybe a
Nothing

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

  pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
  pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
pruneParams (Param VarName
n) = VarName -> Params NExprLoc
forall r. VarName -> Params r
Param VarName
n
  pruneParams (ParamSet Maybe VarName
mname Variadic
variadic ParamSet (Maybe NExprLoc)
pset) =
    Maybe VarName -> Variadic -> ParamSet NExprLoc -> Params NExprLoc
forall r. Maybe VarName -> Variadic -> ParamSet r -> Params r
ParamSet Maybe VarName
mname Variadic
variadic ((VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc)
reduceOrPassMode ((VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc))
-> ParamSet (Maybe NExprLoc) -> ParamSet NExprLoc
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 =
      (Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> (VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
 -> (VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc))
-> (Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> (VarName, Maybe (Maybe NExprLoc))
-> (VarName, Maybe NExprLoc)
forall a b. (a -> b) -> a -> b
$
        ((Maybe NExprLoc -> NExprLoc)
 -> Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> ((Maybe NExprLoc -> NExprLoc)
    -> Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> Bool
-> (Maybe NExprLoc -> NExprLoc)
-> Maybe (Maybe NExprLoc)
-> Maybe NExprLoc
forall a. a -> a -> Bool -> a
bool
          (Maybe NExprLoc -> NExprLoc)
-> Maybe (Maybe NExprLoc) -> Maybe NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ((NExprLoc -> Maybe NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NExprLoc -> Maybe NExprLoc)
-> (Maybe (Maybe NExprLoc) -> NExprLoc)
-> Maybe (Maybe NExprLoc)
-> Maybe NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Maybe (Maybe NExprLoc) -> NExprLoc)
 -> Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> ((Maybe NExprLoc -> NExprLoc)
    -> Maybe (Maybe NExprLoc) -> NExprLoc)
-> (Maybe NExprLoc -> NExprLoc)
-> Maybe (Maybe NExprLoc)
-> Maybe NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NExprLoc
-> (Maybe NExprLoc -> NExprLoc)
-> Maybe (Maybe NExprLoc)
-> NExprLoc
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
          (NExprLoc -> Maybe NExprLoc -> NExprLoc
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  SourcePos
_  ) = Maybe (Binding NExprLoc)
forall a. Maybe a
Nothing
  pruneBinding (NamedVar NAttrPath (Maybe NExprLoc)
xs                (Just NExprLoc
x) SourcePos
pos) = Binding NExprLoc -> Maybe (Binding NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding NExprLoc -> Maybe (Binding NExprLoc))
-> Binding NExprLoc -> Maybe (Binding NExprLoc)
forall a b. (a -> b) -> a -> b
$ NAttrPath NExprLoc -> NExprLoc -> SourcePos -> Binding NExprLoc
forall r. NAttrPath r -> r -> SourcePos -> Binding r
NamedVar (NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName (NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc)
-> NAttrPath (Maybe NExprLoc) -> NAttrPath NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NAttrPath (Maybe NExprLoc)
xs) NExprLoc
x SourcePos
pos
  pruneBinding (Inherit  Maybe (Maybe NExprLoc)
_                 []       SourcePos
_  ) = Maybe (Binding NExprLoc)
forall a. Maybe a
Nothing
  pruneBinding (Inherit  (Maybe (Maybe NExprLoc) -> Maybe NExprLoc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join -> Maybe NExprLoc
Nothing) [VarName]
_        SourcePos
_  ) = Maybe (Binding NExprLoc)
forall a. Maybe a
Nothing
  pruneBinding (Inherit  (Maybe (Maybe NExprLoc) -> Maybe NExprLoc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join -> Maybe NExprLoc
m)       [VarName]
xs       SourcePos
pos) = Binding NExprLoc -> Maybe (Binding NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding NExprLoc -> Maybe (Binding NExprLoc))
-> Binding NExprLoc -> Maybe (Binding NExprLoc)
forall a b. (a -> b) -> a -> b
$ Maybe NExprLoc -> [VarName] -> SourcePos -> Binding NExprLoc
forall r. Maybe r -> [VarName] -> SourcePos -> Binding r
Inherit Maybe NExprLoc
m [VarName]
xs SourcePos
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 :: (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 NExprLocF
expr'           <- NExprLoc -> m (Flagged NExprLocF)
forall (n :: * -> *) (f :: * -> *).
(MonadIO n, Traversable f) =>
Fix f -> n (Flagged f)
flagExprLoc (NExprLoc -> m (Flagged NExprLocF))
-> m NExprLoc -> m (Flagged NExprLocF)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO NExprLoc -> m NExprLoc
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe Path -> NExprLoc -> IO NExprLoc
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Maybe Path -> NExprLoc -> m NExprLoc
reduceExpr Maybe Path
mpath NExprLoc
expr)
    Either r a
eres <- (m (Either r a) -> (r -> m (Either r a)) -> m (Either r a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Either r a -> m (Either r a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either r a -> m (Either r a))
-> (r -> Either r a) -> r -> m (Either r a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Either r a
forall a b. a -> Either a b
Left) (m (Either r a) -> m (Either r a))
-> m (Either r a) -> m (Either r a)
forall a b. (a -> b) -> a -> b
$
      a -> Either r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either r a) -> m a -> m (Either r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlaggedF NExprLocF (m a) -> m a) -> Flagged NExprLocF -> m a
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix ((NExprLocF (m a) -> m a) -> FlaggedF NExprLocF (m a) -> m a
forall (f :: * -> *) (f :: * -> *) r b.
MonadIO f =>
(f r -> f b) -> FlaggedF f r -> f b
addEvalFlags NExprLocF (m a) -> m a
eval) Flagged NExprLocF
expr'
    Options
opts <- m Options
forall e (m :: * -> *).
(MonadReader e m, Has e Options) =>
m Options
askOptions
    Maybe NExprLoc
expr''          <- Options -> Flagged NExprLocF -> m (Maybe NExprLoc)
forall (n :: * -> *).
MonadIO n =>
Options -> Flagged NExprLocF -> n (Maybe NExprLoc)
pruneTree Options
opts Flagged NExprLocF
expr'
    pure (NExprLoc -> Maybe NExprLoc -> NExprLoc
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)) = IO () -> f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef Bool
b Bool
True) f () -> f b -> f b
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   = Reducer m (Scopes (Reducer m) NExprLoc)
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
m (Scopes m a)
askScopesReader
  clearScopes :: Reducer m r -> Reducer m r
clearScopes = forall e r.
(MonadReader e (Reducer m), Has e (Scopes (Reducer m) NExprLoc)) =>
Reducer m r -> Reducer m r
forall (m :: * -> *) a e r.
(MonadReader e m, Has e (Scopes m a)) =>
m r -> m r
clearScopesReader @(Reducer m) @NExprLoc
  pushScopes :: Scopes (Reducer m) NExprLoc -> Reducer m r -> Reducer m r
pushScopes  = Scopes (Reducer m) NExprLoc -> Reducer m r -> Reducer m r
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   = VarName -> Reducer m (Maybe NExprLoc)
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
VarName -> m (Maybe a)
lookupVarReader