{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | 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           Control.Applicative
import           Control.Arrow                  ( second )
import           Control.Monad
import           Control.Monad.Catch
#if !MIN_VERSION_base(4,13,0)
import           Control.Monad.Fail
#endif
import           Control.Monad.Fix
import           Control.Monad.IO.Class
import           Control.Monad.Reader
import           Control.Monad.State.Strict
import           Data.Fix                       ( Fix(..), foldFix, foldFixM )
-- import           Data.Foldable
import           Data.HashMap.Lazy              ( HashMap )
import qualified Data.HashMap.Lazy             as M
-- import           Data.HashSet (HashSet)
-- import qualified Data.HashSet as S
import           Data.IORef
import           Data.List.NonEmpty             ( NonEmpty(..) )
import qualified Data.List.NonEmpty            as NE
import           Data.Maybe                     ( fromMaybe
                                                , mapMaybe
                                                , catMaybes
                                                )
import           Data.Text                      ( Text )
import           Nix.Atoms
import           Nix.Effects.Basic              ( pathToDefaultNixFile )
import           Nix.Expr
import           Nix.Frames
import           Nix.Options                    ( Options
                                                , reduceSets
                                                , reduceLists
                                                )
import           Nix.Parser
import           Nix.Scope
import           Nix.Utils
import           System.Directory
import           System.FilePath

newtype Reducer m a = Reducer
    { Reducer m a
-> ReaderT
     (Maybe FilePath, Scopes (Reducer m) NExprLoc)
     (StateT (HashMap FilePath NExprLoc) m)
     a
runReducer :: ReaderT (Maybe FilePath, Scopes (Reducer m) NExprLoc)
                           (StateT (HashMap FilePath NExprLoc) 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. FilePath -> Reducer m a) -> MonadFail (Reducer m)
FilePath -> Reducer m a
forall a. FilePath -> Reducer m a
forall (m :: * -> *).
Monad m =>
(forall a. FilePath -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (Reducer m)
forall (m :: * -> *) a. MonadFail m => FilePath -> Reducer m a
fail :: FilePath -> Reducer m a
$cfail :: forall (m :: * -> *) a. MonadFail m => FilePath -> Reducer m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (Reducer m)
MonadFail,
              MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc),
              MonadState (HashMap FilePath NExprLoc))

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

  HashMap FilePath NExprLoc
imports <- m (HashMap FilePath NExprLoc)
forall s (m :: * -> *). MonadState s m => m s
get
  case FilePath -> HashMap FilePath NExprLoc -> Maybe NExprLoc
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup FilePath
path' HashMap FilePath NExprLoc
imports of
    Just expr :: NExprLoc
expr -> NExprLoc -> m NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprLoc
expr
    Nothing   -> FilePath -> m NExprLoc
go FilePath
path'
 where
  go :: FilePath -> m NExprLoc
go path :: FilePath
path = do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ "Importing file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
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
$ FilePath -> IO (Result NExprLoc)
forall (m :: * -> *).
MonadFile m =>
FilePath -> m (Result NExprLoc)
parseNixFileLoc FilePath
path
    case Result NExprLoc
eres of
      Failure err :: Doc Void
err -> FilePath -> m NExprLoc
forall a. HasCallStack => FilePath -> a
error (FilePath -> m NExprLoc) -> FilePath -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ "Parse failed: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc Void -> FilePath
forall a. Show a => a -> FilePath
show Doc Void
err
      Success x :: NExprLoc
x   -> do
        let
          pos :: SourcePos
pos  = FilePath -> Pos -> Pos -> SourcePos
SourcePos "Reduce.hs" (Int -> Pos
mkPos 1) (Int -> Pos
mkPos 1)
          span :: SrcSpan
span = SourcePos -> SourcePos -> SrcSpan
SrcSpan SourcePos
pos SourcePos
pos
          cur :: Binding NExprLoc
cur  = NAttrPath NExprLoc -> NExprLoc -> SourcePos -> Binding NExprLoc
forall r. NAttrPath r -> r -> SourcePos -> Binding r
NamedVar (VarName -> NKeyName NExprLoc
forall r. VarName -> NKeyName r
StaticKey "__cur_file" NKeyName NExprLoc -> [NKeyName NExprLoc] -> NAttrPath NExprLoc
forall a. a -> [a] -> NonEmpty a
:| [])
                          (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SrcSpan -> FilePath -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> FilePath -> NExprLocF r
NLiteralPath_ SrcSpan
pann FilePath
path))
                          SourcePos
pos
          x' :: NExprLoc
x' = Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SrcSpan
-> [Binding NExprLoc]
-> NExprLoc
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> [Binding r] -> r -> NExprLocF r
NLet_ SrcSpan
span [Binding NExprLoc
cur] NExprLoc
x)
        (HashMap FilePath NExprLoc -> HashMap FilePath NExprLoc) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FilePath
-> NExprLoc
-> HashMap FilePath NExprLoc
-> HashMap FilePath NExprLoc
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert FilePath
path NExprLoc
x')
        ((Maybe FilePath, Scopes m NExprLoc)
 -> (Maybe FilePath, Scopes m NExprLoc))
