{- |
Module      :  Camfort.Specification.Units.ModFile
Description :  Helpers for working with units-relevant ModFiles.
Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish
License     :  Apache-2.0

Maintainer  :  dom.orchard@gmail.com
Stability   :  experimental
-}

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE TupleSections #-}

module Camfort.Specification.Units.ModFile
  (
    genUnitsModFile
  , initializeModFiles
  , runCompileUnits
  , dumpModFileCompiledUnits
  ) where

import           Camfort.Analysis (analysisModFiles)
import           Camfort.Specification.Units.Annotation (UA)
import           Camfort.Specification.Units.Environment (Constraint(..), foldUnits, UnitInfo(..), colSort, Constraints)
import           Camfort.Specification.Units.InferenceBackend (flattenConstraints, flattenUnits, genUnitAssignments')
import           Camfort.Specification.Units.Monad
import           Control.Monad.State (get, gets, lift)
import           Data.Binary (Binary, decodeOrFail, encode)
import           Data.Data (Data)
import           Data.Generics.Uniplate.Operations (universeBi)
import           Data.List (partition)
import qualified Data.Map as M
import           Data.Maybe (mapMaybe, catMaybes)
import qualified Data.Set as S
import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)
import qualified Language.Fortran.AST as F
import qualified Language.Fortran.Analysis as FA
import           Language.Fortran.Util.ModFile
import           Prelude hiding (mod)

-- | The data-structure stored in 'fortran-src mod files'
data CompiledUnits = CompiledUnits
  { CompiledUnits -> TemplateMap
cuTemplateMap  :: TemplateMap
  , CompiledUnits -> NameParamMap
cuNameParamMap :: NameParamMap
  } deriving (Eq CompiledUnits
Eq CompiledUnits
-> (CompiledUnits -> CompiledUnits -> Ordering)
-> (CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> CompiledUnits)
-> (CompiledUnits -> CompiledUnits -> CompiledUnits)
-> Ord CompiledUnits
CompiledUnits -> CompiledUnits -> Bool
CompiledUnits -> CompiledUnits -> Ordering
CompiledUnits -> CompiledUnits -> CompiledUnits
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 :: CompiledUnits -> CompiledUnits -> CompiledUnits
$cmin :: CompiledUnits -> CompiledUnits -> CompiledUnits
max :: CompiledUnits -> CompiledUnits -> CompiledUnits
$cmax :: CompiledUnits -> CompiledUnits -> CompiledUnits
>= :: CompiledUnits -> CompiledUnits -> Bool
$c>= :: CompiledUnits -> CompiledUnits -> Bool
> :: CompiledUnits -> CompiledUnits -> Bool
$c> :: CompiledUnits -> CompiledUnits -> Bool
<= :: CompiledUnits -> CompiledUnits -> Bool
$c<= :: CompiledUnits -> CompiledUnits -> Bool
< :: CompiledUnits -> CompiledUnits -> Bool
$c< :: CompiledUnits -> CompiledUnits -> Bool
compare :: CompiledUnits -> CompiledUnits -> Ordering
$ccompare :: CompiledUnits -> CompiledUnits -> Ordering
$cp1Ord :: Eq CompiledUnits
Ord, CompiledUnits -> CompiledUnits -> Bool
(CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> Bool) -> Eq CompiledUnits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompiledUnits -> CompiledUnits -> Bool
$c/= :: CompiledUnits -> CompiledUnits -> Bool
== :: CompiledUnits -> CompiledUnits -> Bool
$c== :: CompiledUnits -> CompiledUnits -> Bool
Eq, Int -> CompiledUnits -> ShowS
[CompiledUnits] -> ShowS
CompiledUnits -> String
(Int -> CompiledUnits -> ShowS)
-> (CompiledUnits -> String)
-> ([CompiledUnits] -> ShowS)
-> Show CompiledUnits
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompiledUnits] -> ShowS
$cshowList :: [CompiledUnits] -> ShowS
show :: CompiledUnits -> String
$cshow :: CompiledUnits -> String
showsPrec :: Int -> CompiledUnits -> ShowS
$cshowsPrec :: Int -> CompiledUnits -> ShowS
Show, Typeable CompiledUnits
DataType
Constr
Typeable CompiledUnits
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c CompiledUnits)
-> (CompiledUnits -> Constr)
-> (CompiledUnits -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c CompiledUnits))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c CompiledUnits))
-> ((forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r)
-> (forall u. (forall d. Data d => d -> u) -> CompiledUnits -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits)
-> Data CompiledUnits
CompiledUnits -> DataType
CompiledUnits -> Constr
(forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u
forall u. (forall d. Data d => d -> u) -> CompiledUnits -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CompiledUnits)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CompiledUnits)
$cCompiledUnits :: Constr
$tCompiledUnits :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
gmapMp :: (forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
gmapM :: (forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
gmapQi :: Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u
gmapQ :: (forall d. Data d => d -> u) -> CompiledUnits -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CompiledUnits -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
gmapT :: (forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits
$cgmapT :: (forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CompiledUnits)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CompiledUnits)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c CompiledUnits)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CompiledUnits)
dataTypeOf :: CompiledUnits -> DataType
$cdataTypeOf :: CompiledUnits -> DataType
toConstr :: CompiledUnits -> Constr
$ctoConstr :: CompiledUnits -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits
$cp1Data :: Typeable CompiledUnits
Data, Typeable, (forall x. CompiledUnits -> Rep CompiledUnits x)
-> (forall x. Rep CompiledUnits x -> CompiledUnits)
-> Generic CompiledUnits
forall x. Rep CompiledUnits x -> CompiledUnits
forall x. CompiledUnits -> Rep CompiledUnits x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CompiledUnits x -> CompiledUnits
$cfrom :: forall x. CompiledUnits -> Rep CompiledUnits x
Generic)

