{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverlappingInstances   #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# LANGUAGE ViewPatterns           #-}

module Cubix.Analysis.Call.Trivial (
    NodeIdx(..)
  , TrivialCallAnalysisConstraints
  , CallAnalysis(..)
  , TrivialFunctionAnalysisConstraints
  , FunctionAnalysis(..)
  ) where

import Control.Monad.Identity ( Identity(..) )

import           Data.Map ( Map )
import qualified Data.Map as Map

import Data.Foldable ( fold )

import Data.Comp.Multi ( E(..), HTraversable, stripA, (:-<:), All, HFoldable, HFunctor )
import Data.Comp.Multi.Strategic ( TranslateM, GTranslateM, crushtdT, promoteTF, addFail )
import Data.Comp.Multi.Strategy.Classification ( DynCase )

import Cubix.Language.Info
import Cubix.Language.Parametric.InjF
import Cubix.Language.Parametric.Syntax

import Cubix.Sin.Compdata.Annotation ( getAnn )

data NodeIdx = NodeIdx FilePath Label
  deriving ( NodeIdx -> NodeIdx -> Bool
(NodeIdx -> NodeIdx -> Bool)
-> (NodeIdx -> NodeIdx -> Bool) -> Eq NodeIdx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeIdx -> NodeIdx -> Bool
$c/= :: NodeIdx -> NodeIdx -> Bool
== :: NodeIdx -> NodeIdx -> Bool
$c== :: NodeIdx -> NodeIdx -> Bool
Eq, Eq NodeIdx
Eq NodeIdx =>
(NodeIdx -> NodeIdx -> Ordering)
-> (NodeIdx -> NodeIdx -> Bool)
-> (NodeIdx -> NodeIdx -> Bool)
-> (NodeIdx -> NodeIdx -> Bool)
-> (NodeIdx -> NodeIdx -> Bool)
-> (NodeIdx -> NodeIdx -> NodeIdx)
-> (NodeIdx -> NodeIdx -> NodeIdx)
-> Ord NodeIdx
NodeIdx -> NodeIdx -> Bool
NodeIdx -> NodeIdx -> Ordering
NodeIdx -> NodeIdx -> NodeIdx
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NodeIdx -> NodeIdx -> NodeIdx
$cmin :: NodeIdx -> NodeIdx -> NodeIdx
max :: NodeIdx -> NodeIdx -> NodeIdx
$cmax :: NodeIdx -> NodeIdx -> NodeIdx
>= :: NodeIdx -> NodeIdx -> Bool
$c>= :: NodeIdx -> NodeIdx -> Bool
> :: NodeIdx -> NodeIdx -> Bool
$c> :: NodeIdx -> NodeIdx -> Bool
<= :: NodeIdx -> NodeIdx -> Bool
$c<= :: NodeIdx -> NodeIdx -> Bool
< :: NodeIdx -> NodeIdx -> Bool
$c< :: NodeIdx -> NodeIdx -> Bool
compare :: NodeIdx -> NodeIdx -> Ordering
$ccompare :: NodeIdx -> NodeIdx -> Ordering
$cp1Ord :: Eq NodeIdx
Ord, Int -> NodeIdx -> ShowS
[NodeIdx] -> ShowS
NodeIdx -> String
(Int -> NodeIdx -> ShowS)
-> (NodeIdx -> String) -> ([NodeIdx] -> ShowS) -> Show NodeIdx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeIdx] -> ShowS
$cshowList :: [NodeIdx] -> ShowS
show :: NodeIdx -> String
$cshow :: NodeIdx -> String
showsPrec :: Int -> NodeIdx -> ShowS
$cshowsPrec :: Int -> NodeIdx -> ShowS
Show )
type FunctionId = String


newtype AccumMap k v = AccumMap { AccumMap k v -> Map k v
runAccumMap :: Map k v }

mergeKey :: (Ord k, Semigroup v) => k -> v -> Map k v -> Map k v
mergeKey :: k -> v -> Map k v -> Map k v
mergeKey = (v -> v -> v) -> k -> v -> Map k v -> Map k v
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith v -> v -> v
forall a. Semigroup a => a -> a -> a
(<>)