-> m NExprLoc -> m NExprLoc
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Maybe FilePath, Scopes m NExprLoc)
-> (Maybe FilePath, Scopes m NExprLoc)
-> (Maybe FilePath, Scopes m NExprLoc)
forall a b. a -> b -> a
const (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
path, Scopes m NExprLoc
forall (m :: * -> *) a. Scopes m a
emptyScopes @m @NExprLoc)) (m NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ do
          NExprLoc
x'' <- (Compose (Ann SrcSpan) NExprF (m NExprLoc) -> m NExprLoc)
-> NExprLoc -> m NExprLoc
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
foldFix Compose (Ann SrcSpan) NExprF (m NExprLoc) -> m NExprLoc
forall (m :: * -> *).
(MonadIO m, Scoped NExprLoc m, MonadFail m,
 MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
 MonadState (HashMap FilePath NExprLoc) m) =>
NExprLocF (m NExprLoc) -> m NExprLoc
reduce NExprLoc
x'
          (HashMap FilePath NExprLoc -> HashMap FilePath NExprLoc) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FilePath
-> NExprLoc
-> HashMap FilePath NExprLoc
-> HashMap FilePath NExprLoc
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert FilePath
path NExprLoc
x'')
          return NExprLoc
x''

-- gatherNames :: NExprLoc -> HashSet VarName
-- gatherNames = foldFix $ \case
--     NSym_ _ var -> S.singleton var
--     Compose (Ann _ x) -> fold x

reduceExpr
  :: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc
reduceExpr :: Maybe FilePath -> NExprLoc -> m NExprLoc
reduceExpr mpath :: Maybe FilePath
mpath expr :: NExprLoc
expr =
  (StateT (HashMap FilePath NExprLoc) m NExprLoc
-> HashMap FilePath NExprLoc -> m NExprLoc
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` HashMap FilePath NExprLoc
forall k v. HashMap k v
M.empty)
    (StateT (HashMap FilePath NExprLoc) m NExprLoc -> m NExprLoc)
-> (Reducer m NExprLoc
    -> StateT (HashMap FilePath NExprLoc) m NExprLoc)
-> Reducer m NExprLoc
-> m NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT
  (Maybe FilePath, Scopes (Reducer m) NExprLoc)
  (StateT (HashMap FilePath NExprLoc) m)
  NExprLoc
-> (Maybe FilePath, Scopes (Reducer m) NExprLoc)
-> StateT (HashMap FilePath NExprLoc) m NExprLoc
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` (Maybe FilePath
mpath, Scopes (Reducer m) NExprLoc
forall (m :: * -> *) a. Scopes m a
emptyScopes))
    (ReaderT
   (Maybe FilePath, Scopes (Reducer m) NExprLoc)
   (StateT (HashMap FilePath NExprLoc) m)
   NExprLoc
 -> StateT (HashMap FilePath NExprLoc) m NExprLoc)
-> (Reducer m NExprLoc
    -> ReaderT
         (Maybe FilePath, Scopes (Reducer m) NExprLoc)
         (StateT (HashMap FilePath NExprLoc) m)
         NExprLoc)
-> Reducer m NExprLoc
-> StateT (HashMap FilePath NExprLoc) m NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reducer m NExprLoc
-> ReaderT
     (Maybe FilePath, Scopes (Reducer m) NExprLoc)
     (StateT (HashMap FilePath NExprLoc) m)
     NExprLoc
forall (m :: * -> *) a.
Reducer m a
-> ReaderT
     (Maybe FilePath, Scopes (Reducer m) NExprLoc)
     (StateT (HashMap FilePath NExprLoc) m)
     a
runReducer
    (Reducer m NExprLoc -> m NExprLoc)