instance Binary CompiledUnits

emptyCompiledUnits :: CompiledUnits
emptyCompiledUnits :: CompiledUnits
emptyCompiledUnits = TemplateMap -> NameParamMap -> CompiledUnits
CompiledUnits TemplateMap
forall k a. Map k a
M.empty NameParamMap
forall k a. Map k a
M.empty

combinedCompiledUnits :: ModFiles -> CompiledUnits
combinedCompiledUnits :: ModFiles -> CompiledUnits
combinedCompiledUnits ModFiles
mfs = CompiledUnits :: TemplateMap -> NameParamMap -> CompiledUnits
CompiledUnits { cuTemplateMap :: TemplateMap
cuTemplateMap = [TemplateMap] -> TemplateMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions [TemplateMap]
tmaps
                                          , cuNameParamMap :: NameParamMap
cuNameParamMap = [NameParamMap] -> NameParamMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions [NameParamMap]
nmaps }
  where
    cus :: [CompiledUnits]
cus = (ModFile -> CompiledUnits) -> ModFiles -> [CompiledUnits]
forall a b. (a -> b) -> [a] -> [b]
map ModFile -> CompiledUnits
mfCompiledUnits ModFiles
mfs
    tmaps :: [TemplateMap]
tmaps = (CompiledUnits -> TemplateMap) -> [CompiledUnits] -> [TemplateMap]
forall a b. (a -> b) -> [a] -> [b]
map CompiledUnits -> TemplateMap
cuTemplateMap [CompiledUnits]
cus
    nmaps :: [NameParamMap]
nmaps = (CompiledUnits -> NameParamMap)
-> [CompiledUnits] -> [NameParamMap]
forall a b. (a -> b) -> [a] -> [b]
map CompiledUnits -> NameParamMap
cuNameParamMap [CompiledUnits]
cus

-- | Name of the labeled data within a ModFile containing unit-specific info.
unitsCompiledDataLabel :: String
unitsCompiledDataLabel :: String
unitsCompiledDataLabel = String
"units-compiled-data"

mfCompiledUnits :: ModFile -> CompiledUnits
mfCompiledUnits :: ModFile -> CompiledUnits
mfCompiledUnits ModFile
mf = case String -> ModFile -> Maybe ByteString
lookupModFileData String
unitsCompiledDataLabel ModFile
mf of
  Maybe ByteString
