NoAnn.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}

-- | Reduction algorithm.
--
-- Doesn't use or preserve annotations.
module Descript.BasicInj.Process.Reduce.NoAnn
  ( interpret
  , reducePhase
  , reduceReg
  ) where

import Descript.BasicInj.Process.Reduce.PropTrans
import Descript.BasicInj.Process.Reduce.Match
import qualified Descript.BasicInj.Data.Value.Reg as Reg
import qualified Descript.BasicInj.Data.Value.In as In
import qualified Descript.BasicInj.Data.Value.Out as Out
import Descript.BasicInj.Data
import Descript.Misc
import Data.Monoid
import Core.Data.Functor
import Data.Foldable
import Data.Proxy
import Data.Maybe
import Data.List
import Core.Data.List
import Core.Data.List.Assoc hiding (Value)
import qualified Data.List.NonEmpty as NonEmpty
import Control.Monad
import Core.Control.Monad.Trans
import Control.Monad.Trans.Writer
import Prelude hiding (mod)

class (GenPart p, Eq (p ()), (PartPropVal p ~ GenValue p)) => NormReducePart p where
  reducePartProps :: PhaseCtx () -> p () -> p ()

instance NormReducePart Reg.Part where
  reducePartProps _ (Reg.PartPrim prim) = Reg.PartPrim prim
  reducePartProps ctx (Reg.PartRecord record)
    = Reg.PartRecord $ reduceRecordProps ctx record

reduceInPartProps :: PhaseCtx ()
                  -> In.Part ()
                  -> WriterT PropTranses [] (In.Part ())
reduceInPartProps _ (In.PartPrim prim) = pure $ In.PartPrim prim
reduceInPartProps _ (In.PartPrimType ptype) = pure $ In.PartPrimType ptype
reduceInPartProps ctx (In.PartRecord record)
  = In.PartRecord <$> reduceInRecordProps ctx record

instance NormReducePart Out.Part where
  reducePartProps _ (Out.PartPrim prim) = Out.PartPrim prim
  reducePartProps ctx (Out.PartRecord record)
    = Out.PartRecord $ reduceOutRecordProps ctx record
  reducePartProps _ (Out.PartPropPath path) = Out.PartPropPath path
  reducePartProps ctx (Out.PartInjApp app)
    = Out.PartInjApp $ reduceInjAppProps ctx app

reduceRecordProps :: PhaseCtx () -> Reg.Record () -> Reg.Record ()
reduceRecordProps = mapPropVals . reduceReg

reduceInRecordProps :: PhaseCtx ()
                    -> In.Record ()
                    -> WriterT PropTranses [] (In.Record ())
reduceInRecordProps ctx (Record () head' props)
  = Record () head' <$> traverse (reduceInRecordProp ctx head') props

reduceInRecordProp :: PhaseCtx ()
                   -> FSymbol ()
                   -> In.Property ()
                   -> WriterT PropTranses [] (In.Property ())
reduceInRecordProp ctx head' (Property () key val)
    = Property () key <$> val'
  where val'
          = censor (subPropTranses pelem)
          $ In.traverseOptVal (reduceInput ctx) val
        pelem = PathElem () key head'

reduceOutRecordProps :: PhaseCtx () -> Out.Record () -> Out.Record ()
reduceOutRecordProps = mapPropVals . reduceOutput

reduceInjAppProps :: PhaseCtx () -> Out.InjApp () -> Out.InjApp ()
reduceInjAppProps = Out.mapInjAppParams . Out.mapInjParamVal . reduceOutput

-- | Interprets the program - reduces its query using its reducers.
interpret :: Depd Program () -> Reg.Value ()
interpret dprog = reduceReg phase0 qval
  where phase0 = reduceAppPhases $ reduceCtx $ dmodule dprog
        qval = queryVal $ dquery dprog

-- | Macro-reduces each of the phases using reducers from the above
-- phase, adding reducers from the above phase along the way, then
-- returns the last phase (which will reduce the query).
reduceAppPhases :: ReduceCtx () -> PhaseCtx ()
reduceAppPhases (ReduceCtx () t xs) = foldl' reduceAppPhase t $ NonEmpty.toList xs