-> Reducer m NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ (Compose (Ann 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 (Ann SrcSpan) NExprF (Reducer m NExprLoc)
-> Reducer m NExprLoc
forall (m :: * -> *).
(MonadIO m, Scoped NExprLoc m, MonadFail m,
 MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
 MonadState (HashMap FilePath NExprLoc) m) =>
NExprLocF (m NExprLoc) -> m NExprLoc
reduce NExprLoc
expr

reduce
  :: forall m
   . ( MonadIO m
     , Scoped NExprLoc m
     , MonadFail m
     , MonadReader (Maybe FilePath, Scopes m NExprLoc) m
     , MonadState (HashMap FilePath NExprLoc) 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 (NSym_ ann :: SrcSpan
ann var :: VarName
var) = VarName -> m (Maybe NExprLoc)
forall a (m :: * -> *). Scoped a m => VarName -> m (Maybe a)
lookupVar VarName
var m (Maybe NExprLoc) -> (Maybe NExprLoc -> NExprLoc) -> m NExprLoc
forall (f :: * -> *) a c. Functor f => f a -> (a -> c) -> f c
<&> \case
  Nothing -> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SrcSpan -> VarName -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> VarName -> NExprLocF r
NSym_ SrcSpan
ann VarName
var)
  Just v :: NExprLoc
v  -> NExprLoc
v

-- | Reduce binary and integer negation.
reduce (NUnary_ uann :: SrcSpan
uann op :: NUnaryOp
op arg :: m NExprLoc
arg) = m NExprLoc
arg m NExprLoc -> (NExprLoc -> m NExprLoc) -> m NExprLoc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: NExprLoc
x -> case (NUnaryOp
op, NExprLoc
x) of
  (NNeg, Fix (NConstant_ cann :: SrcSpan
cann (NInt n :: Integer
n))) ->
    NExprLoc -> m NExprLoc
forall (m :: * -> *) a. Monad m => a -> m a
return (NExprLoc -> m NExprLoc) -> NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan -> NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NAtom -> NExprLocF r
NConstant_ SrcSpan
cann (Integer -> NAtom
NInt (Integer -> Integer
forall a. Num a => a -> a
negate Integer
n))
  (NNot, Fix (NConstant_ cann :: SrcSpan
cann (NBool b :: Bool
b))) ->
    NExprLoc -> m NExprLoc
forall (m :: * -> *) a. Monad m => a -> m a
return (NExprLoc -> m NExprLoc) -> NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan -> NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NAtom -> NExprLocF r
NConstant_ SrcSpan
cann (Bool -> NAtom
NBool (Bool -> Bool
not Bool
b))
  _ -> NExprLoc -> m NExprLoc
forall (m :: * -> *) a. Monad m => a -> m a
return (NExprLoc -> m NExprLoc) -> NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> NUnaryOp -> NExprLoc -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NUnaryOp -> r -> NExprLocF r
NUnary_ 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 (NBinary_ bann :: SrcSpan
bann NApp fun :: m NExprLoc
fun arg :: m NExprLoc
arg) = m NExprLoc
fun m NExprLoc -> (NExprLoc -> m NExprLoc) -> m NExprLoc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  f :: NExprLoc
f@(Fix (NSym_ _ "import")) -> m NExprLoc
arg m NExprLoc -> (NExprLoc -> m NExprLoc) -> m NExprLoc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- Fix (NEnvPath_     pann origPath) -> staticImport pann origPath
    Fix (NLiteralPath_ pann :: SrcSpan
pann origPath :: FilePath
origPath) -> SrcSpan -> FilePath -> m NExprLoc
forall (m :: * -> *).
(MonadIO m, Scoped NExprLoc m, MonadFail m,
 MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
 MonadState (HashMap FilePath NExprLoc) m) =>
SrcSpan -> FilePath -> m NExprLoc
staticImport SrcSpan
pann FilePath
origPath
    v :: NExprLoc
v -> NExprLoc -> m NExprLoc
forall (m :: * -> *) a. Monad m => a -> m a
return (NExprLoc -> m NExprLoc) -> NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> NBinaryOp
-> NExprLoc
-> NExprLoc
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r
NBinary_ SrcSpan
bann NBinaryOp
NApp NExprLoc
f NExprLoc
v

  Fix (NAbs_ _ (Param name :: VarName
name) body :: NExprLoc
body) -> do
    NExprLoc
x <- m NExprLoc
arg
    AttrSet NExprLoc -> m NExprLoc -> m NExprLoc
forall a (m :: * -> *) r. Scoped a m => AttrSet a -> m r -> m r
pushScope (VarName -> NExprLoc -> AttrSet NExprLoc
forall k v. Hashable k => k -> v -> HashMap k v
M.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 FilePath, Scopes m NExprLoc) m,
 MonadState (HashMap FilePath NExprLoc) m) =>
NExprLocF (m NExprLoc) -> m NExprLoc
reduce NExprLoc
body)

  f :: NExprLoc
f -> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> (NExprLoc -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> NExprLoc
-> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> NBinaryOp
-> NExprLoc
-> NExprLoc
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r
NBinary_ 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

-- | Reduce an integer addition to its result.
reduce (NBinary_ bann :: SrcSpan
bann op :: NBinaryOp
op larg :: m NExprLoc
larg rarg :: m NExprLoc
rarg) = do
  NExprLoc
lval <- m NExprLoc
larg
  NExprLoc
rval <- m NExprLoc
rarg
  case (NBinaryOp
op, NExprLoc
lval, NExprLoc
rval) of
    (NPlus, Fix (NConstant_ ann :: SrcSpan
ann (NInt x :: Integer
x)), Fix (NConstant_ _ (NInt y :: Integer
y))) ->
      NExprLoc -> m NExprLoc
forall (m :: * -> *) a. Monad m => a -> m a
return (NExprLoc -> m NExprLoc) -> NExprLoc -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SrcSpan -> NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NAtom -> NExprLocF r
NConstant_ SrcSpan
ann (Integer -> NAtom
NInt (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y)))
    _ -> 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
$ Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> NBinaryOp
-> NExprLoc
-> NExprLoc
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NBinaryOp -> r -> r -> NExprLocF r
NBinary_ 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@(NSelect_ _ _ attrs :: 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
    (NSelect_ _ aset :: NExprLoc
aset attrs :: NAttrPath NExprLoc
attrs _) <- NExprLocF (m NExprLoc) -> m (Compose (Ann SrcSpan) NExprF NExprLoc)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence NExprLocF (m NExprLoc)
base
    Compose (Ann SrcSpan) NExprF NExprLoc
-> NAttrPath NExprLoc -> m NExprLoc
inspectSet (NExprLoc -> Compose (Ann SrcSpan) NExprF NExprLoc
forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
aset) NAttrPath NExprLoc
attrs
  | Bool
otherwise = m NExprLoc
sId
 where
  sId :: m NExprLoc
sId = Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> m (Compose (Ann SrcSpan) NExprF NExprLoc) -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExprLocF (m NExprLoc) -> m (Compose (Ann SrcSpan) NExprF NExprLoc)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence NExprLocF (m NExprLoc)
base
  -- The selection AttrPath is composed of StaticKeys.
  sAttrPath :: [NKeyName r] -> Bool
sAttrPath (StaticKey _ : xs :: [NKeyName r]
xs) = [NKeyName r] -> Bool
sAttrPath [NKeyName r]
xs
  sAttrPath []                 = Bool
True
  sAttrPath _                  = Bool
False
  -- Find appropriate bind in set's binds.
  findBind :: [Binding r] -> NonEmpty (NKeyName r) -> Maybe (Binding r)
findBind []       _              = Maybe (Binding r)
forall a. Maybe a
Nothing
  findBind (x :: Binding r
x : xs :: [Binding r]
xs) attrs :: NonEmpty (NKeyName r)
attrs@(a :: NKeyName r
a :| _) = case Binding r
x of
    n :: Binding r
n@(NamedVar (a' :: NKeyName r
a' :| _) _ _) | NKeyName r
a' NKeyName r -> NKeyName r -> Bool
forall a. Eq a => a -> a -> Bool
== NKeyName r
a -> Binding r -> Maybe (Binding r)
forall a. a -> Maybe a
Just Binding r
n
    _ -> [Binding r] -> NonEmpty (NKeyName r) -> Maybe (Binding r)
findBind [Binding r]
xs NonEmpty (NKeyName r)
attrs
  -- Follow the attrpath recursively in sets.
  inspectSet :: Compose (Ann SrcSpan) NExprF NExprLoc
-> NAttrPath NExprLoc -> m NExprLoc
inspectSet (NSet_ _ NNonRecursive binds :: [Binding NExprLoc]
binds) attrs :: 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 _ e :: NExprLoc
e _) -> case NAttrPath NExprLoc
-> (NKeyName NExprLoc, Maybe (NAttrPath NExprLoc))
forall a. NonEmpty a -> (a, Maybe (NonEmpty a))
NE.uncons NAttrPath NExprLoc
attrs of
      (_, Just attrs :: NAttrPath NExprLoc
attrs) -> Compose (Ann SrcSpan) NExprF NExprLoc
-> NAttrPath NExprLoc -> m NExprLoc
inspectSet (NExprLoc -> Compose (Ann SrcSpan) NExprF NExprLoc
forall (f :: * -> *). Fix f -> f (Fix f)
unFix NExprLoc
e) NAttrPath NExprLoc
attrs
      _               -> NExprLoc -> m NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure NExprLoc
e
    _ -> m NExprLoc
sId
  inspectSet _ _ = 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@(NSet_ ann :: SrcSpan
ann NNonRecursive binds :: [Binding (m NExprLoc)]
binds) = do
  let usesInherit :: Bool
usesInherit = ((Binding (m NExprLoc) -> Bool) -> [Binding (m NExprLoc)] -> Bool)
-> [Binding (m NExprLoc)] -> (Binding (m NExprLoc) -> Bool) -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Binding (m NExprLoc) -> Bool) -> [Binding (m NExprLoc)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [Binding (m NExprLoc)]
binds ((Binding (m NExprLoc) -> Bool) -> Bool)
-> (Binding (m NExprLoc) -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ \case
        Inherit{} -> Bool
True
        _         -> Bool
False
  if Bool
usesInherit
    then 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
$ Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> ([Binding NExprLoc] -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> [Binding NExprLoc]
-> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> NRecordType
-> [Binding NExprLoc]
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NRecordType -> [Binding r] -> NExprLocF r
NSet_ SrcSpan
ann NRecordType
NNonRecursive ([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 :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Binding (m NExprLoc)]
binds
    else Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> m (Compose (Ann SrcSpan) NExprF NExprLoc) -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExprLocF (m NExprLoc) -> m (Compose (Ann SrcSpan) NExprF NExprLoc)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence NExprLocF (m NExprLoc)
e

-- Encountering a 'rec set' construction eliminates any hope of inlining
-- definitions.
reduce (NSet_ ann :: SrcSpan
ann NRecursive binds :: [Binding (m NExprLoc)]
binds) =
  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
$ Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> ([Binding NExprLoc] -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> [Binding NExprLoc]
-> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> NRecordType
-> [Binding NExprLoc]
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NRecordType -> [Binding r] -> NExprLocF r
NSet_ SrcSpan
ann NRecordType
NRecursive ([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 :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Binding (m NExprLoc)]
binds

-- Encountering a 'with' construction eliminates any hope of inlining
-- definitions.
reduce (NWith_ ann :: SrcSpan
ann scope :: m NExprLoc
scope body :: 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
$ (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> m (Compose (Ann SrcSpan) NExprF NExprLoc) -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (m (Compose (Ann SrcSpan) NExprF NExprLoc) -> m NExprLoc)
-> m (Compose (Ann SrcSpan) NExprF NExprLoc) -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> NExprLoc -> NExprLoc -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> r -> r -> NExprLocF r
NWith_ SrcSpan
ann (NExprLoc -> NExprLoc -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> m NExprLoc
-> m (NExprLoc -> Compose (Ann SrcSpan) NExprF NExprLoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m NExprLoc
scope m (NExprLoc -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> m NExprLoc -> m (Compose (Ann SrcSpan) NExprF NExprLoc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m NExprLoc
body

-- | Reduce a let binds section by pushing lambdas,
--   constants and strings to the body scope.
reduce (NLet_ ann :: SrcSpan
ann binds :: [Binding (m NExprLoc)]
binds body :: m NExprLoc
body) = do
  AttrSet NExprLoc
s <- ([Maybe (VarName, NExprLoc)] -> AttrSet NExprLoc)
-> m [Maybe (VarName, NExprLoc)] -> m (AttrSet NExprLoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(VarName, NExprLoc)] -> AttrSet NExprLoc
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(VarName, NExprLoc)] -> AttrSet NExprLoc)
-> ([Maybe (VarName, NExprLoc)] -> [(VarName, NExprLoc)])
-> [Maybe (VarName, NExprLoc)]
-> AttrSet NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (VarName, NExprLoc)] -> [(VarName, NExprLoc)]
forall a. [Maybe a] -> [a]
catMaybes) (m [Maybe (VarName, NExprLoc)] -> m (AttrSet NExprLoc))
-> m [Maybe (VarName, NExprLoc)] -> m (AttrSet NExprLoc)
forall a b. (a -> b) -> a -> b
$ [Binding (m NExprLoc)]
-> (Binding (m NExprLoc) -> m (Maybe (VarName, NExprLoc)))
-> m [Maybe (VarName, NExprLoc)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Binding (m NExprLoc)]
binds ((Binding (m NExprLoc) -> m (Maybe (VarName, NExprLoc)))
 -> m [Maybe (VarName, NExprLoc)])
-> (Binding (m NExprLoc) -> m (Maybe (VarName, NExprLoc)))
-> m [Maybe (VarName, NExprLoc)]
forall a b. (a -> b) -> a -> b
$ \case
    NamedVar (StaticKey name :: VarName
name :| []) def :: m NExprLoc
def _pos :: SourcePos
_pos -> m NExprLoc
def m NExprLoc
-> (NExprLoc -> m (Maybe (VarName, NExprLoc)))
-> m (Maybe (VarName, NExprLoc))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      d :: NExprLoc
d@(Fix NAbs_{}     ) -> Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc)))
-> Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc))
forall a b. (a -> b) -> a -> b
$ (VarName, NExprLoc) -> Maybe (VarName, NExprLoc)
forall a. a -> Maybe a
Just (VarName
name, NExprLoc
d)
      d :: NExprLoc
d@(Fix NConstant_{}) -> Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc)))
-> Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc))
forall a b. (a -> b) -> a -> b
$ (VarName, NExprLoc) -> Maybe (VarName, NExprLoc)
forall a. a -> Maybe a
Just (VarName
name, NExprLoc
d)
      d :: NExprLoc
