Arity.hs

-- | Slurp out arities of function bindings.
--   and infer arities for primitives based on their types.
--
--   For function bindings the arity is the number of outer-most lambdas
--   in the definition. 
--
--   For primitives, the arity is the number of function
--   constructors in its type. 
--
module DDC.Core.Analysis.Arity
        ( -- * Arities map
          Arities
        , emptyArities
        , extendsArities
        , getArity

          -- * Arity analysis
        , aritiesOfModule
        , aritiesOfLets
        , aritiesOfPat
        , arityFromType
        , arityOfExp)
where
import DDC.Core.Predicates
import DDC.Core.Compounds
import DDC.Core.Module
import DDC.Core.Exp
import DDC.Data.ListUtils
import Control.Monad
import Data.Maybe
import qualified Data.Map       as Map


-- | Arities of named and anonymous bindings.
type Arities n = (Map.Map n Int, [Int])


-- | Empty arities context.
emptyArities :: Ord n => Arities n
emptyArities = (Map.empty, [])


-- | Extend map with some binders and their arities.
extendsArities :: Ord n => Arities n -> [(Bind n, Int)] -> Arities n
extendsArities arity exts = foldl go arity exts
 where  go (named, anon) (BNone _t,   _) = (named,anon)
        go (named, anon) (BAnon _t,   a) = (named, a:anon)
        go (named, anon) (BName n _t, a) = (Map.insert n a named, anon)


-- | Look up a binder's arity from the arity map
--   or determine it from its type in the case of primops.
getArity :: Ord n => Arities n -> Bound n -> Maybe Int
getArity (named, anon) u
 = case u of
        -- Get arities of anonymous things from the stack.
        UIx ix 
         -> let Just x  = index anon ix
            in  Just x

        -- Lookup arities of named things from the stack.
        UName n         -> Map.lookup n named

        -- Get a primitive's arity from its type.
        -- The arities of primitives always match their types, so this is ok.
        UPrim _ t       -> arityFromType t


-- Slurp ----------------------------------------------------------------------
-- | Slurp out arities of imports and top-level bindings from a module.
aritiesOfModule :: Ord n => Module a n -> Arities n
aritiesOfModule mm
  = let (lts, _)        = splitXLets $ moduleBody mm

        aritiesLets     
         = concat $ catMaybes $ map aritiesOfLets  lts

        aritiesImports  
         = catMaybes
         $ [ case arityFromType t of
                Just a  -> Just (BName n t, a)
                Nothing -> Nothing
           | (n, (_, t)) <- Map.toList $ moduleImportTypes mm ]

    in  emptyArities
        `extendsArities` aritiesImports
        `extendsArities` aritiesLets


-- | Get the arities of a `Lets`
aritiesOfLets :: Ord n => Lets a n -> Maybe [(Bind n, Int)]
aritiesOfLets ll
 = let get (b, x)
        = case arityOfExp x of
                Nothing         -> Nothing
                Just a          -> Just (b, a)
   in case ll of
        LLet b x        -> sequence $ map get [(b, x)]
        LRec bxs        -> sequence $ map get bxs
        _               -> Just []


-- | Retrieve binders from case pattern, so we can extend the arity context.
--   We don't know anything about their values, so record as 0.
aritiesOfPat :: Ord n => Pat n -> [(Bind n, Int)]
aritiesOfPat p
 = case p of
        PDefault        -> []
        (PData _b bs)   -> zip bs (repeat 0)


-- | Get the arity of an expression. 
arityOfExp :: Ord n => Exp a n -> Maybe Int
arityOfExp xx
 = case xx of
        -- Counting all binders, because they all correspond to XApps.
        XLam _ _ e      -> liftM (+ 1) $ arityOfExp e
        XLAM _ _ e      -> liftM (+ 1) $ arityOfExp e

        -- Determine a data constructor's arity from its type.
        XCon _ dc       -> arityFromType (typeOfDaCon dc)

        -- Anything else we'll need to apply one at a time
        _               -> Just 0


-- | Determine the arity of an expression by looking at its type.
--   Count all the function arrows, and foralls.
arityFromType :: Ord n => Type n -> Maybe Int
arityFromType tt
        | TForall _ t   <- tt
        = case arityFromType t of
                Nothing -> Nothing
                Just a  -> Just (1 + a)

        | isBot tt
        = Nothing

        | (args, _)     <- takeTFunArgResult tt
        = Just (length args)