-- | Macro-reduces the second phase using reducers from the first.
-- Then combines the phases.
reduceAppPhase :: PhaseCtx () -> PhaseCtx () -> PhaseCtx ()
reduceAppPhase mctx x = mctx <> reducePhase mctx x

-- | Macro-reduces the second phase using reducers from the first.
reducePhase :: PhaseCtx () -> PhaseCtx () -> PhaseCtx ()
reducePhase mctx (PhaseCtx () xs)
  = PhaseCtx () $ concatMap (reduceReducer mctx) xs

-- | Macro-reduces the input and output (ctx is macros).
reduceReducer :: PhaseCtx () -> Reducer () -> [Reducer ()]
reduceReducer ctx (Reducer () input' output')
  = reduceReducerOut ctx output' <$> reduceInput' ctx input'

-- | Continues reducing the output using effects from the reduced input,
-- then creates the reduced reducer.
reduceReducerOut :: PhaseCtx ()
                 -> Out.Value ()
                 -> (In.Value (), PropTranses)
                 -> Reducer ()
reduceReducerOut ctx output' (newIn, outTranses)
  = Reducer () newIn newOut
  where newOut = reduceOutput ctx $ apPropTranses newIn outTranses output'

-- | Applies the context's reducers to the value, until they can't
-- be applied anymore.
reduceReg :: PhaseCtx () -> Reg.Value () -> Reg.Value ()
reduceReg = reduceNorm

-- | Applies the context's reducers to the output value, until they
-- can't be applied anymore.
reduceOutput :: PhaseCtx () -> Out.Value () -> Out.Value ()
reduceOutput = reduceNorm

-- | Applies the context's reducers to the value, until they can't be
-- applied anymore.
reduceNorm :: (NormReducePart p)
           => PhaseCtx ()
           -> GenValue p ()
           -> GenValue p ()
reduceNorm ctx = reduceRest reduceNorm ctx . reduceProps ctx

-- | Applies the context's reducers to the input value, until they can't
-- be applied anymore.
--
-- This also returns transformers which should be applied to the output.
-- Every time a record in the input matches, the corresponding property
-- in the output is transformed to a union of all the locations of that
-- property in the reducer's output.
reduceInput' :: PhaseCtx ()
            -> In.Value ()
            -> [(In.Value (), PropTranses)]
reduceInput' ctx = runWriterT . reduceInput ctx

reduceInput :: PhaseCtx ()
            -> In.Value ()
            -> WriterT PropTranses [] (In.Value ())
reduceInput ctx = reduceInRest reduceInput ctx <=< reduceInProps ctx

-- | Applies the context's reducers to the value's properties,
-- until they can't be applied anymore.
reduceProps :: (NormReducePart p) => PhaseCtx () -> GenValue p () -> GenValue p ()
reduceProps ctx (Value () parts)
  = Value () $ map (reducePartProps ctx) parts

reduceInProps :: PhaseCtx ()
              -> In.Value ()
              -> WriterT PropTranses [] (In.Value ())
reduceInProps ctx (Value () parts)
  = Value () <$> traverse (reduceInPartProps ctx) parts

-- | Applies the context's reducers to the value's head.
-- If the value reduced, applies the given reducer to reduce it more.
-- Otherwise just returns it as-is.
reduceRest :: (NormReducePart p)
           => (PhaseCtx () -> GenValue p () -> GenValue p ())
           -> PhaseCtx () -> GenValue p () -> GenValue p ()
reduceRest reduceMore ctx value
  = case reduceOnce ctx value of
         Failure () -> value
         Success next -> reduceMore ctx next

reduceInRest :: (PhaseCtx () -> In.Value () -> WriterT PropTranses [] (In.Value ()))
             -> PhaseCtx () -> In.Value () -> WriterT PropTranses [] (In.Value ())