d@(Fix NStr_{}     ) -> Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc)))
-> Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc))
forall a b. (a -> b) -> a -> b
$ (VarName, NExprLoc) -> Maybe (VarName, NExprLoc)
forall a. a -> Maybe a
Just (VarName
name, NExprLoc
d)
      _                    -> Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (VarName, NExprLoc)
forall a. Maybe a
Nothing
    _ -> Maybe (VarName, NExprLoc) -> m (Maybe (VarName, NExprLoc))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (VarName, NExprLoc)
forall a. Maybe a
Nothing
  NExprLoc
body'  <- AttrSet NExprLoc -> m NExprLoc -> m NExprLoc
forall a (m :: * -> *) r. Scoped a m => AttrSet a -> m r -> m r
pushScope AttrSet NExprLoc
s m NExprLoc
body
  [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 :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Binding (m NExprLoc)]
binds
  -- let names = gatherNames body'
  -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case
  --     NamedVar (StaticKey name _ :| []) _ ->
  --         name `S.member` names
  --     _ -> True
  pure $ Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> [Binding NExprLoc]
-> NExprLoc
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> [Binding r] -> r -> NExprLocF r
NLet_ 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@(NIf_ _ b :: m NExprLoc
b t :: m NExprLoc
t f :: m NExprLoc
f) = m NExprLoc
b m NExprLoc -> (NExprLoc -> m NExprLoc) -> m NExprLoc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Fix (NConstant_ _ (NBool b' :: Bool
b')) -> if Bool
b' then m NExprLoc
t else m NExprLoc
f
  _                             -> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> m (Compose (Ann SrcSpan) NExprF NExprLoc) -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExprLocF (m NExprLoc) -> m (Compose (Ann SrcSpan) NExprF NExprLoc)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence NExprLocF (m NExprLoc)
e

-- | Reduce an assert atom to its encapsulated
--   symbol if the assertion is a boolean constant.
reduce e :: NExprLocF (m NExprLoc)
e@(NAssert_ _ b :: m NExprLoc
b body :: m NExprLoc
body) = m NExprLoc
b m NExprLoc -> (NExprLoc -> m NExprLoc) -> m NExprLoc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Fix (NConstant_ _ (NBool b' :: Bool
b')) | Bool
b' -> m NExprLoc
body
  _ -> Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> m (Compose (Ann SrcSpan) NExprF NExprLoc) -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExprLocF (m NExprLoc) -> m (Compose (Ann SrcSpan) NExprF NExprLoc)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence NExprLocF (m NExprLoc)
e

reduce (NAbs_ ann :: SrcSpan
ann params :: Params (m NExprLoc)
params body :: m NExprLoc
body) = do
  Params NExprLoc
params' <- Params (m NExprLoc) -> m (Params NExprLoc)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Params (m NExprLoc)
params
  -- Make sure that variable definitions in scope do not override function
  -- arguments.
  let args :: AttrSet NExprLoc
args = case Params NExprLoc
params' of
        Param name :: VarName
name -> VarName -> NExprLoc -> AttrSet NExprLoc
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton VarName
name (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SrcSpan -> VarName -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> VarName -> NExprLocF r
NSym_ SrcSpan
ann VarName
name))
        ParamSet pset :: ParamSet NExprLoc
pset _ _ ->
          [(VarName, NExprLoc)] -> AttrSet NExprLoc
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(VarName, NExprLoc)] -> AttrSet NExprLoc)
-> [(VarName, NExprLoc)] -> AttrSet NExprLoc
forall a b. (a -> b) -> a -> b
$ ((VarName, Maybe NExprLoc) -> (VarName, NExprLoc))
-> ParamSet NExprLoc -> [(VarName, NExprLoc)]
forall a b. (a -> b) -> [a] -> [b]
map (\(k :: VarName
k, _) -> (VarName
k, Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SrcSpan -> VarName -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> VarName -> NExprLocF r
NSym_ SrcSpan
ann VarName
k))) ParamSet NExprLoc
pset
  Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> (NExprLoc -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> NExprLoc
-> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan
-> Params NExprLoc
-> NExprLoc
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> Params r -> r -> NExprLocF r
NAbs_ SrcSpan
ann Params NExprLoc
params' (NExprLoc -> NExprLoc) -> m NExprLoc -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttrSet NExprLoc -> m NExprLoc -> m NExprLoc
forall a (m :: * -> *) r. Scoped a m => AttrSet a -> m r -> m r
pushScope AttrSet NExprLoc
args m NExprLoc
body

reduce v :: NExprLocF (m NExprLoc)
v = Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> m (Compose (Ann SrcSpan) NExprF NExprLoc) -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NExprLocF (m NExprLoc) -> m (Compose (Ann SrcSpan) NExprF NExprLoc)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence NExprLocF (m NExprLoc)
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 -> FilePath
show (FlaggedF (_, x :: f r
x)) = f r -> FilePath
forall a. Show a => a -> FilePath
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
$ \x :: 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 a. a -> IO (IORef a)
newIORef Bool
False
  pure $ FlaggedF f (Flagged f) -> Flagged f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (FlaggedF f (Flagged f) -> Flagged f)
-> FlaggedF f (Flagged f) -> Flagged f
forall a b. (a -> b) -> a -> b
$ (IORef Bool, f (Flagged f)) -> FlaggedF f (Flagged f)
forall (f :: * -> *) r. (IORef Bool, f r) -> FlaggedF f r
FlaggedF (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 opts :: 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 (b :: IORef Bool
b, Compose x :: Ann SrcSpan (NExprF (Maybe NExprLoc))
x)) -> do
  Bool
used <- IO Bool -> n Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> n Bool) -> IO Bool -> n Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
b
  pure $ if Bool
