root/src/Pugs/Junc.hs

{-# OPTIONS_GHC -fglasgow-exts #-}

{-|
    Junction logic.

>   Still round the corner there may wait
>   A new road or a secret gate,
>   And though we pass them by today,
>   Tomorrow we may come this way...
-}

module Pugs.Junc (
    ApplyArg(..),
    opJunc, opJuncNone, opJuncAll, opJuncAny, opJuncOne,
    juncApply,
) where
import Pugs.Types
import Pugs.Internals
import Pugs.AST
import qualified Data.Set as Set

{-|
Construct a @none(...)@ junction from a list of values.

Delegates to 'opJunc'.
-}
opJuncNone :: [Val] -> Val
opJuncNone = opJunc JNone

{-|
Construct an @all(...)@ junction from a list of values.

Delegates to 'opJunc'.
-}
opJuncAll :: [Val] -> Val
opJuncAll = opJunc JAll

{-|
Construct a n@any(...)@ junction from a list of values.

Delegates to 'opJunc'.
-}
opJuncAny :: [Val] -> Val
opJuncAny = opJunc JAny

{-|
Construct a @one(...)@ junction from a list of values.

Does /not/ delegate to 'opJunc'!
-}
opJuncOne :: [Val] -> Val
opJuncOne args = VJunc (MkJunc JOne dups vals)
    where
    vals = Set.fromList [ v | [v] <- groups ]
    dups = Set.fromList [ v | (v:_:_) <- groups ]
    groups = group $ sort args

{-|
Construct a junction of the specified junctive type, containing all the
values in the list.
-}
opJunc :: JuncType -> [Val] -> Val
opJunc t vals = VJunc $ MkJunc t Set.empty (joined `Set.union` Set.fromList vs)
    where
    joined = Set.unions $ map (\(VJunc s) -> juncSet s) js
    (js, vs) = partition sameType vals
    sameType (VJunc (MkJunc t' _ _))  = t == t'
    sameType _                      = False

{-|
Merge the contents of two @any@ or @one@ junctions into a single, combined 
junction value.

For 'Pugs.Internals.JAny', values are simply collapsed into @Set@s (duplicate
values are discarded).

For 'Pugs.Internals.JOne', newly-created duplicates are extracted from the 
combined list of values and moved into the combined set of duplicates.
-}
mergeJunc :: JuncType -- ^ Type of the junctions being combined
          -> [Val]    -- ^ Concatenated list of duplicates (only used for @one@)
          -> [Val]    -- ^ Concatenated list of regular values
          -> VJunc
mergeJunc j ds vs
    = case j of
       JAny -> MkJunc j (Set.fromList ds) (Set.fromList vs)
       JOne -> MkJunc j dups vals
       x    -> internalError $ "mergeJunc pattern failure: " ++ (show x)
    where
    vals = Set.fromList [ v | [v] <- group $ sort vs ]
    dups = Set.fromList (ds ++ [ v | (v:_:_) <- group $ sort (vs ++ ds) ])

-- OK... Now let's implement the hideously clever autothreading algorithm.
-- First pass - thread thru all() and none()
-- Second pass - thread thru any() and one()

{-|
Core of the \"hideously clever\" autothreading algorithm.

This function scans through the list of 'ApplyArg's, finds the first
uncollapsed junction, and transposes e.g. @foo($a|$b|$c)@ into
@( foo($a) | foo($b) | foo($c) )@.

It then recursively applies itself to each of those newly-created \'threads\', 
so ultimately all the call's arguments are properly collapsed.

The scanning process will thread through @all@ and @none@ before it threads
through @any@ and @one@.

>[09:09] <scook0> any specific reason for all() & none() getting autothreaded before one() & any()?
>[09:10] <autrijus> scook0: specced this way.
>[09:10] <autrijus> I don't think S09 gives reasons

<http://dev.perl.org/perl6/doc/design/syn/S09.html>

Once all the args /are/ collapsed, we call the (Haskell) function that 
'juncApply'\'s was given, passing to it the final list of collapsed args.
This happens once for /each/ possible combination of (collapsed) arguments.
The function is expected to perform the actual subroutine call.

Note that 'juncApply' takes place /after/ parameter binding (because it must),
but /before/ we actually introduce any bindings into the sub's lexical scope
(because otherwise we wouldn't know which value to bind).
-}
juncApply :: ([ApplyArg] -> Eval Val) -- ^ Function to call once we know the
                                      --     collapsed arg values
          -> [ApplyArg]               -- ^ List of arguments to autothread over
          -> Eval Val
juncApply f args
    | this@(_, (pivot:_)) <- break isTotalJunc args
    , VJunc (MkJunc j dups vals) <- argValue pivot
    = do
        vals' <- appList this vals
        return $ VJunc (MkJunc j dups (Set.fromList vals'))
    | this@(_, (pivot:_)) <- break isPartialJunc args
    , VJunc (MkJunc j dups vals) <- argValue pivot
    = do
        dups' <- appList this dups
        vals' <- appList this vals
        return $ VJunc (mergeJunc j dups' vals')
    | (val:_) <- [ val | (ApplyArg _ val@(VError _ _) _) <- args ]
    = return val
    | otherwise
    = f args
    where
    appList :: ([ApplyArg], [ApplyArg]) -> Set Val -> Eval [Val]
    appList (before, (ApplyArg name _ coll):after) vs = do
        env <- ask
        io $ do
            mvars   <- forM (Set.elems vs) $ \v -> do
                mv  <- newEmptyMVar
                forkIO $ do
                    val <- runEvalIO env $ juncApply f (before ++ (ApplyArg name v coll:after))
                    putMVar mv val
                return mv
            mapM takeMVar mvars
    appList _ _ = internalError "appList: list doesn't begin with ApplyArg"

{-|
Return @True@ if the given 'ApplyArg' (autothreaded argument) represents a
junction value that is @all@ or @none@, /and/ still needs to autothreaded.

Other junctions, total junctions that don't need collapsing, and non-junction
values will all produce @False@.
-}
isTotalJunc :: ApplyArg -> Bool
isTotalJunc arg
    | (ApplyArg _ (VJunc j) b) <- arg
    , (juncType j ==) `any` [JAll, JNone]
    = not b
    | otherwise
    = False

{-|
Return @True@ if the given 'ApplyArg' (autothreaded argument) represents a
junction value that is @one@ or @any@, /and/ still needs to be autothreaded.

Other junctions, partial junctions that don't need collapsing, and non-junction
values will all produce @False@.
-}
isPartialJunc :: ApplyArg -> Bool
isPartialJunc arg
    | (ApplyArg _ (VJunc j) b) <- arg
    , (juncType j ==) `any` [JOne, JAny]
    = not b
    | otherwise
    = False

{-|
Represents a sub argument during the junction autothreading process.

Note that 'argCollapsed' is set to @True@ only if the corresponding sub param
is explicitly specified as accepting the Perl 6 type @Junc@.
-}
data ApplyArg = ApplyArg
    { argName       :: !Var     -- ^ Name of the param that this arg is for
    , argValue      :: !Val     -- ^ Actual argument value, which may still be
                                --     a junction
    , argCollapsed  :: !Bool    -- ^ @True@ if we have confirmed that this arg
                                --     doesn't need any further autothreading
    }
    deriving (Show, Eq, Ord)

---------------------

{-

bool = ["0", "1"]
test = do
    sequence [ testJunc out inn nest | out <- junc, inn <- junc, nest <- [True, False] ]

testJunc out inn nest = do
    let foo = [ blah a b c out inn nest | a <- bool, b <- bool, c <- bool ]
    when (all id foo) $ if nest
        then print (out, inn)
        else print (out)

junc = ["any", "one", "all", "none"]
out1 = "any"
inn1 = "any"

blah a b c out inn nest = want == has
    where
    want = opEval emptyEnv $ "? " ++ out1 ++ "( " ++ inn1 ++ "( " ++ a ++ ", " ++ b ++ " ), " ++ inn1 ++ "( " ++ b ++ ", " ++ " " ++ c ++ " ) )"
    has | nest = opEval emptyEnv $ "? " ++ out ++ "( " ++ b ++ ", " ++ inn ++ "(" ++ a ++ ", " ++ c ++ "))"
        | otherwise = opEval emptyEnv $ "? " ++ out ++ "( " ++ b ++ ", " ++ a ++ ", " ++ c ++ ")"
-}