{- |
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
$ccompare :: CompiledUnits -> CompiledUnits -> Ordering
compare :: CompiledUnits -> CompiledUnits -> Ordering
$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
>= :: CompiledUnits -> CompiledUnits -> Bool
$cmax :: CompiledUnits -> CompiledUnits -> CompiledUnits
max :: CompiledUnits -> CompiledUnits -> CompiledUnits
$cmin :: CompiledUnits -> CompiledUnits -> CompiledUnits
min :: CompiledUnits -> CompiledUnits -> CompiledUnits
Ord, CompiledUnits -> CompiledUnits -> Bool
(CompiledUnits -> CompiledUnits -> Bool)
-> (CompiledUnits -> CompiledUnits -> Bool) -> Eq CompiledUnits
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompiledUnits -> CompiledUnits -> Bool
== :: CompiledUnits -> CompiledUnits -> Bool
$c/= :: CompiledUnits -> CompiledUnits -> Bool
/= :: CompiledUnits -> CompiledUnits -> Bool
Eq, Int -> CompiledUnits -> ShowS
[CompiledUnits] -> ShowS
CompiledUnits -> Name
(Int -> CompiledUnits -> ShowS)
-> (CompiledUnits -> Name)
-> ([CompiledUnits] -> ShowS)
-> Show CompiledUnits
forall a.
(Int -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompiledUnits -> ShowS
showsPrec :: Int -> CompiledUnits -> ShowS
$cshow :: CompiledUnits -> Name
show :: CompiledUnits -> Name
$cshowList :: [CompiledUnits] -> ShowS
showList :: [CompiledUnits] -> ShowS
Show, Typeable CompiledUnits
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 -> Constr
CompiledUnits -> DataType
(forall b. Data b => b -> b) -> CompiledUnits -> 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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CompiledUnits -> c CompiledUnits
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CompiledUnits
$ctoConstr :: CompiledUnits -> Constr
toConstr :: CompiledUnits -> Constr
$cdataTypeOf :: CompiledUnits -> DataType
dataTypeOf :: CompiledUnits -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CompiledUnits)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CompiledUnits)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CompiledUnits)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CompiledUnits)
$cgmapT :: (forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits
gmapT :: (forall b. Data b => b -> b) -> CompiledUnits -> CompiledUnits
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
gmapQl :: forall r r'.
(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
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CompiledUnits -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CompiledUnits -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> CompiledUnits -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CompiledUnits -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m CompiledUnits
gmapM :: forall (m :: * -> *).
Monad m =>
(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
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(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
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CompiledUnits -> m 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
$cfrom :: forall x. CompiledUnits -> Rep CompiledUnits x
from :: forall x. CompiledUnits -> Rep CompiledUnits x
$cto :: forall x. Rep CompiledUnits x -> CompiledUnits
to :: forall x. Rep CompiledUnits x -> CompiledUnits
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 { 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 :: Name
unitsCompiledDataLabel = Name
"units-compiled-data"

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

-- | Initialize units-relevant ModFile information.
initializeModFiles :: UnitSolver ()
initializeModFiles :: UnitSolver ()
initializeModFiles = do
  ModFiles
mfs <- UnitAnalysis ModFiles -> StateT UnitState UnitAnalysis ModFiles
forall (m :: * -> *) a. Monad m => m a -> StateT UnitState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UnitAnalysis ModFiles -> StateT UnitState UnitAnalysis ModFiles)
-> (AnalysisT () () IO ModFiles -> UnitAnalysis ModFiles)
-> AnalysisT () () IO ModFiles
-> StateT UnitState UnitAnalysis ModFiles
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnalysisT () () IO ModFiles -> UnitAnalysis ModFiles
forall (m :: * -> *) a. Monad m => m a -> ReaderT UnitEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (AnalysisT () () IO ModFiles
 -> StateT UnitState UnitAnalysis ModFiles)
-> AnalysisT () () IO ModFiles
-> StateT UnitState UnitAnalysis 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
  [Constraint]
cons <- UnitState -> [Constraint]
usConstraints (UnitState -> [Constraint])
-> StateT UnitState UnitAnalysis UnitState
-> StateT UnitState UnitAnalysis [Constraint]
forall a b.
(a -> b)
-> StateT UnitState UnitAnalysis a
-> StateT UnitState UnitAnalysis b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT UnitState UnitAnalysis UnitState
forall s (m :: * -> *). MonadState s m => m s
get
  ProgramFile UA
pf <- UnitState -> ProgramFile UA
usProgramFile  (UnitState -> ProgramFile UA)
-> StateT UnitState UnitAnalysis UnitState
-> StateT UnitState UnitAnalysis (ProgramFile UA)
forall a b.
(a -> b)
-> StateT UnitState UnitAnalysis a
-> StateT UnitState UnitAnalysis b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT UnitState UnitAnalysis UnitState
forall s (m :: * -> *). MonadState s m => m s
get

  let unitAssigns :: [([UnitInfo], [UnitInfo])]
unitAssigns = [Constraint] -> [([UnitInfo], [UnitInfo])]
flattenConstraints [Constraint]
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 Name
getName ProgramUnit (Analysis a)
pu | F.Named Name
n <- ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
FA.puName ProgramUnit (Analysis a)
pu = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n | Bool
otherwise = Maybe Name
forall a. Maybe a
Nothing
  let puNameSet :: Set Name
puNameSet = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes [ ProgramUnit UA -> Maybe Name
forall {a}. ProgramUnit (Analysis a) -> Maybe Name
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] ] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
                               [ Expression UA -> Name
forall a. Expression (Analysis a) -> Name
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 -> Name
forall a. Expression (Analysis a) -> Name
FA.varName Expression UA
v, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
FA.srcName Expression UA
v) | F.Declarator UA
_ SrcSpan
_ Expression UA
v DeclaratorType 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 Name a -> Map Name a
filterPUs = (Name -> a -> Bool) -> Map Name a -> Map Name a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (Bool -> a -> Bool
forall a b. a -> b -> a
const (Bool -> a -> Bool) -> (Name -> Bool) -> Name -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Name
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 {a}. Map Name a -> Map Name a
filterPUs (TemplateMap -> TemplateMap)
-> (TemplateMap -> TemplateMap) -> TemplateMap -> TemplateMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Constraint] -> [Constraint]) -> TemplateMap -> TemplateMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map [Constraint] -> [Constraint]
optimiseTemplate) (TemplateMap -> TemplateMap)
-> StateT UnitState UnitAnalysis TemplateMap
-> StateT UnitState UnitAnalysis TemplateMap
forall a b.
(a -> b)
-> StateT UnitState UnitAnalysis a
-> StateT UnitState UnitAnalysis b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (UnitState -> TemplateMap)
-> StateT UnitState UnitAnalysis 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 a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: [Constraint] -> [Constraint]
optimiseTemplate [Constraint]
cons = (([UnitInfo], UnitInfo) -> Constraint)
-> [([UnitInfo], UnitInfo)] -> [Constraint]
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 -> [Constraint] -> [([UnitInfo], UnitInfo)]
genUnitAssignments' (SortFn
compileColSort) [Constraint]
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 a b. (a -> b) -> ([UnitInfo], a) -> ([UnitInfo], b)
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 a b. (a -> b) -> ([UnitInfo], a) -> ([UnitInfo], b)
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 Name
_) Double
_)        = Bool
True
    isUnitRHS (UnitPow (UnitParamEAPAbs VV
_) Double
_) = Bool
True
    isUnitRHS (UnitPow (UnitParamImpAbs Name
_) 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)
-> Name -> ModFile -> ModFile
alterModFileData Maybe ByteString -> Maybe ByteString
forall {p}. p -> Maybe ByteString
f Name
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 Name
dumpModFileCompiledUnits ModFile
mf = do
  ByteString