used then Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc)
-> (Ann SrcSpan (NExprF NExprLoc)
    -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> Ann SrcSpan (NExprF NExprLoc)
-> NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ann SrcSpan (NExprF NExprLoc)
-> Compose (Ann SrcSpan) NExprF NExprLoc
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Ann SrcSpan (NExprF NExprLoc) -> NExprLoc)
-> Maybe (Ann SrcSpan (NExprF NExprLoc)) -> Maybe NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc))
-> Ann SrcSpan (NExprF (Maybe NExprLoc))
-> Maybe (Ann 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 Ann SrcSpan (NExprF (Maybe NExprLoc))
x else Maybe NExprLoc
forall a. Maybe a
Nothing
 where
  prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc)
  prune :: NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc)
prune = \case
    NStr str :: NString (Maybe NExprLoc)
str -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (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 (Maybe NExprLoc) -> NString NExprLoc
pruneString NString (Maybe NExprLoc)
str)
    NHasAttr (Just aset :: NExprLoc
aset) attr :: NAttrPath (Maybe NExprLoc)
attr ->
      NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (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 ((NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc)
-> NAttrPath (Maybe NExprLoc) -> NAttrPath NExprLoc
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName NAttrPath (Maybe NExprLoc)
attr)
    NAbs params :: Params (Maybe NExprLoc)
params (Just body :: NExprLoc
body) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (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 l :: [Maybe NExprLoc]
l | Options -> Bool
reduceLists Options
opts -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (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 ([Maybe NExprLoc] -> [NExprLoc]
forall a. [Maybe a] -> [a]
catMaybes [Maybe NExprLoc]
l)
            | Bool
otherwise        -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (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 ((Maybe NExprLoc -> NExprLoc) -> [Maybe NExprLoc] -> [NExprLoc]
forall a b. (a -> b) -> [a] -> [b]
map (NExprLoc -> Maybe NExprLoc -> NExprLoc
forall a. a -> Maybe a -> a
fromMaybe NExprLoc
nNull) [Maybe NExprLoc]
l)
    NSet recur :: NRecordType
recur binds :: [Binding (Maybe NExprLoc)]
binds
      | Options -> Bool
reduceSets Options
opts -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ NRecordType -> [Binding NExprLoc] -> NExprF NExprLoc
forall r. NRecordType -> [Binding r] -> NExprF r
NSet NRecordType
recur ((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 :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Binding (Maybe NExprLoc)]
binds)
      | Bool
otherwise -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ NRecordType -> [Binding NExprLoc] -> NExprF NExprLoc
forall r. NRecordType -> [Binding r] -> NExprF r
NSet NRecordType
recur ((Binding (Maybe NExprLoc) -> Binding NExprLoc)
-> [Binding (Maybe NExprLoc)] -> [Binding NExprLoc]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe NExprLoc -> NExprLoc)
-> Binding (Maybe NExprLoc) -> Binding NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NExprLoc -> Maybe NExprLoc -> NExprLoc
forall a. a -> Maybe a -> a
fromMaybe NExprLoc
nNull)) [Binding (Maybe NExprLoc)]
binds)

    NLet binds :: [Binding (Maybe NExprLoc)]
binds (Just body :: NExprLoc
body@(Fix (Compose (Ann _ x :: NExprF NExprLoc
x)))) ->
      NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ case (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 of
        [] -> NExprF NExprLoc
x
        xs :: [Binding NExprLoc]
xs -> [Binding NExprLoc] -> NExprLoc -> NExprF NExprLoc
forall r. [Binding r] -> r -> NExprF r
NLet [Binding NExprLoc]
xs NExprLoc
body

    NSelect (Just aset :: NExprLoc
aset) attr :: NAttrPath (Maybe NExprLoc)
attr alt :: Maybe (Maybe NExprLoc)
alt ->
      NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (NExprF NExprLoc -> Maybe (NExprF NExprLoc))
-> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a b. (a -> b) -> a -> b
$ NExprLoc -> NAttrPath NExprLoc -> Maybe NExprLoc -> NExprF NExprLoc
forall r. r -> NAttrPath r -> Maybe r -> NExprF r
NSelect NExprLoc
aset ((NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc)
-> NAttrPath (Maybe NExprLoc) -> NAttrPath NExprLoc
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName NAttrPath (Maybe NExprLoc)
attr) (Maybe (Maybe NExprLoc) -> Maybe NExprLoc
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe NExprLoc)
alt)

    -- These are the only short-circuiting binary operators
    NBinary NAnd (Just (Fix (Compose (Ann _ larg :: NExprF NExprLoc
larg)))) _ -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just NExprF NExprLoc
larg
    NBinary NOr (Just (Fix (Compose (Ann _ larg :: NExprF NExprLoc
larg)))) _ -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just NExprF NExprLoc
larg

    -- If the function was never called, it means its argument was in a
    -- thunk that was forced elsewhere.
    NBinary NApp Nothing (Just _) -> 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
    -- error the user encountered, which means providing all aspects of
    -- the evaluation path they ultimately followed.
    NBinary op :: NBinaryOp
op Nothing (Just rarg :: NExprLoc
rarg) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (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
nNull NExprLoc
rarg
    NBinary op :: NBinaryOp
op (Just larg :: NExprLoc
larg) Nothing -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (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
nNull

    -- If the scope of a with was never referenced, it's not needed
    NWith Nothing (Just (Fix (Compose (Ann _ body :: NExprF NExprLoc
body)))) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just NExprF NExprLoc
body

    NAssert Nothing _ ->
      FilePath -> Maybe (NExprF NExprLoc)
forall a. HasCallStack => FilePath -> a
error "How can an assert be used, but its condition not?"

    NAssert _ (Just (Fix (Compose (Ann _ body :: NExprF NExprLoc
body)))) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just NExprF NExprLoc
body
    NAssert (Just cond :: NExprLoc
cond) _ -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just (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
nNull

    NIf Nothing _ _ -> FilePath -> Maybe (NExprF NExprLoc)
forall a. HasCallStack => FilePath -> a
error "How can an if be used, but its condition not?"

    NIf _ Nothing (Just (Fix (Compose (Ann _ f :: NExprF NExprLoc
f)))) -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just NExprF NExprLoc
f
    NIf _ (Just (Fix (Compose (Ann _ t :: NExprF NExprLoc
t)))) Nothing -> NExprF NExprLoc -> Maybe (NExprF NExprLoc)
forall a. a -> Maybe a
Just NExprF NExprLoc
t

    x :: NExprF (Maybe NExprLoc)
x                     -> NExprF (Maybe NExprLoc) -> Maybe (NExprF NExprLoc)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence NExprF (Maybe NExprLoc)
x

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

  pruneAntiquotedText
    :: Antiquoted Text (Maybe NExprLoc) -> Maybe (Antiquoted Text NExprLoc)
  pruneAntiquotedText :: Antiquoted VarName (Maybe NExprLoc)
-> Maybe (Antiquoted VarName NExprLoc)
pruneAntiquotedText (Plain v :: VarName
v)             = Antiquoted VarName NExprLoc -> Maybe (Antiquoted VarName NExprLoc)
forall a. a -> Maybe a
Just (VarName -> Antiquoted VarName NExprLoc
forall v r. v -> Antiquoted v r
Plain VarName
v)
  pruneAntiquotedText EscapedNewline        = Antiquoted VarName NExprLoc -> Maybe (Antiquoted VarName NExprLoc)
forall a. a -> Maybe a
Just Antiquoted VarName NExprLoc
forall v r. Antiquoted v r
EscapedNewline
  pruneAntiquotedText (Antiquoted Nothing ) = Maybe (Antiquoted VarName NExprLoc)
forall a. Maybe a
Nothing
  pruneAntiquotedText (Antiquoted (Just k :: NExprLoc
k)) = Antiquoted VarName NExprLoc -> Maybe (Antiquoted VarName NExprLoc)
forall a. a -> Maybe a
Just (NExprLoc -> Antiquoted VarName NExprLoc
forall v r. r -> Antiquoted v r
Antiquoted NExprLoc
k)

  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 v :: NString (Maybe NExprLoc)
v)             = Antiquoted (NString NExprLoc) NExprLoc
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall a. a -> Maybe a
Just (NString NExprLoc -> Antiquoted (NString NExprLoc) NExprLoc
forall v r. v -> Antiquoted v r
Plain (NString (Maybe NExprLoc) -> NString NExprLoc
pruneString NString (Maybe NExprLoc)
v))
  pruneAntiquoted EscapedNewline        = Antiquoted (NString NExprLoc) NExprLoc
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall a. a -> Maybe a
Just Antiquoted (NString NExprLoc) NExprLoc
forall v r. Antiquoted v r
EscapedNewline
  pruneAntiquoted (Antiquoted Nothing ) = Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall a. Maybe a
Nothing
  pruneAntiquoted (Antiquoted (Just k :: NExprLoc
k)) = Antiquoted (NString NExprLoc) NExprLoc
-> Maybe (Antiquoted (NString NExprLoc) NExprLoc)
forall a. a -> Maybe a
Just (NExprLoc -> Antiquoted (NString NExprLoc) NExprLoc
forall v r. r -> Antiquoted v r
Antiquoted NExprLoc
k)

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

  pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
  pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
pruneParams (Param n :: VarName
n) = VarName -> Params NExprLoc
forall r. VarName -> Params r
Param VarName
n
  pruneParams (ParamSet xs :: ParamSet (Maybe NExprLoc)
xs b :: Bool
b n :: Maybe VarName
n)
    | Options -> Bool
reduceSets Options
opts = ParamSet NExprLoc -> Bool -> Maybe VarName -> Params NExprLoc
forall r. ParamSet r -> Bool -> Maybe VarName -> Params r
ParamSet
      (((VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc))
-> ParamSet (Maybe NExprLoc) -> ParamSet NExprLoc
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> (VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Maybe NExprLoc
-> (NExprLoc -> Maybe NExprLoc) -> Maybe NExprLoc -> Maybe NExprLoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (NExprLoc -> Maybe NExprLoc
forall a. a -> Maybe a
Just NExprLoc
nNull) NExprLoc -> Maybe NExprLoc
forall a. a -> Maybe a
Just (Maybe NExprLoc -> Maybe NExprLoc)
-> (Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> Maybe (Maybe NExprLoc)
-> Maybe NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe NExprLoc -> NExprLoc)
-> Maybe (Maybe NExprLoc) -> Maybe NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NExprLoc -> Maybe NExprLoc -> NExprLoc
forall a. a -> Maybe a -> a
fromMaybe NExprLoc
nNull))) ParamSet (Maybe NExprLoc)
xs)
      Bool
b
      Maybe VarName
n
    | Bool
otherwise = ParamSet NExprLoc -> Bool -> Maybe VarName -> Params NExprLoc
forall r. ParamSet r -> Bool -> Maybe VarName -> Params r
ParamSet (((VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc))
-> ParamSet (Maybe NExprLoc) -> ParamSet NExprLoc
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> (VarName, Maybe (Maybe NExprLoc)) -> (VarName, Maybe NExprLoc)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Maybe NExprLoc -> NExprLoc)
-> Maybe (Maybe NExprLoc) -> Maybe NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NExprLoc -> Maybe NExprLoc -> NExprLoc
forall a. a -> Maybe a -> a
fromMaybe NExprLoc
nNull))) ParamSet (Maybe NExprLoc)
xs) Bool
b Maybe VarName
n

  pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
  pruneBinding :: Binding (Maybe NExprLoc) -> Maybe (Binding NExprLoc)