instance (Ord k, Semigroup v) => Semigroup (AccumMap k v) where
  (AccumMap m1 :: Map k v
m1) <> :: AccumMap k v -> AccumMap k v -> AccumMap k v
<> (AccumMap m2 :: Map k v
m2) = Map k v -> AccumMap k v
forall k v. Map k v -> AccumMap k v
AccumMap (Map k v -> AccumMap k v) -> Map k v -> AccumMap k v
forall a b. (a -> b) -> a -> b
$ (k -> v -> Map k v -> Map k v) -> Map k v -> Map k v -> Map k v
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\k :: k
k v :: v
v m :: Map k v
m -> k -> v -> Map k v -> Map k v
forall k v. (Ord k, Semigroup v) => k -> v -> Map k v -> Map k v
mergeKey k
k v
v Map k v
m) Map k v
m2 Map k v
m1

instance (Ord k, Monoid v) => Monoid (AccumMap k v) where
  mempty :: AccumMap k v
mempty = Map k v -> AccumMap k v
forall k v. Map k v -> AccumMap k v
AccumMap (Map k v -> AccumMap k v) -> Map k v -> AccumMap k v
forall a b. (a -> b) -> a -> b
$ Map k v
forall k a. Map k a
Map.empty

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

class CallAnalysis fs where
  callAnalysis :: Project fs -> Map FunctionId [NodeIdx]


type TrivialCallAnalysisConstraints fs = ( FunctionCall :-<: fs, Ident :-<: fs
                                        , InjF fs IdentL FunctionExpL, All HTraversable fs
                                        , DynCase (TermLab fs) FunctionCallL)
type TCAC fs = TrivialCallAnalysisConstraints fs


getCalls' :: (TCAC fs, Monad m) => TranslateM m (TermLab fs) FunctionCallL (AccumMap FunctionId [Label])
getCalls' :: TranslateM m (TermLab fs) FunctionCallL (AccumMap String [Label])
getCalls' t :: TermLab fs FunctionCallL
t@(TermLab fs FunctionCallL
-> Cxt NoHole (Sum fs) (K ()) FunctionCallL
forall (g :: (* -> *) -> * -> *) (f :: (* -> *) -> * -> *).
(RemA g f, HFunctor g) =>
CxtFun g f
stripA -> FunctionCall' _ f :: CxtS NoHole fs (K ()) FunctionExpL
f _) = AccumMap String [Label] -> m (AccumMap String [Label])
forall (m :: * -> *) a. Monad m => a -> m a
return (AccumMap String [Label] -> m (AccumMap String [Label]))
-> AccumMap String [Label] -> m (AccumMap String [Label])
forall a b. (a -> b) -> a -> b
$ case CxtS NoHole fs (K ()) FunctionExpL
-> Maybe (CxtS NoHole fs (K ()) IdentL)
forall (fs :: [(* -> *) -> * -> *]) l l' h (a :: * -> *).
InjF fs l l' =>
CxtS h fs a l' -> Maybe (CxtS h fs a l)
projF CxtS NoHole fs (K ()) FunctionExpL
f of
                                                         Just (Ident' n :: String
n) -> Map String [Label] -> AccumMap String [Label]
forall k v. Map k v -> AccumMap k v
AccumMap (Map String [Label] -> AccumMap String [Label])
-> Map String [Label] -> AccumMap String [Label]
forall a b. (a -> b) -> a -> b
$ String -> [Label] -> Map String [Label]
forall k a. k -> a -> Map k a
Map.singleton String
n [TermLab fs FunctionCallL -> Label
forall (f :: (* -> *) -> * -> *) a. Annotated f a => HFix f :=> a
getAnn TermLab fs FunctionCallL
t]
                                                         Nothing         -> AccumMap String [Label]
forall a. Monoid a => a
mempty

getCalls :: (TCAC fs, All HFoldable fs) => GTranslateM Identity (TermLab fs) (AccumMap FunctionId [Label])
getCalls :: GTranslateM Identity (TermLab fs) (AccumMap String [Label])
getCalls = GTranslateM
  (MaybeT Identity) (TermLab fs) (AccumMap String [Label])