reduceInRest reduceInMore ctx value
  = mapWriterT continue $ reduceInOnce ctx value
  where continue = concatMap (runWriterT . continue') . runResultT
        continue' (Failure ()) = pure value
        continue' (Success (next, effTrs)) = do
          tell effTrs
          reduceInMore ctx next

-- | Applies the context's reducers to the value once, returning a new
-- value if it reduced, or a failure if it couldn't be reduced at all.
reduceOnce :: (NormReducePart p)
           => PhaseCtx ()
           -> GenValue p ()
           -> UResult (GenValue p ())
reduceOnce ctx value
  | next == value = Failure ()
  | otherwise = Success next
  where next = tryReduceOnce ctx value

reduceInOnce :: PhaseCtx ()
             -> In.Value ()
             -> WriterT PropTranses (ResultT () []) (In.Value ())
reduceInOnce ctx value
  = mapWriterT continue $ tryReduceInOnce ctx value
  where continue = ResultT . map continue'
        continue' (next, effTrs)
          | next == value = Failure ()
          | otherwise = Success (next, effTrs)

-- | Applies the context's reducers to the value once. If none of them
-- could be applied (the value didn't reduce), just returns the same value.
tryReduceOnce :: (NormReducePart p)
              => PhaseCtx ()
              -> GenValue p ()
              -> GenValue p ()
tryReduceOnce (PhaseCtx () reducers) value
  = foldl' (flip tryReduceIndiv) value reducers

tryReduceInOnce :: PhaseCtx ()
                -> In.Value ()
                -> WriterT PropTranses [] (In.Value ())
tryReduceInOnce (PhaseCtx () reducers) value
  = foldM (flip tryReduceInIndiv) value reducers

-- | Applies the individual reducer to the value if it can be applied.
-- Otherwise just returns the value.
tryReduceIndiv :: (NormReducePart p)
               => Reducer ()
               -> GenValue p ()
               -> GenValue p ()
tryReduceIndiv reducer value
  = case reduceIndiv reducer value of
         Failure () -> value
         Success next -> next

tryReduceInIndiv :: Reducer ()
                 -> In.Value ()
                 -> WriterT PropTranses [] (In.Value ())
tryReduceInIndiv reducer value
  = mapWriterT continue $ reduceInIndiv reducer value
  where continue = map continue' . runResultT
        continue' (Failure ()) = (value, [])
        continue' (Success (next, effTrs)) = (next, effTrs)

-- | Applies the individual reducer to the value if it can be applied.
-- Otherwise returns a failure.
reduceIndiv :: (NormReducePart p)
            => Reducer ()
            -> GenValue p ()
            -> UResult (GenValue p ())
reduceIndiv reducer
  = fmap (produce $ output reducer)
  . consume (input reducer)

reduceInIndiv :: Reducer ()
              -> In.Value ()
              -> WriterT PropTranses (ResultT () []) (In.Value ())
reduceInIndiv reducer
  = WriterT
  . fmap (produceIn $ output reducer)
  . consumeIn (input reducer)

-- | Tries to match the input value to the given value.
consume :: (NormReducePart p)
        => In.Value ()
        -> GenValue p ()
        -> UResult (Match (GenValue p ()))
consume (Value () inParts) value
  = foldM (flip consumePartInMatch) (emptyMatch value) inParts

consumeIn :: In.Value ()
          -> In.Value ()
          -> UResultT [] (Match (In.Value ()))
consumeIn (Value () inParts) value
  = foldM (flip consumeInPartInMatch) (emptyMatch value) inParts

consumePartInMatch :: (NormReducePart p)
                   => In.Part ()
                   -> Match (GenValue p ())
                   -> UResult (Match (GenValue p ()))
consumePartInMatch = matchAgainF . consumePartInValue

consumeInPartInMatch :: In.Part ()
                     -> Match (In.Value ())
                     -> UResultT [] (Match (In.Value ()))
consumeInPartInMatch = matchAgainF . consumeInPartInValue

consumePartInValue :: (NormReducePart p)
                   => In.Part ()
                   -> GenValue p ()
                   -> UResult (Match (GenValue p ()))
consumePartInValue (In.PartPrim inPrim) (Value () parts)
  | inPart `notElem` parts = Failure ()
  | otherwise
  = Success Match
  { matched = Value () [inPart]
  , leftover = Value () $ inPart `delete` parts
  }
  where inPart = primToPart Proxy inPrim
consumePartInValue (In.PartPrimType inType) (Value () parts)
  = Value () <<$>> consumePrimTypeInParts inType parts
consumePartInValue (In.PartRecord inRec) (Value () parts)
  = Value () <<$>> consumeRecordInParts inRec parts

consumeInPartInValue :: In.Part ()
                     -> In.Value ()
                     -> UResultT [] (Match (In.Value ()))
consumeInPartInValue inPart@(In.PartPrim _) (Value () parts)
  | inPart `notElem` parts = mkUFailureT
  | otherwise
  = mkSuccessT Match
  { matched = Value () [inPart]
  , leftover = Value () $ inPart `delete` parts
  }
consumeInPartInValue (In.PartPrimType inType) (Value () parts)
  = hoist $ Value () <<$>> consumePrimTypeInParts inType parts
consumeInPartInValue (In.PartRecord inRec) (Value () parts)
  = Value () <<$>> consumeInRecordInParts inRec parts

consumePrimTypeInParts :: (GenPart p)
                       => PrimType ()
                       -> [p ()]
                       -> UResult (Match [p ()])
consumePrimTypeInParts _ [] = Failure ()
consumePrimTypeInParts inType (part : parts)
  = case consumePrimTypeInPart inType part of
         Failure ()
            -> mapLeftover (part :)
           <$> consumePrimTypeInParts inType parts
         Success ()
           -> Success Match
            { matched = [part]
            , leftover = parts
            }

consumePrimTypeInPart :: (GenPart p)
                      => PrimType ()
                      -> p ()
                      -> UResult ()
consumePrimTypeInPart inType part
  = case partToPrim part of
         Nothing -> Failure ()
         Just prim
           | prim `isPrimInstance` inType -> Success ()
           | otherwise -> Failure ()

consumeRecordInParts :: (NormReducePart p)
                     => In.Record ()
                     -> [p ()]
                     -> UResult (Match [p ()])
consumeRecordInParts _ [] = Failure ()
consumeRecordInParts inRec (part : parts)
  = case consumeRecordInPart inRec part of
         Failure ()
            -> mapLeftover (part :)
           <$> consumeRecordInParts inRec parts
         Success (Match partMatch partLeftover)
           -> Success Match
            { matched = maybeToList partMatch
            , leftover = partLeftover ?: parts
            }

consumeInRecordInParts :: In.Record ()
                       -> [In.Part ()]
                       -> UResultT [] (Match [In.Part ()])
consumeInRecordInParts _ [] = mkUFailureT
consumeInRecordInParts inRec (part : parts)
  = bindStackOuter continue $ consumeInRecordInPart inRec part
  where continue (Failure ())
            = mapLeftover (part :)
          <$> consumeInRecordInParts inRec parts
        continue (Success (Match partMatch partLeftover))
          = mkSuccessT Match
          { matched = maybeToList partMatch
          , leftover = partLeftover ?: parts
          }

consumeRecordInPart :: (NormReducePart p)
                    => In.Record ()
                    -> p ()
                    -> UResult (Match (Maybe (p ())))
consumeRecordInPart inRec part
  = case partToRec part of
         Nothing -> Failure ()
         Just record -> recToPart Proxy <<<$>>> consumeRecord inRec record

consumeInRecordInPart :: In.Record ()
                      -> In.Part ()
                      -> UResultT [] (Match (Maybe (In.Part ())))
consumeInRecordInPart _ (In.PartPrim _) = mkUFailureT
consumeInRecordInPart _ (In.PartPrimType _) = mkUFailureT
consumeInRecordInPart inRec (In.PartRecord record)
  = In.PartRecord <<<$>>> consumeInRecord inRec record

consumeRecord :: (NormReducePart p)
              => In.Record ()
              -> PartRecord p ()
              -> UResult (Match (Maybe (PartRecord p ())))
consumeRecord (Record () inRecHead inRecProps) (Record () recHead recProps)
        | inRecHead /= recHead = Failure ()
        | otherwise
        = Record () recHead
  <<<$>>> bimapMatch Just justIfNonEmptyList
      <$> consumeProperties inRecProps recProps

consumeInRecord :: In.Record ()
                -> In.Record ()
                -> UResultT [] (Match (Maybe (In.Record ())))
consumeInRecord (Record () inRecHead inRecProps) (Record () recHead recProps)
        | inRecHead /= recHead = mkUFailureT
        | otherwise
        = Record () recHead
  <<<$>>> bimapMatch Just justIfNonEmptyList
      <$> consumeInProperties inRecProps recProps

consumeProperties :: (NormReducePart p)
                  => [In.Property ()]
                  -> [PartProperty p ()]
                  -> UResult (Match [PartProperty p ()])
consumeProperties _ [] = Success $ pure []
consumeProperties inProps (prop : props)
  = case consumePropertiesInProperty inProps prop of
         Failure () -> Failure ()
         Success match
            -> addPropValMatch prop match
           <$> consumeProperties inProps props

consumeInProperties :: [In.Property ()]
                    -> [In.Property ()]
                    -> UResultT [] (Match [In.Property ()])
consumeInProperties _ [] = mkSuccessT $ pure []
consumeInProperties inProps (prop : props)
  = bindStackOuter continue $ consumeInPropertiesInProperty inProps prop
  where continue (Failure ()) = mkUFailureT
        continue (Success match)
            = addPropValMatch prop match
          <$> consumeInProperties inProps props

consumePropertiesInProperty :: (NormReducePart p)
                            => [In.Property ()]
                            -> PartProperty p ()
                            -> UResult (Match (Maybe (GenValue p ())))
consumePropertiesInProperty inProps (Property () propKey propVal)
  = case glookupForce propKey inProps of
         In.NothingValue
           -> Success Match
            { matched = Just propVal
            , leftover = Nothing
            }
         In.JustValue inPropVal
            -> bimapMatch Just justIfNonEmptyVal
           <$> consume inPropVal propVal

consumeInPropertiesInProperty :: [In.Property ()]
                              -> In.Property ()
                              -> UResultT [] (Match (Maybe (In.OptValue ())))
consumeInPropertiesInProperty inProps (Property () propKey propVal)
  = case glookupForce propKey inProps of
         In.NothingValue
           -> mkSuccessT Match
            { matched = Just propVal
            , leftover = Nothing
            }
         In.JustValue inPropVal
            -> bimapMatch Just justIfNonEmptyOptVal
           <$> consumeInOpt inPropVal propVal

consumeInOpt :: In.Value ()
             -> In.OptValue ()
             -> UResultT [] (Match (In.OptValue ()))
consumeInOpt _ In.NothingValue = ResultT [Failure ()]
{- Should the case be this instead?
  [ -- consumeIn input input
    Success Match
    { matched = In.JustValue input'
    , leftover = mempty -- JustValue $ Value () []
    }
  , Failure ()
  ]
-}
consumeInOpt input' (In.JustValue x)
  = In.JustValue <<$>> consumeIn input' x

addPropValMatch :: GenProperty v ()
                -> Match (Maybe (v ()))
                -> Match [GenProperty v ()]
                -> Match [GenProperty v ()]
addPropValMatch (Property () propKey _) propVal props
  = (?:) <$> prop <*> props
  where prop = Property () propKey <<$>> propVal

justIfNonEmptyOptVal :: In.OptValue () -> Maybe (In.OptValue ())
justIfNonEmptyOptVal In.NothingValue = Just In.NothingValue
justIfNonEmptyOptVal (In.JustValue x) = In.JustValue <$> justIfNonEmptyVal x

justIfNonEmptyVal :: GenValue v () -> Maybe (GenValue v ())
justIfNonEmptyVal x
  | isEmpty x = Nothing
  | otherwise = Just x

justIfNonEmptyList :: [a] -> Maybe [a]
justIfNonEmptyList x
  | null x = Nothing
  | otherwise = Just x

-- | Resolves the property paths in the output value using the given
-- value, and combines the result with the given value.
produce :: (NormReducePart p)
        => Out.Value ()
        -> Match (GenValue p ())
        -> GenValue p ()
produce output' match
  = leftover match <> resolve output' (matched match)

produceIn :: Out.Value ()
          -> Match (In.Value ())
          -> (In.Value (), PropTranses)
produceIn output' match
  = (produceInMain output' match, transProps output' $ matched match)

-- | Resolves the property paths in the output value using the given
-- value, and combines the result with the given value.
produceInMain :: Out.Value () -> Match (In.Value ()) -> In.Value ()
produceInMain output' match
  = leftover match <> resolveIn' output' (matched match)

-- | Resolves all property paths in the output value using the given value.
-- Replaces all paths with the corresponding properties in the given
-- value.
resolve :: (NormReducePart p)
        => Out.Value ()
        -> GenValue p ()
        -> GenValue p ()
resolve (Value () outParts) value
  = mconcat $ map resolvePart outParts
  where resolvePart (Out.PartPrim prim)
          = singletonValue $ primToPart Proxy prim
        resolvePart (Out.PartRecord record)
          = singletonValue
          $ recToPart Proxy
          $ mapPropVals (`resolve` value)
            record
        resolvePart (Out.PartPropPath path) = resolvePropPath path value
        resolvePart (Out.PartInjApp app) = resolveInjApp app value

resolveIn' :: Out.Value () -> In.Value () -> In.Value ()
resolveIn' output' value
  = case resolveIn output' $ In.JustValue value of
         In.NothingValue -> error "Bad macro - reduces input to free bind"
         In.JustValue x -> x

resolveIn :: Out.Value ()
          -> In.OptValue ()
          -> In.OptValue ()
resolveIn (Value () outParts) value
  = mconcat $ map resolvePart outParts
  where resolvePart (Out.PartPrim prim)
          = In.JustValue $ singletonValue $ primToPart Proxy prim
        resolvePart (Out.PartRecord record)
          = In.JustValue
          $ singletonValue
          $ recToPart Proxy
          $ mapPropVals (`resolveIn` value)
            record
        resolvePart (Out.PartPropPath path) = resolveInPropPath path value
        resolvePart (Out.PartInjApp app) = In.JustValue $ resolveInInjApp app value

-- | Resolves the property path using the given value.
-- Replaces it with the corresponding property in the given value.
resolvePropPath :: (NormReducePart p)
                => PropPath ()
                -> GenValue p ()
                -> GenValue p ()
resolvePropPath (PropPath () xs) = resolveSubpath $ NonEmpty.toList xs

resolveInPropPath :: PropPath ()
                  -> In.OptValue ()
                  -> In.OptValue ()
resolveInPropPath (PropPath () xs) = resolveInSubpath $ NonEmpty.toList xs

resolveSubpath :: (NormReducePart p)
               => [PathElem ()]
               -> GenValue p ()
               -> GenValue p ()
resolveSubpath [] = id
resolveSubpath (x : xs) = resolveSubpath xs . resolveElem x

resolveInSubpath :: [PathElem ()]
                 -> In.OptValue ()
                 -> In.OptValue ()
resolveInSubpath [] = id
resolveInSubpath (x : xs) = resolveInSubpath xs . resolveInElem x

resolveElem :: (NormReducePart p)
            => PathElem ()
            -> GenValue p ()
            -> GenValue p ()
resolveElem (PathElem () keyRef' headRef')
  = forceLookupProp keyRef' . forceRecWithHead headRef'

resolveInElem :: PathElem ()
              -> In.OptValue ()
              -> In.OptValue ()
resolveInElem _ In.NothingValue
  = error "Bad macro - references property of free bind"
resolveInElem (PathElem () keyRef' headRef') (In.JustValue val)
  = forceLookupProp keyRef' $ forceRecWithHead headRef' val

-- | Finds the injected function, resolves the arguments, then applies
-- the function with every possible primitive combination until it
-- returns a result.
resolveInjApp :: (NormReducePart p)
              => Out.InjApp ()
              -> GenValue p ()
              -> GenValue p ()
resolveInjApp app x = applyInj func params
  where func = forceLookupFunc $ Out.funcId app
        params = map ((`resolve` x) . Out.injParamVal) $ Out.params app

resolveInInjApp :: Out.InjApp ()
                -> In.OptValue ()
                -> In.Value ()
resolveInInjApp app x = applyInj func params
  where func = forceLookupFunc $ Out.funcId app
        params
          = mapMaybe (In.optValToMaybeVal . (`resolveIn` x) . Out.injParamVal)
          $ Out.params app

-- Applies the function with every possible primitive combination given
-- the arguments until it returns a result. Fails if no combinations work.
applyInj :: (GenPart p) => InjFunc -> [GenValue p ()] -> GenValue p ()
applyInj func params
  = case tryApplyInj func params of
         Failure () -> error "Injected function couldn't be applied to parameters"
         Success out -> out

-- Applies the function with every possible primitive combination given
-- the arguments until it returns a result.
tryApplyInj :: (GenPart p)
            => InjFunc
            -> [GenValue p ()]
            -> UResult (GenValue p ())
tryApplyInj = applyInjUsing []

applyInjUsing :: (GenPart p)
              => [Prim ()]
              -> InjFunc
              -> [GenValue p ()]
              -> UResult (GenValue p ())
applyInjUsing revSelParams func []
  = case func selParams of
         Nothing -> Failure ()
         Just out -> Success $ singletonValue $ primToPart Proxy out
  where selParams = reverse revSelParams
applyInjUsing revSelParams func (nextParam : restParams)
  = asum $ map applyInjUsingNext $ primParts nextParam
  where applyInjUsingNext nextSelParam = applyInjUsing (nextSelParam : revSelParams) func restParams

transProps :: Out.Value () -> In.Value () -> PropTranses
transProps output' = map (`transPath` output') . pathsInVal

pathsInVal :: In.Value () -> [PropPath ()]
pathsInVal (Value () parts) = concatMap pathsInPart parts

pathsInPart :: In.Part () -> [PropPath ()]
pathsInPart (In.PartPrim _) = []
pathsInPart (In.PartPrimType _) = []
pathsInPart (In.PartRecord record) = pathsInRecord record

pathsInRecord :: In.Record () -> [PropPath ()]
pathsInRecord (Record () head' props) = concatMap (pathsInProp head') props

pathsInProp :: FSymbol ()
            -> In.Property ()
            -> [PropPath ()]
pathsInProp head' (Property () key val)
  = immPath elem' : map (subPath elem') (pathsInOptVal val)
  where elem' = PathElem () key head'