bs <- Name -> ModFile -> Maybe ByteString
lookupModFileData Name
unitsCompiledDataLabel ModFile
mf
  CompiledUnits
cu <- case ByteString
-> Either
     (ByteString, ByteOffset, Name)
     (ByteString, ByteOffset, CompiledUnits)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, Name) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bs of
    Left (ByteString, ByteOffset, Name)
_ -> Maybe CompiledUnits
forall a. Maybe a
Nothing
    Right (ByteString
_, ByteOffset
_, CompiledUnits
cu) -> CompiledUnits -> Maybe CompiledUnits
forall a. a -> Maybe a
Just CompiledUnits
cu
  Name -> Maybe Name
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Maybe Name) -> ([Name] -> Name) -> [Name] -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> Maybe Name) -> [Name] -> Maybe Name
forall a b. (a -> b) -> a -> b
$ [ Name
"Template Map (size=" Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show (TemplateMap -> Int
forall k a. Map k a -> Int
M.size (CompiledUnits -> TemplateMap
cuTemplateMap CompiledUnits
cu)) Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
"):"
                   , [Name] -> Name
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Name] -> Name
unlines (Int -> ShowS
i Int
2 Name
fname'Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:(Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> ShowS
i Int
4 ShowS -> (Constraint -> Name) -> Constraint -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint -> Name
forall a. Show a => a -> Name
show) [Constraint]
temp)
                            | (Name
fname, [Constraint]
temp) <- TemplateMap -> [(Name, [Constraint])]
forall k a. Map k a -> [(k, a)]
M.toList (CompiledUnits -> TemplateMap
cuTemplateMap CompiledUnits
cu)
                            , let fname' :: Name
fname' = Name
"Template for " Name -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> Name
show Name
fname ]
                   , Name
"NameParam Map  (size=" Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Name
forall a. Show a => a -> Name
show (NameParamMap -> Int
forall k a. Map k a -> Int
M.size (CompiledUnits -> NameParamMap
cuNameParamMap CompiledUnits
cu)) Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
"):"
                   , [Name] -> Name
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Name] -> Name
unlines (Int -> ShowS
i Int
2 Name
mod'Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[ Int -> ShowS
i Int
4 ([UnitInfo] -> Name
forall a. Show a => a -> Name
show [UnitInfo]
ui Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
" :: " Name -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> Name
show Name
v)
                                                | (NPKVariable (Name
v,Name
_), [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' :: Name
mod' = Name
"Module " Name -> ShowS
forall a. [a] -> [a] -> [a]
++ ProgramUnitName -> Name
forall a. Show a => a -> Name
show ProgramUnitName
mod ]
                   ]
 where
   i :: Int -> ShowS
i Int
n Name
s = Int -> Char -> Name
forall a. Int -> a -> [a]
replicate Int
n Char
' ' Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
s