Nothing -> CompiledUnits
emptyCompiledUnits
  Just ByteString
bs -> case ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, CompiledUnits)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bs of
    Left (ByteString, ByteOffset, String)
_ -> CompiledUnits
emptyCompiledUnits
    Right (ByteString
_, ByteOffset
_, CompiledUnits
cu) -> CompiledUnits
cu

-- | Initialize units-relevant ModFile information.
initializeModFiles :: UnitSolver ()
initializeModFiles :: UnitSolver ()
initializeModFiles = do
  ModFiles
mfs <- ReaderT UnitEnv (AnalysisT () () IO) ModFiles
-> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) ModFiles
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT UnitEnv (AnalysisT () () IO) ModFiles
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) ModFiles)
-> (AnalysisT () () IO ModFiles
    -> ReaderT UnitEnv (AnalysisT () () IO) ModFiles)
-> AnalysisT () () IO ModFiles
-> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) ModFiles
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnalysisT () () IO ModFiles
-> ReaderT UnitEnv (AnalysisT () () IO) ModFiles
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (AnalysisT () () IO ModFiles
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) ModFiles)
-> AnalysisT () () IO ModFiles
-> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) ModFiles
forall a b. (a -> b) -> a -> b
$ AnalysisT () () IO ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
  let compiledUnits :: CompiledUnits
compiledUnits = ModFiles -> CompiledUnits
combinedCompiledUnits ModFiles
mfs
  (TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap  ((TemplateMap -> TemplateMap) -> UnitSolver ())
-> (CompiledUnits -> TemplateMap -> TemplateMap)
-> CompiledUnits
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemplateMap -> TemplateMap -> TemplateMap
forall a b. a -> b -> a
const (TemplateMap -> TemplateMap -> TemplateMap)
-> (CompiledUnits -> TemplateMap)
-> CompiledUnits
-> TemplateMap
-> TemplateMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompiledUnits -> TemplateMap
cuTemplateMap  (CompiledUnits -> UnitSolver ()) -> CompiledUnits -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ CompiledUnits
compiledUnits
  (NameParamMap -> NameParamMap) -> UnitSolver ()
modifyNameParamMap ((NameParamMap -> NameParamMap) -> UnitSolver ())
-> (CompiledUnits -> NameParamMap -> NameParamMap)
-> CompiledUnits
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameParamMap -> NameParamMap -> NameParamMap
forall a b. a -> b -> a
const (NameParamMap -> NameParamMap -> NameParamMap)
-> (CompiledUnits -> NameParamMap)
-> CompiledUnits
-> NameParamMap
-> NameParamMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompiledUnits -> NameParamMap
cuNameParamMap (CompiledUnits -> UnitSolver ()) -> CompiledUnits -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ CompiledUnits
compiledUnits

-- | Produce information for a "units-mod" file.
runCompileUnits :: UnitSolver CompiledUnits
runCompileUnits :: UnitSolver CompiledUnits
runCompileUnits = do
  Constraints
cons <- UnitState -> Constraints
usConstraints (UnitState -> Constraints)
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitState
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraints
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitState
forall s (m :: * -> *). MonadState s m => m s
get
  ProgramFile UA
pf <- UnitState -> ProgramFile UA
usProgramFile  (UnitState -> ProgramFile UA)
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitState
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramFile UA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitState
forall s (m :: * -> *). MonadState s m => m s
get

  let unitAssigns :: [([UnitInfo], [UnitInfo])]
unitAssigns = Constraints -> [([UnitInfo], [UnitInfo])]
flattenConstraints Constraints
cons
  let epsilon :: Double
epsilon = Double
0.001 -- arbitrary
  let approxEq :: Double -> Double -> Bool
approxEq Double
a Double
b = Double -> Double
forall a. Num a => a -> a
abs (Double
b Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
a) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
epsilon

  let variables :: Map NameParamKey [UnitInfo]
variables = [(NameParamKey, [UnitInfo])] -> Map NameParamKey [UnitInfo]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (VV -> NameParamKey
NPKVariable VV
var, [UnitInfo]
units) | ([UnitPow (UnitVar VV
var) Double
k], [UnitInfo]
units) <- [([UnitInfo], [UnitInfo])]
unitAssigns
                                                        , Double
k Double -> Double -> Bool
`approxEq` Double
1 ]

  -- Create sets of relevant program-unit and variable names.
  let getName :: ProgramUnit (Analysis a) -> Maybe String
