{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE FunctionalDependencies   #-}
{-# LANGUAGE MultiParamTypeClasses    #-}
{-# LANGUAGE TemplateHaskell          #-}

module Cubix.Language.Parametric.ProgInfo (
    ProgInfo
  , HasProgInfo(..)

  , makeProgInfo
  , cfgNodePath
  , labToPath
  ) where

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

import Data.Comp.Multi ( runE, All, HFoldable)

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

import Cubix.Sin.Compdata.Annotation ( getAnn )


data ProgInfo fs = ProgInfo { ProgInfo fs -> Cfg fs
_proginf_cfg :: Cfg fs
                            , ProgInfo fs -> Map Label Path
_proginf_paths :: Map Label Path
                            }

makeClassy ''ProgInfo

makeProgInfo :: (CfgBuilder fs, All HFoldable fs) => TermLab fs l -> ProgInfo fs
makeProgInfo :: TermLab fs l -> ProgInfo fs
makeProgInfo t :: TermLab fs l
t = Cfg fs -> Map Label Path -> ProgInfo fs
forall (fs :: [(* -> *) -> * -> *]).
Cfg fs -> Map Label Path -> ProgInfo fs
ProgInfo (TermLab fs l -> Cfg fs
forall (fs :: [(* -> *) -> * -> *]) 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 :: ProgInfo fs -> CfgNode fs -> Maybe Path
cfgNodePath progInf :: ProgInfo fs
progInf n :: 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 :: [(* -> *) -> * -> *]).
HasProgInfo c fs =>
Lens' c (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 TermLab fs :=> Label
forall (f :: (* -> *) -> * -> *) a. Annotated f a => 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 :: [(* -> *) -> * -> *]).
HasCfgNode c fs =>
Lens' c (E (TermLab fs))
cfg_node_term)



labToPath :: Label -> ProgInfo fs -> Path
labToPath :: Label -> ProgInfo fs -> Path
labToPath l :: Label
l progInf :: 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 :: [(* -> *) -> * -> *]).
HasProgInfo c fs =>
Lens' c (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 p :: Path
p  -> Path
p
                        Nothing -> [Char] -> Path
forall a. HasCallStack => [Char] -> a
error ([Char] -> Path) -> [Char] -> Path
forall a b. (a -> b) -> a -> b
$ "No path for label: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Label -> [Char]
forall a. Show a => a -> [Char]
show Label
l