{-# LANGUAGE CPP #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-# 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           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.Lazy             as M
import qualified Data.HashMap.Strict           as MS
import qualified Data.List.NonEmpty            as NE
import qualified Text.Show
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, HashMap Text Text) m)
     a
runReducer ::
        ReaderT
          ( Maybe FilePath
          , Scopes (Reducer m) NExprLoc
          )
          ( StateT
              ( HashMap FilePath NExprLoc
              , MS.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. 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, MS.HashMap Text Text)
    )

staticImport
  :: forall m
   . ( MonadIO m
     , Scoped NExprLoc m
     , MonadFail m
     , MonadReader (Maybe FilePath, Scopes m NExprLoc) m
     , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m
     )
  => SrcSpan
  -> FilePath
  -> m NExprLoc
staticImport :: SrcSpan -> FilePath -> m NExprLoc
staticImport SrcSpan
pann 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 -> FilePath -> FilePath)
-> Maybe FilePath
-> FilePath
-> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath -> FilePath
forall a. a -> a
id (FilePath -> FilePath -> FilePath
(</>) (FilePath -> FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeDirectory) Maybe FilePath
mfile FilePath
path)

  HashMap FilePath NExprLoc
imports <- ((HashMap FilePath NExprLoc, HashMap Text Text)
 -> HashMap FilePath NExprLoc)