getName ProgramUnit (Analysis a)
pu | F.Named String
n <- ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
FA.puName ProgramUnit (Analysis a)
pu = String -> Maybe String
forall a. a -> Maybe a
Just String
n | Bool
otherwise = Maybe String
forall a. Maybe a
Nothing
  let puNameSet :: Set String
puNameSet = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes [ ProgramUnit UA -> Maybe String
forall a. ProgramUnit (Analysis a) -> Maybe String
getName ProgramUnit UA
pu | ProgramUnit UA
pu <- ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [F.ProgramUnit UA] ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                               [ Expression UA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression UA
e | F.BlInterface UA
_ SrcSpan
_ (Just Expression UA
e) Bool
_ [ProgramUnit UA]
_ [Block UA]
_ <- ProgramFile UA -> [Block UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [F.Block UA] ]

  let puVarNameSet :: from -> Set VV
puVarNameSet from
pu = [VV] -> Set VV
forall a. Ord a => [a] -> Set a
S.fromList ([VV] -> Set VV) -> [VV] -> Set VV
forall a b. (a -> b) -> a -> b
$
        [ (Expression UA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression UA
v, Expression UA -> String
forall a. Expression (Analysis a) -> String
FA.srcName Expression UA
v) | F.DeclVariable UA
_ SrcSpan
_ Expression UA
v Maybe (Expression UA)
_ Maybe (Expression UA)
_ <- from -> [Declarator UA]
forall from to. Biplate from to => from -> [to]
universeBi from
pu :: [F.Declarator UA] ] [VV] -> [VV] -> [VV]
forall a. [a] -> [a] -> [a]
++
        [ (Expression UA -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression UA
v, Expression UA -> String
forall a. Expression (Analysis a) -> String
FA.srcName Expression UA
v) | F.DeclArray UA
_ SrcSpan
_ Expression UA
v AList DimensionDeclarator UA
_ Maybe (Expression UA)
_ Maybe (Expression UA)
_  <- from -> [Declarator UA]
forall from to. Biplate from to => from -> [to]
universeBi from
pu :: [F.Declarator UA] ]

  -- Map of modules -> associated declared variables
  let puVarNameMap :: M.Map F.ProgramUnitName (S.Set VV)
      puVarNameMap :: Map ProgramUnitName (Set VV)
puVarNameMap = (Set VV -> Set VV -> Set VV)
-> [(ProgramUnitName, Set VV)] -> Map ProgramUnitName (Set VV)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Set VV -> Set VV -> Set VV
forall a. Ord a => Set a -> Set a -> Set a
S.union [ (ProgramUnit UA -> ProgramUnitName
forall a. Named a => a -> ProgramUnitName
F.getName ProgramUnit UA
pu, ProgramUnit UA -> Set VV
forall from. Data from => from -> Set VV
puVarNameSet ProgramUnit UA
pu)
                                            | pu :: ProgramUnit UA
pu@F.PUModule {} <- ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [F.ProgramUnit UA] ]

  -- Filter functions that cut out any information not having to do
  -- with the current modules being compiled.
  let filterPUs :: Map String b -> Map String b
filterPUs = (String -> b -> Bool) -> Map String b -> Map String b
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (Bool -> b -> Bool
forall a b. a -> b -> a
const (Bool -> b -> Bool) -> (String -> Bool) -> String -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set String
puNameSet))
  -- FIXME: investigate whether we should include vars that are linked
  -- transitively to current pf vars should also be included.
  TemplateMap
tmap <- (TemplateMap -> TemplateMap
forall b. Map String b -> Map String b
filterPUs (TemplateMap -> TemplateMap)
-> (TemplateMap -> TemplateMap) -> TemplateMap -> TemplateMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraints -> Constraints) -> TemplateMap -> TemplateMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Constraints -> Constraints
optimiseTemplate) (TemplateMap -> TemplateMap)
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) TemplateMap
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) TemplateMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (UnitState -> TemplateMap)
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) TemplateMap
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets UnitState -> TemplateMap
usTemplateMap

  let findNPK :: VV -> Maybe (NameParamKey, [UnitInfo])