pruneBinding (NamedVar _ Nothing _) = Maybe (Binding NExprLoc)
forall a. Maybe a
Nothing
  pruneBinding (NamedVar xs :: NAttrPath (Maybe NExprLoc)
xs (Just x :: NExprLoc
x) pos :: SourcePos
pos) =
    Binding NExprLoc -> Maybe (Binding NExprLoc)
forall a. a -> Maybe a
Just (NAttrPath NExprLoc -> NExprLoc -> SourcePos -> Binding NExprLoc
forall r. NAttrPath r -> r -> SourcePos -> Binding r
NamedVar ((NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc)
-> NAttrPath (Maybe NExprLoc) -> NAttrPath NExprLoc
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName NAttrPath (Maybe NExprLoc)
xs) NExprLoc
x SourcePos
pos)
  pruneBinding (Inherit _                 [] _) = 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) _  _) = 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) xs :: [NKeyName (Maybe NExprLoc)]
xs pos :: SourcePos
pos) =
    Binding NExprLoc -> Maybe (Binding NExprLoc)
forall a. a -> Maybe a
Just (Maybe NExprLoc
-> [NKeyName NExprLoc] -> SourcePos -> Binding NExprLoc
forall r. Maybe r -> [NKeyName r] -> SourcePos -> Binding r
Inherit Maybe NExprLoc
m ((NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc)
-> [NKeyName (Maybe NExprLoc)] -> [NKeyName NExprLoc]
forall a b. (a -> b) -> [a] -> [b]
map NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName [NKeyName (Maybe NExprLoc)]
xs) SourcePos
pos)