-> GTranslateM Identity (TermLab fs) (AccumMap String [Label])
forall (f :: (* -> *) -> * -> *) t (m :: * -> *).
(HFoldable f, Monoid t, Monad m) =>
GTranslateM (MaybeT m) (HFix f) t -> GTranslateM m (HFix f) t
crushtdT (TranslateM
  (MaybeT Identity)
  (TermLab fs)
  FunctionCallL
  (AccumMap String [Label])
-> TranslateM
     (MaybeT Identity) (TermLab fs) l (AccumMap String [Label])
forall (f :: * -> *) l (m :: * -> *) t.
(DynCase f l, Alternative m) =>
TranslateM m f l t -> GTranslateM m f t
promoteTF (TranslateM
   (MaybeT Identity)
   (TermLab fs)
   FunctionCallL
   (AccumMap String [Label])
 -> TranslateM
      (MaybeT Identity) (TermLab fs) l (AccumMap String [Label]))
-> TranslateM
     (MaybeT Identity)
     (TermLab fs)
     FunctionCallL
     (AccumMap String [Label])
-> TranslateM
     (MaybeT Identity) (TermLab fs) l (AccumMap String [Label])
forall a b. (a -> b) -> a -> b
$ TranslateM
  Identity (TermLab fs) FunctionCallL (AccumMap String [Label])
-> TranslateM
     (MaybeT Identity)
     (TermLab fs)
     FunctionCallL
     (AccumMap String [Label])
forall (m :: * -> *) (f :: * -> *) l t.
Monad m =>
TranslateM m f l t -> TranslateM (MaybeT m) f l t
addFail TranslateM
  Identity (TermLab fs) FunctionCallL (AccumMap String [Label])
forall (fs :: [(* -> *) -> * -> *]) (m :: * -> *).
(TCAC fs, Monad m) =>
TranslateM m (TermLab fs) FunctionCallL (AccumMap String [Label])
getCalls')

instance (TCAC fs, All HFoldable fs) => CallAnalysis fs where
  callAnalysis :: Project fs -> Map String [NodeIdx]
callAnalysis prj :: Project fs
prj = AccumMap String [NodeIdx] -> Map String [NodeIdx]
forall k v. AccumMap k v -> Map k v
runAccumMap (AccumMap String [NodeIdx] -> Map String [NodeIdx])
-> AccumMap String [NodeIdx] -> Map String [NodeIdx]
forall a b. (a -> b) -> a -> b
$ [AccumMap String [NodeIdx]] -> AccumMap String [NodeIdx]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([AccumMap String [NodeIdx]] -> AccumMap String [NodeIdx])
-> [AccumMap String [NodeIdx]] -> AccumMap String [NodeIdx]
forall a b. (a -> b) -> a -> b
$ ((String, E (TermLab fs)) -> AccumMap String [NodeIdx])
-> [(String, E (TermLab fs))] -> [AccumMap String [NodeIdx]]
forall a b. (a -> b) -> [a] -> [b]
map (String, E (TermLab fs)) -> AccumMap String [NodeIdx]
forall (fs :: [(* -> *) -> * -> *]).
(TCAC fs, All HFoldable fs) =>
(String, E (TermLab fs)) -> AccumMap String [NodeIdx]
getCallsAnnSource ([(String, E (TermLab fs))] -> [AccumMap String [NodeIdx]])
-> [(String, E (TermLab fs))] -> [AccumMap String [NodeIdx]]
forall a b. (a -> b) -> a -> b
$ Project fs -> [(String, E (TermLab fs))]
forall k a. Map k a -> [(k, a)]
Map.toList Project fs
prj
    where
      -- After a lot of painful debugging, I've determined that let-statements are evil
      -- (within a let statement, the typeclass-resolver will run wild and try to infer stuff
      --   while ignoring the things provided by the context)
      getCallsAnnSource :: forall fs. (TCAC fs, All HFoldable fs) => (FilePath, E (TermLab fs)) -> AccumMap FunctionId [NodeIdx]
      getCallsAnnSource :: (String, E (TermLab fs)) -> AccumMap String [NodeIdx]
getCallsAnnSource (fil :: String
fil, E t :: TermLab fs i
t) = case Identity (AccumMap String [Label]) -> AccumMap String [Label]
forall a. Identity a -> a
runIdentity (Identity (AccumMap String [Label]) -> AccumMap String [Label])
-> Identity (AccumMap String [Label]) -> AccumMap String [Label]
forall a b. (a -> b) -> a -> b
$ TranslateM Identity (TermLab fs) i (AccumMap String [Label])
forall (fs :: [(* -> *) -> * -> *]).
(TCAC fs, All HFoldable fs) =>
GTranslateM Identity (TermLab fs) (AccumMap String [Label])
getCalls TermLab fs i
t of
                                       AccumMap m :: Map String [Label]
m -> Map String [NodeIdx] -> AccumMap String [NodeIdx]
forall k v. Map k v -> AccumMap k v
AccumMap (Map String [NodeIdx] -> AccumMap String [NodeIdx])
-> Map String [NodeIdx] -> AccumMap String [NodeIdx]
forall a b. (a -> b) -> a -> b
$ ([Label] -> [NodeIdx])
-> Map String [Label] -> Map String [NodeIdx]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Label -> NodeIdx) -> [Label] -> [NodeIdx]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Label -> NodeIdx
NodeIdx String
fil)) Map String [Label]
m

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