findNPK VV
vv = ( (VV -> NameParamKey
NPKVariable VV
vv), ) ([UnitInfo] -> (NameParamKey, [UnitInfo]))
-> Maybe [UnitInfo] -> Maybe (NameParamKey, [UnitInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameParamKey -> Map NameParamKey [UnitInfo] -> Maybe [UnitInfo]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (VV -> NameParamKey
NPKVariable VV
vv) Map NameParamKey [UnitInfo]
variables

  -- 'Name Param Map': module names -> (variables -> unit info)
  let npm :: NameParamMap
npm = (Map NameParamKey [UnitInfo] -> Bool)
-> NameParamMap -> NameParamMap
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool)
-> (Map NameParamKey [UnitInfo] -> Bool)
-> Map NameParamKey [UnitInfo]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NameParamKey [UnitInfo] -> Bool
forall k a. Map k a -> Bool
M.null) (NameParamMap -> NameParamMap) -> NameParamMap -> NameParamMap
forall a b. (a -> b) -> a -> b
$ ((Set VV -> Map NameParamKey [UnitInfo])
 -> Map ProgramUnitName (Set VV) -> NameParamMap)
-> Map ProgramUnitName (Set VV)
-> (Set VV -> Map NameParamKey [UnitInfo])
-> NameParamMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Set VV -> Map NameParamKey [UnitInfo])
-> Map ProgramUnitName (Set VV) -> NameParamMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Map ProgramUnitName (Set VV)
puVarNameMap ([(NameParamKey, [UnitInfo])] -> Map NameParamKey [UnitInfo]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(NameParamKey, [UnitInfo])] -> Map NameParamKey [UnitInfo])
-> (Set VV -> [(NameParamKey, [UnitInfo])])
-> Set VV
-> Map NameParamKey [UnitInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VV -> Maybe (NameParamKey, [UnitInfo]))
-> [VV] -> [(NameParamKey, [UnitInfo])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VV -> Maybe (NameParamKey, [UnitInfo])
findNPK ([VV] -> [(NameParamKey, [UnitInfo])])
-> (Set VV -> [VV]) -> Set VV -> [(NameParamKey, [UnitInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set VV -> [VV]
forall a. Set a -> [a]
S.toList)

  CompiledUnits -> UnitSolver CompiledUnits
forall (f :: * -> *) a. Applicative f => a -> f a
pure CompiledUnits :: TemplateMap -> NameParamMap -> CompiledUnits
CompiledUnits { cuTemplateMap :: TemplateMap
cuTemplateMap = TemplateMap
tmap, cuNameParamMap :: NameParamMap
cuNameParamMap = NameParamMap
npm }

-- | Cut out unnecessary constraints in the template using the solver.
optimiseTemplate :: Constraints -> Constraints
optimiseTemplate :: Constraints -> Constraints
optimiseTemplate Constraints
cons = (([UnitInfo], UnitInfo) -> Constraint)
-> [([UnitInfo], UnitInfo)] -> Constraints
forall a b. (a -> b) -> [a] -> [b]
map (\ ([UnitInfo]
l, UnitInfo
r) -> UnitInfo -> UnitInfo -> Constraint
ConEq ([UnitInfo] -> UnitInfo
forall (t :: * -> *). Foldable t => t UnitInfo -> UnitInfo
foldUnits [UnitInfo]
l) UnitInfo
r) [([UnitInfo], UnitInfo)]
optimised
  where
    unitAssigns :: [([UnitInfo], UnitInfo)]
unitAssigns  = SortFn -> Constraints -> [([UnitInfo], UnitInfo)]
genUnitAssignments' (SortFn
compileColSort) Constraints
cons
    unitPows :: [([UnitInfo], [UnitInfo])]
unitPows     = (([UnitInfo], UnitInfo) -> ([UnitInfo], [UnitInfo]))
-> [([UnitInfo], UnitInfo)] -> [([UnitInfo], [UnitInfo])]
forall a b. (a -> b) -> [a] -> [b]
map ((UnitInfo -> [UnitInfo])
-> ([UnitInfo], UnitInfo) -> ([UnitInfo], [UnitInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitInfo -> [UnitInfo]
flattenUnits) [([UnitInfo], UnitInfo)]
unitAssigns
    optimised :: [([UnitInfo], UnitInfo)]
optimised    = (([UnitInfo], UnitInfo) -> Bool)
-> [([UnitInfo], UnitInfo)] -> [([UnitInfo], UnitInfo)]
forall a. (a -> Bool) -> [a] -> [a]
filter ([UnitInfo], UnitInfo) -> Bool
forall from b. Data from => (from, b) -> Bool
cull ([([UnitInfo], UnitInfo)] -> [([UnitInfo], UnitInfo)])
-> [([UnitInfo], UnitInfo)] -> [([UnitInfo], UnitInfo)]
forall a b. (a -> b) -> a -> b
$ (([UnitInfo], [UnitInfo]) -> ([UnitInfo], UnitInfo))
-> [([UnitInfo], [UnitInfo])] -> [([UnitInfo], UnitInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (([UnitInfo] -> UnitInfo)
-> ([UnitInfo], [UnitInfo]) -> ([UnitInfo], UnitInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [UnitInfo] -> UnitInfo
forall (t :: * -> *). Foldable t => t UnitInfo -> UnitInfo
foldUnits (([UnitInfo], [UnitInfo]) -> ([UnitInfo], UnitInfo))
-> (([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo]))
-> ([UnitInfo], [UnitInfo])
-> ([UnitInfo], UnitInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])
shiftTerms) [([UnitInfo], [UnitInfo])]
unitPows

    cull :: (from, b) -> Bool
cull (from
lhs, b
_) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Bool
True | (UnitPow (UnitParamPosAbs (VV, Int)
_) Double
_) <- from -> [UnitInfo]
forall from to. Biplate from to => from -> [to]
universeBi from
lhs ]

    isUnitRHS :: UnitInfo -> Bool
isUnitRHS (UnitPow (UnitName String
_) Double
_)        = Bool
True
    isUnitRHS (UnitPow (UnitParamEAPAbs VV
_) Double
_) = Bool
True
    isUnitRHS (UnitPow (UnitParamImpAbs String
_) Double
_) = Bool
True
    isUnitRHS (UnitPow (UnitParamPosAbs (VV, Int)
_) Double
_) = Bool
False
    isUnitRHS UnitInfo
_                               = Bool
False

    negateCons :: [UnitInfo] -> [UnitInfo]
negateCons = (UnitInfo -> UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (\ (UnitPow UnitInfo
u Double
k) -> UnitInfo -> Double -> UnitInfo
UnitPow UnitInfo
u (-Double
k))

    shiftTerms :: ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])
    shiftTerms :: ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])
shiftTerms ([UnitInfo]
lhs, [UnitInfo]
rhs) = ([UnitInfo]
lhsOk [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [UnitInfo]
negateCons [UnitInfo]
rhsShift, [UnitInfo]
rhsOk [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [UnitInfo]
negateCons [UnitInfo]
lhsShift)
      where
        ([UnitInfo]
lhsOk, [UnitInfo]
lhsShift) = (UnitInfo -> Bool) -> [UnitInfo] -> ([UnitInfo], [UnitInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Bool -> Bool
not (Bool -> Bool) -> (UnitInfo -> Bool) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> Bool
isUnitRHS) [UnitInfo]
lhs
        ([UnitInfo]
rhsOk, [UnitInfo]
rhsShift) = (UnitInfo -> Bool) -> [UnitInfo] -> ([UnitInfo], [UnitInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition UnitInfo -> Bool
isUnitRHS [UnitInfo]
rhs

    compileColSort :: SortFn
compileColSort = SortFn -> SortFn
forall a b c. (a -> b -> c) -> b -> a -> c
flip SortFn
colSort

-- | Generate a new ModFile containing Units information.
genUnitsModFile :: F.ProgramFile UA -> CompiledUnits -> ModFile
genUnitsModFile :: ProgramFile UA -> CompiledUnits -> ModFile
genUnitsModFile ProgramFile UA
pf CompiledUnits
cu = (Maybe ByteString -> Maybe ByteString)
-> String -> ModFile -> ModFile
alterModFileData Maybe ByteString -> Maybe ByteString
forall p. p -> Maybe ByteString
f String
unitsCompiledDataLabel (ModFile -> ModFile) -> ModFile -> ModFile
forall a b. (a -> b) -> a -> b
$ ProgramFile UA -> ModFile
forall a. Data a => ProgramFile (Analysis a) -> ModFile
genModFile ProgramFile UA
pf
  where
    f :: p -> Maybe ByteString
f p
_ = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ CompiledUnits -> ByteString
forall a. Binary a => a -> ByteString
encode CompiledUnits
cu

-- | Return information about compiled units for debugging purposes
dumpModFileCompiledUnits :: ModFile -> Maybe String
dumpModFileCompiledUnits :: ModFile -> Maybe String
dumpModFileCompiledUnits ModFile
mf = do
  ByteString
bs <- String -> ModFile -> Maybe ByteString
lookupModFileData String
unitsCompiledDataLabel ModFile
mf
  CompiledUnits
cu <- case ByteString
-> Either
     (ByteString, ByteOffset, String)
     (ByteString, ByteOffset, CompiledUnits)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bs of
    Left (ByteString, ByteOffset, String)
_ -> Maybe CompiledUnits
forall a. Maybe a
Nothing
    Right (ByteString
_, ByteOffset
_, CompiledUnits
cu) -> CompiledUnits -> Maybe CompiledUnits
forall a. a -> Maybe a
Just CompiledUnits
cu
  String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Maybe String)
-> ([String] -> String) -> [String] -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [ String
"Template Map (size=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (TemplateMap -> Int
forall k a. Map k a -> Int
M.size (CompiledUnits -> TemplateMap
cuTemplateMap CompiledUnits
cu)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"):"
                   , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String] -> String
unlines (Int -> ShowS
i Int
2 String
fname'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:(Constraint -> String) -> Constraints -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
i Int
4 ShowS -> (Constraint -> String) -> Constraint -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint -> String
forall a. Show a => a -> String
show) Constraints
temp)
                            | (String
fname, Constraints
temp) <- TemplateMap -> [(String, Constraints)]
forall k a. Map k a -> [(k, a)]
M.toList (CompiledUnits -> TemplateMap
cuTemplateMap CompiledUnits
cu)
                            , let fname' :: String
fname' = String
"Template for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
fname ]
                   , String
"NameParam Map  (size=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (NameParamMap -> Int
forall k a. Map k a -> Int
M.size (CompiledUnits -> NameParamMap
cuNameParamMap CompiledUnits
cu)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"):"
                   , [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [String] -> String
unlines (Int -> ShowS
i Int
2 String
mod'String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[ Int -> ShowS
i Int
4 ([UnitInfo] -> String
forall a. Show a => a -> String
show [UnitInfo]
ui String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
v)
                                                | (NPKVariable (String
v,String
_), [UnitInfo]
ui) <- Map NameParamKey [UnitInfo] -> [(NameParamKey, [UnitInfo])]
forall k a. Map k a -> [(k, a)]
M.toList Map NameParamKey [UnitInfo]
npkmap ])
                            | (ProgramUnitName
mod, Map NameParamKey [UnitInfo]
npkmap) <- NameParamMap -> [(ProgramUnitName, Map NameParamKey [UnitInfo])]
forall k a. Map k a -> [(k, a)]
M.toList (CompiledUnits -> NameParamMap
cuNameParamMap CompiledUnits
cu)
                            , let mod' :: String
mod' = String
"Module " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> String
forall a. Show a => a -> String
show ProgramUnitName
mod ]
                   ]
 where
   i :: Int -> ShowS
i Int
n String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s