reducingEvalExpr
  :: (Framed e m, Has e Options, Exception r, MonadCatch m, MonadIO m)
  => (NExprLocF (m a) -> m a)
  -> Maybe FilePath
  -> NExprLoc
  -> m (NExprLoc, Either r a)
reducingEvalExpr :: (NExprLocF (m a) -> m a)
-> Maybe FilePath -> NExprLoc -> m (NExprLoc, Either r a)
reducingEvalExpr eval :: NExprLocF (m a) -> m a
eval mpath :: Maybe FilePath
mpath expr :: 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 FilePath -> NExprLoc -> IO NExprLoc
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Maybe FilePath -> NExprLoc -> m NExprLoc
reduceExpr Maybe FilePath
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 (a -> Either r a
forall a b. b -> Either a b
Right (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') (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)
  Options
opts :: Options <- (e -> Options) -> m Options
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (FoldLike Options e e Options Options -> e -> Options
forall a s t b. FoldLike a s t a b -> s -> a
view FoldLike Options e e Options Options
forall a b. Has a b => Lens' a b
hasLens)
  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'
  return (NExprLoc -> Maybe NExprLoc -> NExprLoc
forall a. a -> Maybe a -> a
fromMaybe NExprLoc
nNull Maybe NExprLoc
expr'', Either r a
eres)
  where addEvalFlags :: (f r -> f b) -> FlaggedF f r -> f b
addEvalFlags k :: f r -> f b
k (FlaggedF (b :: IORef Bool
b, x :: f r
x)) = IO () -> f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
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
  currentScopes :: Reducer m (Scopes (Reducer m) NExprLoc)
currentScopes = Reducer m (Scopes (Reducer m) NExprLoc)
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
m (Scopes m a)
currentScopesReader
  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