pathsInOptVal :: In.OptValue () -> [PropPath ()]
pathsInOptVal In.NothingValue = []
pathsInOptVal (In.JustValue x) = pathsInVal x

transPath :: PropPath () -> Out.Value () -> PropTrans
transPath inPath = PropTrans inPath . transOutsInVal inPath

transOutsInVal :: PropPath () -> Out.Value () -> [SubPropPath ()]
transOutsInVal inPath (Value () parts) = concatMap (transOutsInPart inPath) parts

transOutsInPart :: PropPath () -> Out.Part () -> [SubPropPath ()]
transOutsInPart _ (Out.PartPrim _) = []
transOutsInPart inPath (Out.PartRecord record)
  = transOutsInRecord inPath record
transOutsInPart inPath (Out.PartPropPath path)
  = transOutsInPath inPath path
transOutsInPart inPath (Out.PartInjApp app)
  = transOutsInInjApp inPath app

transOutsInRecord :: PropPath () -> Out.Record () -> [SubPropPath ()]
transOutsInRecord inPath (Record () head' props)
  = concatMap (transOutsInProp inPath head') props

transOutsInProp :: PropPath () -> FSymbol () -> Out.Property () -> [SubPropPath ()]
transOutsInProp inPath head' (Property () key val)
  = map (elem' :) $ transOutsInVal inPath val
  where elem' = PathElem () key head'

-- | Name is misleading out of context - the old property path will
-- transform into the location of this property path if both paths are
-- equal.
transOutsInPath :: PropPath () -> PropPath () -> [SubPropPath ()]
transOutsInPath inPath path
  | inPath == path = [[]]
  | otherwise = []

transOutsInInjApp :: PropPath () -> Out.InjApp () -> [SubPropPath ()]
transOutsInInjApp _ _
  = error "Macros deconstructing injected applications is unsupported. \
          \Wrap the injected application in a regular record, then \
          \deconstruct that record instead."