-> m (HashMap FilePath NExprLoc)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (HashMap FilePath NExprLoc, HashMap Text Text)
-> HashMap FilePath 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
    (FilePath -> m NExprLoc
go FilePath
path')
    NExprLoc -> m NExprLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (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)
 where
  go :: FilePath -> m NExprLoc
go 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 ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Importing file " FilePath -> FilePath -> FilePath
forall a. Semigroup 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
    (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 -> FilePath -> m NExprLoc
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m NExprLoc) -> FilePath -> m NExprLoc
forall a b. (a -> b) -> a -> b
$ FilePath
"Parse failed: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Doc Void -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Doc Void
err)
      (\ NExprLoc
x -> do
        let
          pos :: SourcePos
pos  = FilePath -> Pos -> Pos -> SourcePos
SourcePos FilePath
"Reduce.hs" (Int -> Pos
mkPos Int
1) (Int -> Pos
mkPos Int
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
              (Text -> NKeyName NExprLoc
forall r. Text -> NKeyName r
StaticKey Text
"__cur_file" NKeyName NExprLoc -> [NKeyName NExprLoc] -> NAttrPath NExprLoc
forall a. a -> [a] -> NonEmpty a
:| [NKeyName NExprLoc]
forall a. Monoid a => a
mempty)
              (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 (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
span [Binding NExprLoc
cur] NExprLoc
x
        ((HashMap FilePath NExprLoc, HashMap Text Text)
 -> (HashMap FilePath NExprLoc, HashMap Text Text))
-> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((HashMap FilePath NExprLoc, HashMap Text Text)
  -> (HashMap FilePath NExprLoc, HashMap Text Text))
 -> m ())
-> ((HashMap FilePath NExprLoc, HashMap Text Text)
    -> (HashMap FilePath NExprLoc, HashMap Text Text))
-> m ()
forall a b. (a -> b) -> a -> b
$ (HashMap FilePath NExprLoc -> HashMap FilePath NExprLoc)
-> (HashMap FilePath NExprLoc, HashMap Text Text)
-> (HashMap FilePath NExprLoc, HashMap Text Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((HashMap FilePath NExprLoc -> HashMap FilePath NExprLoc)
 -> (HashMap FilePath NExprLoc, HashMap Text Text)
 -> (HashMap FilePath NExprLoc, HashMap Text Text))
-> (HashMap FilePath NExprLoc -> HashMap FilePath NExprLoc)
-> (HashMap FilePath NExprLoc, HashMap Text Text)
-> (HashMap FilePath NExprLoc, HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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, HashMap Text Text) m) =>
NExprLocF (m NExprLoc) -> m NExprLoc
reduce NExprLoc
x'
            ((HashMap FilePath NExprLoc, HashMap Text Text)
 -> (HashMap FilePath NExprLoc, HashMap Text Text))
-> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((HashMap FilePath NExprLoc, HashMap Text Text)
  -> (HashMap FilePath NExprLoc, HashMap Text Text))
 -> m ())
-> ((HashMap FilePath NExprLoc, HashMap Text Text)
    -> (HashMap FilePath NExprLoc, HashMap Text Text))
-> m ()
forall a b. (a -> b) -> a -> b
$ (HashMap FilePath NExprLoc -> HashMap FilePath NExprLoc)
-> (HashMap FilePath NExprLoc, HashMap Text Text)
-> (HashMap FilePath NExprLoc, HashMap Text Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((HashMap FilePath NExprLoc -> HashMap FilePath NExprLoc)
 -> (HashMap FilePath NExprLoc, HashMap Text Text)
 -> (HashMap FilePath NExprLoc, HashMap Text Text))
-> (HashMap FilePath NExprLoc -> HashMap FilePath NExprLoc)
-> (HashMap FilePath NExprLoc, HashMap Text Text)
-> (HashMap FilePath NExprLoc, HashMap Text Text)
forall a b. (a -> b) -> a -> b
$ 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''
            pure NExprLoc
x''
      )
      Result NExprLoc
eres

-- 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 Maybe FilePath
mpath NExprLoc
expr =
  (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m NExprLoc
-> (HashMap FilePath NExprLoc, HashMap Text Text) -> m NExprLoc
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` (HashMap FilePath NExprLoc
forall a. Monoid a => a
mempty, HashMap Text Text
forall k v. HashMap k v
MS.empty))
    (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m NExprLoc
 -> m NExprLoc)
-> (Reducer m NExprLoc
    -> StateT
         (HashMap FilePath NExprLoc, HashMap Text Text) 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, HashMap Text Text) m)
  NExprLoc
-> (Maybe FilePath, Scopes (Reducer m) NExprLoc)
-> StateT (HashMap FilePath NExprLoc, HashMap Text Text) 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, HashMap Text Text) m)
   NExprLoc
 -> StateT
      (HashMap FilePath NExprLoc, HashMap Text Text) m NExprLoc)
-> (Reducer m NExprLoc
    -> ReaderT
         (Maybe FilePath, Scopes (Reducer m) NExprLoc)
         (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m)
         NExprLoc)
-> Reducer m NExprLoc
-> StateT (HashMap FilePath NExprLoc, HashMap Text Text) 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, HashMap Text Text) m)
     NExprLoc
forall (m :: * -> *) a.
Reducer m a
-> ReaderT
     (Maybe FilePath, Scopes (Reducer m) NExprLoc)
     (StateT (HashMap FilePath 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 (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, HashMap Text Text) 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, MS.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 (NSym_ SrcSpan
ann Text
var) =
  NExprLoc -> Maybe NExprLoc -> NExprLoc
forall a. a -> Maybe a -> a
fromMaybe (Compose (Ann SrcSpan) NExprF NExprLoc -> NExprLoc
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SrcSpan -> Text -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> Text -> NExprLocF r
NSym_ SrcSpan
ann Text
var)) (Maybe NExprLoc -> NExprLoc) -> m (Maybe NExprLoc) -> m NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m (Maybe NExprLoc)
forall a (m :: * -> *). Scoped a m => Text -> m (Maybe a)
lookupVar Text
var

-- | Reduce binary and integer negation.
reduce (NUnary_ SrcSpan
uann NUnaryOp
op m NExprLoc
arg) =
  do
    NExprLoc
x <- m NExprLoc
arg
    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
$
      case (NUnaryOp
op, NExprLoc
x) of
        (NUnaryOp
NNeg, Fix (NConstant_ SrcSpan
cann (NInt  Integer
n))) -> SrcSpan -> NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NAtom -> NExprLocF r
NConstant_ SrcSpan
cann (NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> NAtom -> Compose (Ann SrcSpan) NExprF 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, Fix (NConstant_ SrcSpan
cann (NBool Bool
b))) -> SrcSpan -> NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NAtom -> NExprLocF r
NConstant_ SrcSpan
cann (NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> NAtom -> Compose (Ann SrcSpan) NExprF 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 -> 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_ SrcSpan
bann NBinaryOp
NApp m NExprLoc
fun 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_ SrcSpan
_ Text
"import")) ->
    (\case
        -- Fix (NEnvPath_     pann origPath) -> staticImport pann origPath
      Fix (NLiteralPath_ SrcSpan
pann 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, HashMap Text Text) m) =>
SrcSpan -> FilePath -> m NExprLoc
staticImport SrcSpan
pann FilePath
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
$ 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
    ) (NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m NExprLoc
arg

  Fix (NAbs_ SrcSpan
_ (Param Text
name) 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
        (Text -> NExprLoc -> AttrSet NExprLoc
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton Text
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, HashMap Text Text) m) =>
NExprLocF (m NExprLoc) -> m NExprLoc
reduce NExprLoc
body)

  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_ SrcSpan
bann NBinaryOp
op m NExprLoc
larg m NExprLoc
rarg) =
  do
    NExprLoc
lval <- m NExprLoc
larg
    NExprLoc
rval <- m NExprLoc
rarg
    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
$
      case (NBinaryOp
op, NExprLoc
lval, NExprLoc
rval) of
        (NBinaryOp
NPlus, Fix (NConstant_ SrcSpan
ann (NInt Integer
x)), Fix (NConstant_ SrcSpan
_ (NInt Integer
y))) -> SrcSpan -> NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> NAtom -> NExprLocF r
NConstant_ SrcSpan
ann  (NAtom -> Compose (Ann SrcSpan) NExprF NExprLoc)
-> NAtom -> Compose (Ann SrcSpan) NExprF 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
-> 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_ SrcSpan
_ m NExprLoc
_ NAttrPath (m NExprLoc)
attrs Maybe (m NExprLoc)
_)
  | [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_ SrcSpan
_ NExprLoc
aset NAttrPath NExprLoc
attrs Maybe NExprLoc
_) <- 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 Text
_ : [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 :: Compose (Ann SrcSpan) NExprF NExprLoc
-> NAttrPath NExprLoc -> m NExprLoc
inspectSet (NSet_ SrcSpan
_ NRecordType
NNonRecursive [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) -> 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
      (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 Compose (Ann SrcSpan) NExprF 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@(NSet_ SrcSpan
ann NRecordType
NNonRecursive [Binding (m NExprLoc)]
binds) =
  do
    let
      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

    m NExprLoc -> m NExprLoc -> Bool -> m NExprLoc
forall a. a -> a -> Bool -> a
bool
      (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)
      (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)
      Bool
usesInherit

-- Encountering a 'rec set' construction eliminates any hope of inlining
-- definitions.
reduce (NSet_ SrcSpan
ann NRecordType
NRecursive [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_ 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
$ 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
<$> (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_ 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 :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Binding (m NExprLoc)]
binds
    NExprLoc
body'  <-
      (AttrSet NExprLoc -> m NExprLoc -> m NExprLoc
forall a (m :: * -> *) r. Scoped a m => AttrSet a -> m r -> m r
`pushScope` m NExprLoc
body) (AttrSet NExprLoc -> m NExprLoc)
-> ([Maybe (Text, NExprLoc)] -> AttrSet NExprLoc)
-> [Maybe (Text, NExprLoc)]
-> m NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, NExprLoc)] -> AttrSet NExprLoc
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Text, NExprLoc)] -> AttrSet NExprLoc)
-> ([Maybe (Text, NExprLoc)] -> [(Text, NExprLoc)])
-> [Maybe (Text, NExprLoc)]
-> AttrSet NExprLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, NExprLoc)] -> [(Text, NExprLoc)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Text, NExprLoc)] -> m NExprLoc)
-> m [Maybe (Text, NExprLoc)] -> m NExprLoc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        (Binding (m NExprLoc) -> m (Maybe (Text, NExprLoc)))
-> [Binding (m NExprLoc)] -> m [Maybe (Text, NExprLoc)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
          (\case
            NamedVar (StaticKey Text
name :| []) m NExprLoc
def SourcePos
_pos ->
              let
                defcase :: NExprLoc -> Maybe (Text, NExprLoc)
defcase =
                  \case
                    d :: NExprLoc
d@(Fix NAbs_{}     ) -> (Text, NExprLoc) -> Maybe (Text, NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
name, NExprLoc
d)
                    d :: NExprLoc
d@(Fix NConstant_{}) -> (Text, NExprLoc) -> Maybe (Text, NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
name, NExprLoc
d)
                    d :: NExprLoc
d@(Fix NStr_{}     ) -> (Text, NExprLoc) -> Maybe (Text, NExprLoc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
name, NExprLoc
d)
                    NExprLoc
_                    -> Maybe (Text, NExprLoc)
forall a. Maybe a
Nothing
              in
              NExprLoc -> Maybe (Text, NExprLoc)
defcase (NExprLoc -> Maybe (Text, NExprLoc))
-> m NExprLoc -> m (Maybe (Text, NExprLoc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m NExprLoc
def

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

    -- let names = gatherNames body'
    -- binds' <- traverse sequence binds <&> \b -> flip filter b $ \case
    --     NamedVar (StaticKey name _ :| mempty) _ ->
    --         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 _ :| mempty) 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_ SrcSpan
_ m NExprLoc
b m NExprLoc
t m NExprLoc
f) =
  (\case
    Fix (NConstant_ SrcSpan
_ (NBool Bool
b')) -> if Bool
b' then m NExprLoc
t else m NExprLoc
f
    NExprLoc
_                             -> 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
  ) (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@(NAssert_ SrcSpan
_ m NExprLoc
b m NExprLoc
body) =
  (\case
    Fix (NConstant_ SrcSpan
_ (NBool Bool
b')) | Bool
b' -> m NExprLoc
body
    NExprLoc
_ -> 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
  ) (NExprLoc -> m NExprLoc) -> m NExprLoc -> m NExprLoc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m NExprLoc
b

reduce (NAbs_ SrcSpan
ann Params (m NExprLoc)
params 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    Text
name     -> Text -> NExprLoc -> AttrSet NExprLoc
forall k v. Hashable k => k -> v -> HashMap k v
M.singleton Text
name (NExprLoc -> AttrSet NExprLoc) -> NExprLoc -> AttrSet 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 -> Text -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> Text -> NExprLocF r
NSym_ SrcSpan
ann Text
name
        ParamSet ParamSet NExprLoc
pset Bool
_ Maybe Text
_ ->
          [(Text, NExprLoc)] -> AttrSet NExprLoc
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Text, NExprLoc)] -> AttrSet NExprLoc)
-> [(Text, NExprLoc)] -> AttrSet NExprLoc
forall a b. (a -> b) -> a -> b
$ (\(Text
k, Maybe NExprLoc
_) -> (Text
k, 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 -> Text -> Compose (Ann SrcSpan) NExprF NExprLoc
forall r. SrcSpan -> Text -> NExprLocF r
NSym_ SrcSpan
ann Text
k)) ((Text, Maybe NExprLoc) -> (Text, NExprLoc))
-> ParamSet NExprLoc -> [(Text, NExprLoc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 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 (IORef Bool
_, f r
x)) = f r -> FilePath
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 $ 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 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 Ann 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
        (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)
        (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)
-> 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 (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
nNull (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
reduceLists Options
opts)  -- Reduce list members that aren't used; breaks if elemAt is used
        [Maybe NExprLoc]
l
    NSet NRecordType
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
$ NRecordType -> [Binding NExprLoc] -> NExprF NExprLoc
forall r. NRecordType -> [Binding r] -> NExprF r
NSet NRecordType
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
nNull (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 :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence)
        (Options -> Bool
reduceSets 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@(AnnE 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 (Just NExprLoc
aset) NAttrPath (Maybe NExprLoc)
attr Maybe (Maybe NExprLoc)
alt ->
      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 -> 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 NBinaryOp
NAnd (Just (AnnE 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 (AnnE 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
nNull 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
nNull

    -- If the scope of a with was never referenced, it's not needed
    NWith Maybe NExprLoc
Nothing (Just (AnnE 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
_ ->
      FilePath -> Maybe (NExprF NExprLoc)
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"How can an assert be used, but its condition not?"

    NAssert Maybe NExprLoc
_ (Just (AnnE 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
nNull

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

    NIf Maybe NExprLoc
_ Maybe NExprLoc
Nothing (Just (AnnE 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 (AnnE 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 :: * -> *) (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 [Antiquoted Text (Maybe NExprLoc)]
xs) =
    [Antiquoted Text NExprLoc] -> NString NExprLoc
forall r. [Antiquoted Text r] -> NString r
DoubleQuoted ((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 (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 Text
n) = Text -> NKeyName NExprLoc
forall r. Text -> NKeyName r
StaticKey Text
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 = Text -> NKeyName NExprLoc
forall r. Text -> NKeyName r
StaticKey Text
"<unused?>"

  pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
  pruneParams :: Params (Maybe NExprLoc) -> Params NExprLoc
pruneParams (Param Text
n) = Text -> Params NExprLoc
forall r. Text -> Params r
Param Text
n
  pruneParams (ParamSet ParamSet (Maybe NExprLoc)
xs Bool
b Maybe Text
n) =
    ParamSet NExprLoc -> Bool -> Maybe Text -> Params NExprLoc
forall r. ParamSet r -> Bool -> Maybe Text -> Params r
ParamSet ((Text, Maybe (Maybe NExprLoc)) -> (Text, Maybe NExprLoc)
reduceOrPassMode ((Text, Maybe (Maybe NExprLoc)) -> (Text, Maybe NExprLoc))
-> ParamSet (Maybe NExprLoc) -> ParamSet NExprLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParamSet (Maybe NExprLoc)
xs) Bool
b Maybe Text
n
   where
    reduceOrPassMode :: (Text, Maybe (Maybe NExprLoc)) -> (Text, Maybe NExprLoc)
reduceOrPassMode =
      (Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> (Text, Maybe (Maybe NExprLoc)) -> (Text, Maybe NExprLoc)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
 -> (Text, Maybe (Maybe NExprLoc)) -> (Text, Maybe NExprLoc))
-> (Maybe (Maybe NExprLoc) -> Maybe NExprLoc)
-> (Text, Maybe (Maybe NExprLoc))
-> (Text, 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
nNull)
          (Options -> Bool
reduceSets 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
nNull)

  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)
-> 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 (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) [NKeyName (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
m) [NKeyName (Maybe NExprLoc)]
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
-> [NKeyName NExprLoc] -> SourcePos -> Binding NExprLoc
forall r. Maybe r -> [NKeyName r] -> SourcePos -> Binding r
Inherit Maybe NExprLoc
m (NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc
pruneKeyName (NKeyName (Maybe NExprLoc) -> NKeyName NExprLoc)
-> [NKeyName (Maybe NExprLoc)] -> [NKeyName NExprLoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [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 NExprLocF (m a) -> m a
eval Maybe FilePath
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 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 (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') ((r -> m (Either r a)) -> m (Either r a))
-> (r -> m (Either r a)) -> m (Either r a)
forall a b. (a -> b) -> a -> b
$ 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 ((e -> Options) -> m Options) -> (e -> Options) -> m Options
forall a b. (a -> b) -> a -> b
$ 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'
    pure (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 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
  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 :: Text -> Reducer m (Maybe NExprLoc)
lookupVar     = Text -> Reducer m (Maybe NExprLoc)
forall (m :: * -> *) a e.
(MonadReader e m, Has e (Scopes m a)) =>
Text -> m (Maybe a)
lookupVarReader