{-# LANGUAGE TemplateHaskell          #-}

module Cubix.Language.Parametric.ProgInfo (
    -- * Type
    ProgInfo
  , HasProgInfo(..)

    -- * Construction
  , makeProgInfo

    -- * Accessors
  , cfgNodePath
  , labToPath
  , termToPath

    -- * Utilities involving multiple components

  , containingCfgNode
  , withContainingCfgNode
  ) where

import Control.Lens ( makeClassy, (^.) )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Maybe ( isJust )

import Data.Comp.Multi ( runE, All, E(..), HFunctor, HFoldable, HTraversable )

import Cubix.Language.Info
import Cubix.Language.Parametric.Path
import Cubix.Language.Parametric.Semantics.Cfg

import Cubix.Sin.Compdata.Annotation ( getAnn )

-----------------------------------------------------------------------
------------------ Datatype, construction access ----------------------
-----------------------------------------------------------------------

data ProgInfo fs = ProgInfo { forall (fs :: Signature). ProgInfo fs -> E (TermLab fs)
_proginf_program :: E (TermLab fs)
                            , forall (fs :: Signature). ProgInfo fs -> Cfg fs
_proginf_cfg     :: Cfg fs
                            , forall (fs :: Signature). ProgInfo fs -> Map Label Path
_proginf_paths   :: Map Label Path
                            }

makeClassy ''ProgInfo

makeProgInfo :: (CfgBuilder fs, All HFoldable fs) => TermLab fs l -> ProgInfo fs
makeProgInfo :: forall (fs :: Signature) l.
(CfgBuilder fs, All HFoldable fs) =>
TermLab fs l -> ProgInfo fs
makeProgInfo TermLab fs l
t = E (TermLab fs) -> Cfg fs -> Map Label Path -> ProgInfo fs
forall (fs :: Signature).
E (TermLab fs) -> Cfg fs -> Map Label Path -> ProgInfo fs
ProgInfo (TermLab fs l -> E (TermLab fs)
forall (f :: * -> *) i. f i -> E f
E TermLab fs l
t) (TermLab fs l -> Cfg fs
forall (fs :: Signature) l. CfgBuilder fs => TermLab fs l -> Cfg fs
makeCfg TermLab fs l
t) (TermLab fs l -> Map Label Path
forall (f :: (* -> *) -> * -> *) i.
HTraversable f =>
HFixLab f i -> Map Label Path
getPaths TermLab fs l
t)

cfgNodePath :: ProgInfo fs -> CfgNode fs -> Maybe Path
cfgNodePath :: forall (fs :: Signature). ProgInfo fs -> CfgNode fs -> Maybe Path
cfgNodePath ProgInfo fs
progInf CfgNode fs
n = Label -> Map Label Path -> Maybe Path
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Label
termLab (ProgInfo fs
progInf ProgInfo fs
-> Getting (Map Label Path) (ProgInfo fs) (Map Label Path)
-> Map Label Path
forall s a. s -> Getting a s a -> a
^. Getting (Map Label Path) (ProgInfo fs) (Map Label Path)
forall c (fs :: Signature).
HasProgInfo c fs =>
Lens' c (Map Label Path)
Lens' (ProgInfo fs) (Map Label Path)
proginf_paths)
  where
    termLab :: Label
termLab = (TermLab fs :=> Label) -> E (TermLab fs) -> Label
forall (f :: * -> *) b. (f :=> b) -> E f -> b
runE HFix (Sum fs :&: Label) i -> Label
TermLab fs :=> Label
forall a (f :: (* -> *) -> * -> *). Annotated a f => HFix f :=> a
getAnn (CfgNode fs
n CfgNode fs
-> Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
-> E (TermLab fs)
forall s a. s -> Getting a s a -> a
^. Getting (E (TermLab fs)) (CfgNode fs) (E (TermLab fs))
forall c (fs :: Signature).
HasCfgNode c fs =>
Lens' c (E (TermLab fs))
Lens' (CfgNode fs) (E (TermLab fs))
cfg_node_term)

-- TODO: Switch arg order
labToPath :: Label -> ProgInfo fs -> Path
labToPath :: forall (fs :: Signature). Label -> ProgInfo fs -> Path
labToPath Label
l ProgInfo fs
progInf = let paths :: Map Label Path
paths = ProgInfo fs
progInf ProgInfo fs
-> Getting (Map Label Path) (ProgInfo fs) (Map Label Path)
-> Map Label Path
forall s a. s -> Getting a s a -> a
^. Getting (Map Label Path) (ProgInfo fs) (Map Label Path)
forall c (fs :: Signature).
HasProgInfo c fs =>
Lens' c (Map Label Path)
Lens' (ProgInfo fs) (Map Label Path)
proginf_paths in
                      case Label -> Map Label Path -> Maybe Path
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Label
l Map Label Path
paths of
                        Just Path
p  -> Path
p
                        Maybe Path
Nothing -> [Char] -> Path
forall a. HasCallStack => [Char] -> a
error ([Char] -> Path) -> [Char] -> Path
forall a b. (a -> b) -> a -> b
$ [Char]
"No path for label: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Label -> [Char]
forall a. Show a => a -> [Char]
show Label
l

termToPath :: ProgInfo fs -> TermLab fs l -> Path
termToPath :: forall (fs :: Signature) l. ProgInfo fs -> TermLab fs l -> Path
termToPath ProgInfo fs
progInf TermLab fs l
t = Label -> ProgInfo fs -> Path
forall (fs :: Signature). Label -> ProgInfo fs -> Path
labToPath (TermLab fs l -> Label
HFix (Sum fs :&: Label) :=> Label
forall a (f :: (* -> *) -> * -> *). Annotated a f => HFix f :=> a
getAnn TermLab fs l
t) ProgInfo fs
progInf

-----------------------------------------------------------------------
------------- Utilities involving multiple components -----------------
-----------------------------------------------------------------------

-- TODO: This needs a name that reflects that it returns the AST node, not the CFG node
--       Of course, it's better to refactor the CFG inserter to take a CFG node,
--       and then change this to indeed return a node
-- | Let @prog@ be the overall program, @t@ be a subterm, and @progInfo@ the `ProgInfo` for @prog@.
-- Then @containingCfgNode progInf t@ returns the smallest ancestor
-- of @t@ which has a corresponding node in the CFG, or `Nothing` if no such
-- node exists.
--
-- This is useful for writing code which deals with generic nodes such as @Ident@
-- which are contained in computation nodes, but are not themselves computation nodes.
containingCfgNode :: forall fs l. (All HTraversable fs, All HFoldable fs, All HFunctor fs)
                  => ProgInfo fs
                  -> TermLab fs l
                  -> Maybe (E (TermLab fs))
containingCfgNode :: forall (fs :: Signature) l.
(All HTraversable fs, All HFoldable fs, All HFunctor fs) =>
ProgInfo fs -> TermLab fs l -> Maybe (E (TermLab fs))
containingCfgNode ProgInfo fs
progInf TermLab fs l
t = (TermLab fs :=> Maybe (E (TermLab fs)))
-> E (TermLab fs) -> Maybe (E (TermLab fs))
forall (f :: * -> *) b. (f :=> b) -> E f -> b
runE (\TermLab fs i
prog -> (forall i. HFix (Sum fs :&: Label) i -> Bool)
-> TermLab fs i -> Path -> Maybe (E (TermLab fs))
forall (f :: (* -> *) -> * -> *) l.
HTraversable f =>
(forall i. HFix f i -> Bool)
-> HFix f l -> Path -> Maybe (E (HFix f))
searchParent TermLab fs i -> Bool
forall i. HFix (Sum fs :&: Label) i -> Bool
inCfg TermLab fs i
prog (ProgInfo fs -> TermLab fs l -> Path
forall (fs :: Signature) l. ProgInfo fs -> TermLab fs l -> Path
termToPath ProgInfo fs
progInf TermLab fs l
t))
                                   (ProgInfo fs
progInf ProgInfo fs
-> Getting (E (TermLab fs)) (ProgInfo fs) (E (TermLab fs))
-> E (TermLab fs)
forall s a. s -> Getting a s a -> a
^. Getting (E (TermLab fs)) (ProgInfo fs) (E (TermLab fs))
forall c (fs :: Signature).
HasProgInfo c fs =>
Lens' c (E (TermLab fs))
Lens' (ProgInfo fs) (E (TermLab fs))
proginf_program)
  where
    cfg :: Cfg fs
cfg = ProgInfo fs
progInf ProgInfo fs -> Getting (Cfg fs) (ProgInfo fs) (Cfg fs) -> Cfg fs
forall s a. s -> Getting a s a -> a
^. Getting (Cfg fs) (ProgInfo fs) (Cfg fs)
forall c (fs :: Signature). HasProgInfo c fs => Lens' c (Cfg fs)
Lens' (ProgInfo fs) (Cfg fs)
proginf_cfg

    inCfg :: TermLab fs i -> Bool
    inCfg :: forall i. HFix (Sum fs :&: Label) i -> Bool
inCfg = Maybe (CfgNode fs) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (CfgNode fs) -> Bool)
-> (TermLab fs i -> Maybe (CfgNode fs)) -> TermLab fs i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cfg fs -> CfgNodeType -> TermLab fs i -> Maybe (CfgNode fs)
forall (fs :: Signature) l.
Cfg fs -> CfgNodeType -> TermLab fs l -> Maybe (CfgNode fs)
cfgNodeForTerm Cfg fs
cfg CfgNodeType
EnterNode