type TrivialFunctionAnalysisConstraints fs = ( FunctionDef :-<: fs, Ident :-<: fs
                                            , All HTraversable fs
                                            , DynCase (TermLab fs) FunctionDefL)

type TFAC fs = TrivialFunctionAnalysisConstraints fs

class FunctionAnalysis fs where
  functionAnalysis :: Project fs -> Map FunctionId [NodeIdx]


getFuncs' :: (TFAC fs, Monad m, All HFunctor fs) => TranslateM m (TermLab fs) FunctionDefL (AccumMap FunctionId [Label])
getFuncs' :: TranslateM m (TermLab fs) FunctionDefL (AccumMap String [Label])
getFuncs' t :: TermLab fs FunctionDefL
t@(TermLab fs FunctionDefL -> Cxt NoHole (Sum fs) (K ()) FunctionDefL
forall (g :: (* -> *) -> * -> *) (f :: (* -> *) -> * -> *).
(RemA g f, HFunctor g) =>
CxtFun g f
stripA -> FunctionDef' _ (Ident' n :: String
n) _ _) = AccumMap String [Label] -> m (AccumMap String [Label])
forall (m :: * -> *) a. Monad m => a -> m a
return (AccumMap String [Label] -> m (AccumMap String [Label]))
-> AccumMap String [Label] -> m (AccumMap String [Label])
forall a b. (a -> b) -> a -> b
$ Map String [Label] -> AccumMap String [Label]
forall k v. Map k v -> AccumMap k v
AccumMap (Map String [Label] -> AccumMap String [Label])
-> Map String [Label] -> AccumMap String [Label]
forall a b. (a -> b) -> a -> b
$ String -> [Label] -> Map String [Label]
forall k a. k -> a -> Map k a
Map.singleton String
n [TermLab fs FunctionDefL -> Label
forall (f :: (* -> *) -> * -> *) a. Annotated f a => HFix f :=> a
getAnn TermLab fs FunctionDefL
t]

getFuncs :: (TFAC fs, All HFunctor fs, All HFoldable fs) => GTranslateM Identity (TermLab fs) (AccumMap FunctionId [Label])
getFuncs :: GTranslateM Identity (TermLab fs) (AccumMap String [Label])
getFuncs = GTranslateM
  (MaybeT Identity) (TermLab fs) (AccumMap String [Label])
-> GTranslateM Identity (TermLab fs) (AccumMap String [Label])
forall (f :: (* -> *) -> * -> *) t (m :: * -> *).
(HFoldable f, Monoid t, Monad m) =>
GTranslateM (MaybeT m) (HFix f) t -> GTranslateM m (HFix f) t
crushtdT (TranslateM
  (MaybeT Identity)
  (TermLab fs)
  FunctionDefL
  (AccumMap String [Label])
-> TranslateM
     (MaybeT Identity) (TermLab fs) l (AccumMap String [Label])
forall (f :: * -> *) l (m :: * -> *) t.
(DynCase f l, Alternative m) =>
TranslateM m f l t -> GTranslateM m f t
promoteTF (TranslateM
   (MaybeT Identity)
   (TermLab fs)
   FunctionDefL
   (AccumMap String [Label])
 -> TranslateM
      (MaybeT Identity) (TermLab fs) l (AccumMap String [Label]))
-> TranslateM
     (MaybeT Identity)
     (TermLab fs)
     FunctionDefL
     (AccumMap String [Label])
-> TranslateM
     (MaybeT Identity) (TermLab fs) l (AccumMap String [Label])
forall a b. (a -> b) -> a -> b
$ TranslateM
  Identity (TermLab fs) FunctionDefL (AccumMap String [Label])
-> TranslateM
     (MaybeT Identity)
     (TermLab fs)
     FunctionDefL
     (AccumMap String [Label])
forall (m :: * -> *) (f :: * -> *) l t.
Monad m =>
TranslateM m f l t -> TranslateM (MaybeT m) f l t
addFail TranslateM
  Identity (TermLab fs) FunctionDefL (AccumMap String [Label])
forall (fs :: [(* -> *) -> * -> *]) (m :: * -> *).
(TFAC fs, Monad m, All HFunctor fs) =>
TranslateM m (TermLab fs) FunctionDefL (AccumMap String [Label])
getFuncs')

instance (TFAC fs, All HFunctor fs, All HFoldable fs) => FunctionAnalysis fs where
  functionAnalysis :: Project fs -> Map String [NodeIdx]
functionAnalysis prj :: Project fs
prj = AccumMap String [NodeIdx] -> Map String [NodeIdx]
forall k v. AccumMap k v -> Map k v
runAccumMap (AccumMap String [NodeIdx] -> Map String [NodeIdx])
-> AccumMap String [NodeIdx] -> Map String [NodeIdx]
forall a b. (a -> b) -> a -> b
$ [AccumMap String [NodeIdx]] -> AccumMap String [NodeIdx]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([AccumMap String [NodeIdx]] -> AccumMap String [NodeIdx])
-> [AccumMap String [NodeIdx]] -> AccumMap String [NodeIdx]
forall a b. (a -> b) -> a -> b
$ ((String, E (TermLab fs)) -> AccumMap String [NodeIdx])
-> [(String, E (TermLab fs))] -> [AccumMap String [NodeIdx]]
forall a b. (a -> b) -> [a] -> [b]
map (String, E (TermLab fs)) -> AccumMap String [NodeIdx]
forall (fs :: [(* -> *) -> * -> *]).
(TFAC fs, All HFunctor fs, All HFoldable fs) =>
(String, E (TermLab fs)) -> AccumMap String [NodeIdx]
getFuncsAnnSource ([(String, E (TermLab fs))] -> [AccumMap String [NodeIdx]])
-> [(String, E (TermLab fs))] -> [AccumMap String [NodeIdx]]
forall a b. (a -> b) -> a -> b
$ Project fs -> [(String, E (TermLab fs))]
forall k a. Map k a -> [(k, a)]
Map.toList Project fs
prj
    where
      getFuncsAnnSource :: forall fs. (TFAC fs, All HFunctor fs, All HFoldable fs) => (FilePath, E (TermLab fs)) -> AccumMap FunctionId [NodeIdx]
      getFuncsAnnSource :: (String, E (TermLab fs)) -> AccumMap String [NodeIdx]
getFuncsAnnSource (fil :: String
fil, E t :: TermLab fs i
t) = case Identity (AccumMap String [Label]) -> AccumMap String [Label]
forall a. Identity a -> a
runIdentity (Identity (AccumMap String [Label]) -> AccumMap String [Label])
-> Identity (AccumMap String [Label]) -> AccumMap String [Label]
forall a b. (a -> b) -> a -> b
$ TranslateM Identity (TermLab fs) i (AccumMap String [Label])
forall (fs :: [(* -> *) -> * -> *]).
(TFAC fs, All HFunctor fs, All HFoldable fs) =>
GTranslateM Identity (TermLab fs) (AccumMap String [Label])
getFuncs TermLab fs i
t of
                                       AccumMap m :: Map String [Label]
m -> Map String [NodeIdx] -> AccumMap String [NodeIdx]
forall k v. Map k v -> AccumMap k v
AccumMap (Map String [NodeIdx] -> AccumMap String [NodeIdx])
-> Map String [NodeIdx] -> AccumMap String [NodeIdx]
forall a b. (a -> b) -> a -> b
$ ([Label] -> [NodeIdx])
-> Map String [Label] -> Map String [NodeIdx]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Label -> NodeIdx) -> [Label] -> [NodeIdx]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Label -> NodeIdx
NodeIdx String
fil)) Map String [Label]
m