-- | See documentation of `containingCfgNode`. Runs the passed function
-- on the result of `containingCfgNode`, if the result is not `Nothing`.
withContainingCfgNode :: (All HTraversable fs, All HFoldable fs, All HFunctor fs, Applicative m)
                      => ProgInfo fs
                      -> TermLab fs l
                      -> (forall i. TermLab fs i -> m ())
                      -> m ()
withContainingCfgNode :: forall (fs :: Signature) (m :: * -> *) l.
(All HTraversable fs, All HFoldable fs, All HFunctor fs,
 Applicative m) =>
ProgInfo fs
-> TermLab fs l -> (forall i. TermLab fs i -> m ()) -> m ()
withContainingCfgNode ProgInfo fs
progInf TermLab fs l
t forall i. TermLab fs i -> m ()
f = case ProgInfo fs -> TermLab fs l -> Maybe (E (TermLab fs))
forall (fs :: Signature) l.
(All HTraversable fs, All HFoldable fs, All HFunctor fs) =>
ProgInfo fs -> TermLab fs l -> Maybe (E (TermLab fs))
containingCfgNode ProgInfo fs
progInf TermLab fs l
t of
                                      Just (E TermLab fs i
x) -> TermLab fs i -> m ()
forall i. TermLab fs i -> m ()
f TermLab fs i
x
                                      Maybe (E (TermLab fs))
Nothing    -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()