{- |
Module      :  Camfort.Specification.Units.Analysis
Description :  Helpers for units refactoring and analysis.
Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish
License     :  Apache-2.0

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

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase        #-}

module Camfort.Specification.Units.Analysis
  ( UnitAnalysis
  , compileUnits
  , initInference
  , runInference
  , runUnitAnalysis
    -- ** Helpers
  , puName
  , puSrcName
  ) where

import           Camfort.Analysis
import           Camfort.Analysis.Annotations (Annotation)
import           Camfort.Analysis.CommentAnnotator (annotateComments)
import           Camfort.Analysis.Logger (LogLevel(..))
import           Camfort.Analysis.ModFile (withCombinedEnvironment)
import qualified Camfort.Specification.Units.Annotation as UA
import           Camfort.Specification.Units.Environment
import           Camfort.Specification.Units.InferenceBackend
import qualified Camfort.Specification.Units.InferenceBackendFlint as Flint
import qualified Camfort.Specification.Units.InferenceBackendSBV as BackendSBV
import           Camfort.Specification.Units.ModFile
  (genUnitsModFile, initializeModFiles, runCompileUnits)
import           Camfort.Specification.Units.Monad
import           Camfort.Specification.Units.MonadTypes
import           Camfort.Specification.Units.Parser (unitParser)
import qualified Camfort.Specification.Units.Parser.Types as P
import           Control.Lens ((^?), _1)
import           Control.Monad
import           Control.Monad.Reader
import           Control.Monad.State.Strict
import           Control.Monad.Writer.Lazy
import qualified Data.Array as A
import           Data.Data (Data)
import           Data.Generics.Uniplate.Operations
import qualified Data.IntMap.Strict as IM
import           Data.List (nub, intercalate)
import qualified Data.Map.Strict as M
import           Data.Maybe (isJust, fromMaybe, mapMaybe)
import qualified Data.Set as S
import           Data.Text (Text)
import qualified Language.Fortran.AST as F
import           Language.Fortran.Analysis (constExp, varName, srcName)
import qualified Language.Fortran.Analysis as FA
import qualified Language.Fortran.Analysis.SemanticTypes as FAS
import qualified Language.Fortran.Analysis.BBlocks as FAB
import qualified Language.Fortran.Analysis.DataFlow as FAD
import           Language.Fortran.AST.Literal.Real (readRealLit, parseRealLit)
import           Language.Fortran.Util.ModFile
import qualified Numeric.LinearAlgebra as H -- for debugging
import           Prelude hiding (mod)

-- | Prepare to run an inference function.
initInference :: UnitSolver ()
initInference :: UnitSolver ()
initInference = do
  ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile

  -- Parse unit annotations found in comments and link to their
  -- corresponding statements in the AST.
  let (ProgramFile UA
linkedPF, Name
_) =
        Writer Name (ProgramFile UA) -> (ProgramFile UA, Name)
forall w a. Writer w a -> (a, w)
runWriter (Writer Name (ProgramFile UA) -> (ProgramFile UA, Name))
-> Writer Name (ProgramFile UA) -> (ProgramFile UA, Name)
forall a b. (a -> b) -> a -> b
$ SpecParser UnitParseError UnitStatement
-> (SrcSpan
    -> SpecParseError UnitParseError -> WriterT Name Identity ())
-> ProgramFile UA
-> Writer Name (ProgramFile UA)
forall (m :: * -> *) e a ast.
(Monad m, Data a, Linkable a, ASTEmbeddable a ast) =>
SpecParser e ast
-> (SrcSpan -> SpecParseError e -> m ())
-> ProgramFile a
-> m (ProgramFile a)
annotateComments SpecParser UnitParseError UnitStatement
unitParser
        (\SrcSpan
srcSpan SpecParseError UnitParseError
err -> Name -> WriterT Name Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Name -> WriterT Name Identity ())
-> Name -> WriterT Name Identity ()
forall a b. (a -> b) -> a -> b
$ Name
"Error " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
srcSpan Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
": " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ SpecParseError UnitParseError -> Name
forall a. Show a => a -> Name
show SpecParseError UnitParseError
err) ProgramFile UA
pf
  (ProgramFile UA -> ProgramFile UA) -> UnitSolver ()
modifyProgramFile ((ProgramFile UA -> ProgramFile UA) -> UnitSolver ())
-> (ProgramFile UA -> ProgramFile UA) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ ProgramFile UA -> ProgramFile UA -> ProgramFile UA
forall a b. a -> b -> a
const ProgramFile UA
linkedPF

  -- The following insert* functions examine the AST and insert
  -- mappings into the tables stored in the UnitState.

  -- First, find all given unit annotations and insert them into our
  -- mappings.  Also obtain all unit alias definitions.
  UnitSolver ()
insertGivenUnits

  -- For function or subroutine parameters (or return variables) that
  -- are not given explicit units, give them a parametric polymorphic
  -- unit.
  UnitSolver ()
insertParametricUnits

  -- Any other variables get assigned a unique undetermined unit named
  -- after the variable. This assumes that all variables have unique
  -- names, which the renaming module already has assured.
  UnitSolver ()
insertUndeterminedUnits

  -- Now take the information that we have gathered and annotate the
  -- variable expressions within the AST with it.
  UnitSolver ()
annotateAllVariables

  -- Annotate the literals within the program based upon the
  -- Literals-mode option.
  UnitSolver ()
annotateLiterals

  -- With the variable expressions annotated, we now propagate the
  -- information throughout the AST, giving units to as many
  -- expressions as possible, and also constraints wherever
  -- appropriate.
  UnitSolver ()
propagateUnits

  -- Gather up all of the constraints that we identified in the AST.
  -- These constraints will include parametric polymorphic units that
  -- have not yet been instantiated into their particular uses.
  [Constraint]
abstractCons <- UnitSolver [Constraint]
extractConstraints
  Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"***abstractCons" [Constraint]
abstractCons

  -- Eliminate all parametric polymorphic units by copying them for
  -- each specific use cases and substituting a unique call-site
  -- identifier that distinguishes each use-case from the others.
  [Constraint]
cons <- [Constraint] -> UnitSolver [Constraint]
applyTemplates [Constraint]
abstractCons
  Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"***concreteCons" [Constraint]
cons

  -- Remove any traces of CommentAnnotator, since the annotations can
  -- cause generic operations traversing the AST to get confused.
  (ProgramFile UA -> ProgramFile UA) -> UnitSolver ()
modifyProgramFile ProgramFile UA -> ProgramFile UA
UA.cleanLinks

  ([Constraint] -> [Constraint]) -> UnitSolver ()
modifyConstraints ([Constraint] -> [Constraint] -> [Constraint]
forall a b. a -> b -> a
const [Constraint]
cons)

  UnitSolver ()
debugLogging

-- | Run a 'UnitSolver' analysis within a 'UnitsAnalysis'.
runInference :: UnitSolver a -> UnitAnalysis (a, UnitState)
runInference :: forall a. UnitSolver a -> UnitAnalysis (a, UnitState)
runInference UnitSolver a
solver = do
  ProgramFile A
pf <- (UnitEnv -> ProgramFile A)
-> ReaderT UnitEnv (AnalysisT () () IO) (ProgramFile A)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks UnitEnv -> ProgramFile A
unitProgramFile
  ModFiles
mfs <- AnalysisT () () IO ModFiles
-> ReaderT UnitEnv (AnalysisT () () IO) 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
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles

  let (ProgramFile UA
pf', ModuleMap
_, TypeEnv
_) = ModFiles
-> ProgramFile (UnitAnnotation A)
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall a.
Data a =>
ModFiles
-> ProgramFile a -> (ProgramFile (Analysis a), ModuleMap, TypeEnv)
withCombinedEnvironment ModFiles
mfs (ProgramFile (UnitAnnotation A)
 -> (ProgramFile UA, ModuleMap, TypeEnv))
-> (ProgramFile A -> ProgramFile (UnitAnnotation A))
-> ProgramFile A
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (A -> UnitAnnotation A)
-> ProgramFile A -> ProgramFile (UnitAnnotation A)
forall a b. (a -> b) -> ProgramFile a -> ProgramFile b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap A -> UnitAnnotation A
forall a. a -> UnitAnnotation a
UA.mkUnitAnnotation (ProgramFile A -> (ProgramFile UA, ModuleMap, TypeEnv))
-> ProgramFile A -> (ProgramFile UA, ModuleMap, TypeEnv)
forall a b. (a -> b) -> a -> b
$ ProgramFile A
pf
  let pvm :: ParamVarMap
pvm = ModFiles -> ParamVarMap
combinedParamVarMap ModFiles
mfs
  let pf'' :: ProgramFile UA
pf'' = ProgramFile UA -> ProgramFile UA
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
FAD.analyseConstExps (ProgramFile UA -> ProgramFile UA)
-> (ProgramFile UA -> ProgramFile UA)
-> ProgramFile UA
-> ProgramFile UA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamVarMap -> ProgramFile UA -> ProgramFile UA
forall a.
Data a =>
ParamVarMap -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
FAD.analyseParameterVars ParamVarMap
pvm (ProgramFile UA -> ProgramFile UA)
-> (ProgramFile UA -> ProgramFile UA)
-> ProgramFile UA
-> ProgramFile UA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramFile UA -> ProgramFile UA
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
FAB.analyseBBlocks (ProgramFile UA -> ProgramFile UA)
-> ProgramFile UA -> ProgramFile UA
forall a b. (a -> b) -> a -> b
$ ProgramFile UA
pf'
  ProgramFile UA -> UnitSolver a -> UnitAnalysis (a, UnitState)
forall a.
ProgramFile UA -> UnitSolver a -> UnitAnalysis (a, UnitState)
runUnitSolver ProgramFile UA
pf'' (UnitSolver a -> UnitAnalysis (a, UnitState))
-> UnitSolver a -> UnitAnalysis (a, UnitState)
forall a b. (a -> b) -> a -> b
$ do
    UnitSolver ()
initializeModFiles
    UnitSolver ()
initInference
    UnitSolver a
solver

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

-- | Seek out any parameters to functions or subroutines that do not
-- already have units, and insert parametric units for them into the
-- map of variables to UnitInfo.
insertParametricUnits :: UnitSolver ()
insertParametricUnits :: UnitSolver ()
insertParametricUnits = UnitSolver (ProgramFile UA)
getProgramFile UnitSolver (ProgramFile UA)
-> (ProgramFile UA -> UnitSolver ()) -> UnitSolver ()
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((ProgramUnit UA -> UnitSolver ())
-> [ProgramUnit UA] -> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProgramUnit UA -> UnitSolver ()
paramPU ([ProgramUnit UA] -> UnitSolver ())
-> (ProgramFile UA -> [ProgramUnit UA])
-> ProgramFile UA
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi)
  where
    paramPU :: ProgramUnit UA -> UnitSolver ()
paramPU ProgramUnit UA
pu =
      [(Int, VV)] -> ((Int, VV) -> UnitSolver ()) -> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProgramUnit UA -> [(Int, VV)]
indexedParams ProgramUnit UA
pu) (((Int, VV) -> UnitSolver ()) -> UnitSolver ())
-> ((Int, VV) -> UnitSolver ()) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ (Int
i, VV
param) ->
        -- Insert a parametric unit if the variable does not already have a unit.
        (VarUnitMap -> VarUnitMap) -> UnitSolver ()
modifyVarUnitMap ((VarUnitMap -> VarUnitMap) -> UnitSolver ())
-> (VarUnitMap -> VarUnitMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> UnitInfo)
-> VV -> UnitInfo -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (((UnitInfo, UnitInfo) -> UnitInfo)
-> UnitInfo -> UnitInfo -> UnitInfo
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (UnitInfo, UnitInfo) -> UnitInfo
forall a b. (a, b) -> b
snd) VV
param ((VV, Int) -> UnitInfo
UnitParamPosAbs (VV
fname, Int
i))
      where
        fname :: VV
fname = (ProgramUnit UA -> Name
puName ProgramUnit UA
pu, ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu)

-- | Return the list of parameters paired with its positional index.
indexedParams :: F.ProgramUnit UA -> [(Int, VV)]
indexedParams :: ProgramUnit UA -> [(Int, VV)]
indexedParams ProgramUnit UA
pu
  | F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ Maybe (AList Expression UA)
Nothing (Just Expression UA
r) [Block UA]
_ Maybe [ProgramUnit UA]
_       <- ProgramUnit UA
pu = [(Int
0, Expression UA -> VV
forall {a}. Expression (Analysis a) -> VV
toVV Expression UA
r)]
  | F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ Maybe (AList Expression UA)
Nothing Maybe (Expression UA)
_ [Block UA]
_ Maybe [ProgramUnit UA]
_              <- ProgramUnit UA
pu = [(Int
0, (Name
fname, Name
sfname))]
  | F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ (Just AList Expression UA
paList) (Just Expression UA
r) [Block UA]
_ Maybe [ProgramUnit UA]
_ <- ProgramUnit UA
pu = [Int] -> [VV] -> [(Int, VV)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([VV] -> [(Int, VV)]) -> [VV] -> [(Int, VV)]
forall a b. (a -> b) -> a -> b
$ (Expression UA -> VV) -> [Expression UA] -> [VV]
forall a b. (a -> b) -> [a] -> [b]
map Expression UA -> VV
forall {a}. Expression (Analysis a) -> VV
toVV (Expression UA
r Expression UA -> [Expression UA] -> [Expression UA]
forall a. a -> [a] -> [a]
: AList Expression UA -> [Expression UA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList Expression UA
paList)
  | F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ (Just AList Expression UA
paList) Maybe (Expression UA)
_ [Block UA]
_ Maybe [ProgramUnit UA]
_        <- ProgramUnit UA
pu = [Int] -> [VV] -> [(Int, VV)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([VV] -> [(Int, VV)]) -> [VV] -> [(Int, VV)]
forall a b. (a -> b) -> a -> b
$ (Name
fname, Name
sfname) VV -> [VV] -> [VV]
forall a. a -> [a] -> [a]
: (Expression UA -> VV) -> [Expression UA] -> [VV]
forall a b. (a -> b) -> [a] -> [b]
map Expression UA -> VV
forall {a}. Expression (Analysis a) -> VV
toVV (AList Expression UA -> [Expression UA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList Expression UA
paList)
  | F.PUSubroutine UA
_ SrcSpan
_ PrefixSuffix UA
_ Name
_ (Just AList Expression UA
paList) [Block UA]
_ Maybe [ProgramUnit UA]
_          <- ProgramUnit UA
pu = [Int] -> [VV] -> [(Int, VV)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([VV] -> [(Int, VV)]) -> [VV] -> [(Int, VV)]
forall a b. (a -> b) -> a -> b
$ (Expression UA -> VV) -> [Expression UA] -> [VV]
forall a b. (a -> b) -> [a] -> [b]
map Expression UA -> VV
forall {a}. Expression (Analysis a) -> VV
toVV (AList Expression UA -> [Expression UA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList Expression UA
paList)
  | Bool
otherwise                                               = []
  where
    fname :: Name
fname  = ProgramUnit UA -> Name
puName ProgramUnit UA
pu
    sfname :: Name
sfname = ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu
    toVV :: Expression (Analysis a) -> VV
toVV Expression (Analysis a)
e = (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e, Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e)

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

-- | Any remaining variables with unknown units are given unit UnitVar
-- with a unique name (in this case, taken from the unique name of the
-- variable as provided by the Renamer), or UnitParamVarAbs if the
-- variables are inside of a function or subroutine.
insertUndeterminedUnits :: UnitSolver ()
insertUndeterminedUnits :: UnitSolver ()
insertUndeterminedUnits = do
  ProgramFile UA
pf   <- UnitSolver (ProgramFile UA)
getProgramFile
  Map Name (DeclContext, SrcSpan)
dmap <- UnitAnalysis (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
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 (Map Name (DeclContext, SrcSpan))
 -> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> (AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
    -> UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> UnitAnalysis (Map Name (DeclContext, SrcSpan))
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 (Map Name (DeclContext, SrcSpan))
 -> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall a b. (a -> b) -> a -> b
$ Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (ProgramFile UA -> Map Name (DeclContext, SrcSpan)
forall a.
Data a =>
ProgramFile (Analysis a) -> Map Name (DeclContext, SrcSpan)
extractDeclMap ProgramFile UA
pf) (Map Name (DeclContext, SrcSpan)
 -> Map Name (DeclContext, SrcSpan))
-> (ModFiles -> Map Name (DeclContext, SrcSpan))
-> ModFiles
-> Map Name (DeclContext, SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModFiles -> Map Name (DeclContext, SrcSpan)
combinedDeclMap (ModFiles -> Map Name (DeclContext, SrcSpan))
-> AnalysisT () () IO ModFiles
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnalysisT () () IO ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
  [ProgramUnit UA]
-> (ProgramUnit UA
    -> StateT UnitState UnitAnalysis (ProgramUnit UA))
-> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [F.ProgramUnit UA]) ((ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA))
 -> UnitSolver ())
-> (ProgramUnit UA
    -> StateT UnitState UnitAnalysis (ProgramUnit UA))
-> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit UA
pu ->
    ([Block UA] -> StateT UnitState UnitAnalysis [Block UA])
-> ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> [Block UA] -> StateT UnitState UnitAnalysis [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (Map Name (DeclContext, SrcSpan)
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
insertUndeterminedUnitVar Map Name (DeclContext, SrcSpan)
dmap)) ProgramUnit UA
pu

-- Specifically handle variables
insertUndeterminedUnitVar :: DeclMap -> F.Expression UA -> UnitSolver (F.Expression UA)
insertUndeterminedUnitVar :: Map Name (DeclContext, SrcSpan)
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
insertUndeterminedUnitVar Map Name (DeclContext, SrcSpan)
dmap v :: Expression UA
v@(F.ExpValue UA
_ SrcSpan
_ (F.ValVariable Name
_))
  | Just (FA.IDType { idVType :: IDType -> Maybe SemType
FA.idVType = Just SemType
sty }) <- UA -> Maybe IDType
forall a. Analysis a -> Maybe IDType
FA.idType (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
v)
  , SemType -> Bool
isAcceptableType SemType
sty = do
  let vname :: Name
vname = Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
v
  let sname :: Name
sname = Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
v
  let unit :: UnitInfo
unit  = Map Name (DeclContext, SrcSpan) -> VV -> UnitInfo
toUnitVar Map Name (DeclContext, SrcSpan)
dmap (Name
vname, Name
sname)
  (VarUnitMap -> VarUnitMap) -> UnitSolver ()
modifyVarUnitMap ((VarUnitMap -> VarUnitMap) -> UnitSolver ())
-> (VarUnitMap -> VarUnitMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> UnitInfo)
-> VV -> UnitInfo -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (((UnitInfo, UnitInfo) -> UnitInfo)
-> UnitInfo -> UnitInfo -> UnitInfo
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (UnitInfo, UnitInfo) -> UnitInfo
forall a b. (a, b) -> b
snd) (Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
v, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
v) UnitInfo
unit
  Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
v
insertUndeterminedUnitVar Map Name (DeclContext, SrcSpan)
_ Expression UA
e = Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e

-- Choose UnitVar or UnitParamVarAbs depending upon how the variable was declared.
toUnitVar :: DeclMap -> VV -> UnitInfo
toUnitVar :: Map Name (DeclContext, SrcSpan) -> VV -> UnitInfo
toUnitVar Map Name (DeclContext, SrcSpan)
dmap (Name
vname, Name
sname) = UnitInfo
unit
  where
    unit :: UnitInfo
unit = case (DeclContext, SrcSpan) -> DeclContext
forall a b. (a, b) -> a
fst ((DeclContext, SrcSpan) -> DeclContext)
-> Maybe (DeclContext, SrcSpan) -> Maybe DeclContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name
-> Map Name (DeclContext, SrcSpan) -> Maybe (DeclContext, SrcSpan)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
vname Map Name (DeclContext, SrcSpan)
dmap of
      Just (DCFunction (F.Named Name
fvname, F.Named Name
fsname))   -> (VV, VV) -> UnitInfo
UnitParamVarAbs ((Name
fvname, Name
fsname), (Name
vname, Name
sname))
      Just (DCSubroutine (F.Named Name
fvname, F.Named Name
fsname)) -> (VV, VV) -> UnitInfo
UnitParamVarAbs ((Name
fvname, Name
fsname), (Name
vname, Name
sname))
      Maybe DeclContext
_                                                    -> VV -> UnitInfo
UnitVar (Name
vname, Name
sname)

-- Insert undetermined units annotations on the following types of variables.
isAcceptableType :: FAS.SemType -> Bool
isAcceptableType :: SemType -> Bool
isAcceptableType = \case
  FAS.TReal    Int
_ -> Bool
True
  FAS.TComplex Int
_ -> Bool
True
  FAS.TInteger Int
_ -> Bool
True
  SemType
_              -> Bool
False

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

-- | Convert explicit polymorphic annotations such as (UnitName "'a")
-- into UnitParamEAPAbs with a 'context-unique-name' given by the
-- ProgramUnitName combined with the supplied unit name.
transformExplicitPolymorphism :: Maybe F.ProgramUnitName -> UnitInfo -> UnitInfo
transformExplicitPolymorphism :: Maybe ProgramUnitName -> UnitInfo -> UnitInfo
transformExplicitPolymorphism (Just (F.Named Name
f)) (UnitName a :: Name
a@(Char
'\'':Name
_)) = VV -> UnitInfo
UnitParamEAPAbs (Name
a, Name
f Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"_" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
a)
transformExplicitPolymorphism Maybe ProgramUnitName
_ UnitInfo
u                                      = UnitInfo
u

-- | Any units provided by the programmer through comment annotations
-- will be incorporated into the VarUnitMap.
insertGivenUnits :: UnitSolver ()
insertGivenUnits :: UnitSolver ()
insertGivenUnits = do
  ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile
  (ProgramUnit UA -> UnitSolver ())
-> [ProgramUnit UA] -> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProgramUnit UA -> UnitSolver ()
checkPU (ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf)
  where
    -- Look through each Program Unit for the comments
    checkPU :: F.ProgramUnit UA -> UnitSolver ()
    checkPU :: ProgramUnit UA -> UnitSolver ()
checkPU (F.PUComment UA
a SrcSpan
_ Comment UA
_)
      -- Look at unit assignment between function return variable and spec.
      | Just (P.UnitAssignment (Just [Name]
vars) UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec
      , Just ProgramUnit UA
pu                                      <- Maybe (ProgramUnit UA)
mPU = UnitInfo -> ProgramUnit UA -> [Name] -> UnitSolver ()
insertPUUnitAssigns (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST) ProgramUnit UA
pu [Name]
vars
      -- Add a new unit alias.
      | Just (P.UnitAlias Name
name UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec = (UnitAliasMap -> UnitAliasMap) -> UnitSolver ()
modifyUnitAliasMap (Name -> UnitInfo -> UnitAliasMap -> UnitAliasMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST))
      | Bool
otherwise                                 = () -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        mSpec :: Maybe UnitStatement
mSpec = UnitAnnotation A -> Maybe UnitStatement
forall a. UnitAnnotation a -> Maybe UnitStatement
UA.unitSpec (UA -> UnitAnnotation A
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
        mPU :: Maybe (ProgramUnit UA)
mPU   = UnitAnnotation A -> Maybe (ProgramUnit UA)
forall a.
UnitAnnotation a
-> Maybe (ProgramUnit (Analysis (UnitAnnotation a)))
UA.unitPU   (UA -> UnitAnnotation A
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
    -- Other type of ProgramUnit (e.g. one with a body of blocks)
    checkPU ProgramUnit UA
pu = (Block UA -> UnitSolver ()) -> [Block UA] -> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe ProgramUnitName -> Block UA -> UnitSolver ()
checkBlockComment Maybe ProgramUnitName
getName) [ Block UA
b | b :: Block UA
b@F.BlComment{} <- [Block UA] -> [Block UA]
forall from to. Biplate from to => from -> [to]
universeBi (ProgramUnit UA -> [Block UA]
forall a. ProgramUnit a -> [Block a]
F.programUnitBody ProgramUnit UA
pu) ]
      where
        getName :: Maybe ProgramUnitName
getName = case ProgramUnit UA
pu of
          F.PUFunction {}   -> ProgramUnitName -> Maybe ProgramUnitName
forall a. a -> Maybe a
Just (ProgramUnitName -> Maybe ProgramUnitName)
-> ProgramUnitName -> Maybe ProgramUnitName
forall a b. (a -> b) -> a -> b
$ ProgramUnit UA -> ProgramUnitName
forall a. Named a => a -> ProgramUnitName
F.getName ProgramUnit UA
pu
          F.PUSubroutine {} -> ProgramUnitName -> Maybe ProgramUnitName
forall a. a -> Maybe a
Just (ProgramUnitName -> Maybe ProgramUnitName)
-> ProgramUnitName -> Maybe ProgramUnitName
forall a b. (a -> b) -> a -> b
$ ProgramUnit UA -> ProgramUnitName
forall a. Named a => a -> ProgramUnitName
F.getName ProgramUnit UA
pu
          ProgramUnit UA
_                 -> Maybe ProgramUnitName
forall a. Maybe a
Nothing

    -- Look through each comment that has some kind of unit annotation within it.
    checkBlockComment :: Maybe F.ProgramUnitName -> F.Block UA -> UnitSolver ()
    checkBlockComment :: Maybe ProgramUnitName -> Block UA -> UnitSolver ()
checkBlockComment Maybe ProgramUnitName
pname (F.BlComment UA
a SrcSpan
_ Comment UA
_)
      -- Look at unit assignment between variable and spec.
      | Just (P.UnitAssignment (Just [Name]
vars) UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec
      , Just Block UA
b                                       <- Maybe (Block UA)
mBlock = Maybe ProgramUnitName
-> UnitInfo -> Block UA -> [Name] -> UnitSolver ()
insertBlockUnitAssigns Maybe ProgramUnitName
pname (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST) Block UA
b [Name]
vars
      -- Add a new unit alias.
      | Just (P.UnitAlias Name
name UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec  = (UnitAliasMap -> UnitAliasMap) -> UnitSolver ()
modifyUnitAliasMap (Name -> UnitInfo -> UnitAliasMap -> UnitAliasMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST))
      | Bool
otherwise                                  = () -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        mSpec :: Maybe UnitStatement
mSpec  = UnitAnnotation A -> Maybe UnitStatement
forall a. UnitAnnotation a -> Maybe UnitStatement
UA.unitSpec  (UA -> UnitAnnotation A
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
        mBlock :: Maybe (Block UA)
mBlock = UnitAnnotation A -> Maybe (Block UA)
forall a.
UnitAnnotation a -> Maybe (Block (Analysis (UnitAnnotation a)))
UA.unitBlock (UA -> UnitAnnotation A
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
    checkBlockComment Maybe ProgramUnitName
_ Block UA
_ = Name -> UnitSolver ()
forall a. HasCallStack => Name -> a
error Name
"received non-comment in checkBlockComment"

    -- Figure out the unique names of the referenced variables and
    -- then insert unit info under each of those names.
    insertBlockUnitAssigns :: Maybe F.ProgramUnitName -> UnitInfo -> F.Block UA -> [String] -> UnitSolver ()
    insertBlockUnitAssigns :: Maybe ProgramUnitName
-> UnitInfo -> Block UA -> [Name] -> UnitSolver ()
insertBlockUnitAssigns Maybe ProgramUnitName
pname UnitInfo
info (F.BlStatement UA
_ SrcSpan
_ Maybe (Expression UA)
_ (F.StDeclaration UA
_ SrcSpan
_ TypeSpec UA
_ Maybe (AList Attribute UA)
_ AList Declarator UA
decls)) [Name]
varRealNames = do
      -- figure out the 'unique name' of the varRealName that was found in the comment
      -- FIXME: account for module renaming
      -- FIXME: might be more efficient to allow access to variable renaming environ at this program point
      let info' :: UnitInfo
info' = (UnitInfo -> UnitInfo) -> UnitInfo -> UnitInfo
forall on. Uniplate on => (on -> on) -> on -> on
transform (Maybe ProgramUnitName -> UnitInfo -> UnitInfo
transformExplicitPolymorphism Maybe ProgramUnitName
pname) UnitInfo
info
      let m :: VarUnitMap
m = [(VV, UnitInfo)] -> VarUnitMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ ((Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
e, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
e), UnitInfo
info')
                         | e :: Expression UA
e@(F.ExpValue UA
_ SrcSpan
_ (F.ValVariable Name
_)) <- AList Declarator UA -> [Expression UA]
forall from to. Biplate from to => from -> [to]
universeBi AList Declarator UA
decls :: [F.Expression UA]
                         , Name
varRealName <- [Name]
varRealNames
                         , Name
varRealName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
e ]
      (VarUnitMap -> VarUnitMap) -> UnitSolver ()
modifyVarUnitMap ((VarUnitMap -> VarUnitMap) -> UnitSolver ())
-> (VarUnitMap -> VarUnitMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> UnitInfo)
-> VarUnitMap -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith UnitInfo -> UnitInfo -> UnitInfo
forall a b. a -> b -> a
const VarUnitMap
m
      (GivenVarSet -> GivenVarSet) -> UnitSolver ()
modifyGivenVarSet ((GivenVarSet -> GivenVarSet) -> UnitSolver ())
-> (VarUnitMap -> GivenVarSet -> GivenVarSet)
-> VarUnitMap
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GivenVarSet -> GivenVarSet -> GivenVarSet
forall a. Ord a => Set a -> Set a -> Set a
S.union (GivenVarSet -> GivenVarSet -> GivenVarSet)
-> (VarUnitMap -> GivenVarSet)
-> VarUnitMap
-> GivenVarSet
-> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> GivenVarSet
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> GivenVarSet)
-> (VarUnitMap -> [Name]) -> VarUnitMap -> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VV -> Name) -> [VV] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map VV -> Name
forall a b. (a, b) -> a
fst ([VV] -> [Name]) -> (VarUnitMap -> [VV]) -> VarUnitMap -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarUnitMap -> [VV]
forall k a. Map k a -> [k]
M.keys (VarUnitMap -> UnitSolver ()) -> VarUnitMap -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ VarUnitMap
m
    insertBlockUnitAssigns Maybe ProgramUnitName
_ UnitInfo
_ Block UA
_ [Name]
_ = Name -> UnitSolver ()
forall a. HasCallStack => Name -> a
error Name
"received non-statement/declaration in insertBlockUnitAssigns"

    -- Insert unit annotation for function return variable
    insertPUUnitAssigns :: UnitInfo -> F.ProgramUnit UA -> [String] -> UnitSolver ()
    insertPUUnitAssigns :: UnitInfo -> ProgramUnit UA -> [Name] -> UnitSolver ()
insertPUUnitAssigns UnitInfo
info pu :: ProgramUnit UA
pu@(F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ Maybe (AList Expression UA)
_ Maybe (Expression UA)
mret [Block UA]
_ Maybe [ProgramUnit UA]
_) [Name]
varRealNames
      | (Name
retUniq, Name
retSrc) <- case Maybe (Expression UA)
mret of Just Expression UA
ret -> (Expression UA -> Name
forall a. Expression (Analysis a) -> Name
FA.varName Expression UA
ret, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
FA.srcName Expression UA
ret)
                                          Maybe (Expression UA)
Nothing  -> (ProgramUnit UA -> Name
puName ProgramUnit UA
pu, ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu)
      , Name
retSrc Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
varRealNames = do
          let pname :: Maybe ProgramUnitName
pname = ProgramUnitName -> Maybe ProgramUnitName
forall a. a -> Maybe a
Just (ProgramUnitName -> Maybe ProgramUnitName)
-> ProgramUnitName -> Maybe ProgramUnitName
forall a b. (a -> b) -> a -> b
$ ProgramUnit UA -> ProgramUnitName
forall a. Named a => a -> ProgramUnitName
F.getName ProgramUnit UA
pu
          let info' :: UnitInfo
info' = (UnitInfo -> UnitInfo) -> UnitInfo -> UnitInfo
forall on. Uniplate on => (on -> on) -> on -> on
transform (Maybe ProgramUnitName -> UnitInfo -> UnitInfo
transformExplicitPolymorphism Maybe ProgramUnitName
pname) UnitInfo
info
          let m :: VarUnitMap
m = [(VV, UnitInfo)] -> VarUnitMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ ((Name
retUniq, Name
retSrc), UnitInfo
info') ]
          (VarUnitMap -> VarUnitMap) -> UnitSolver ()
modifyVarUnitMap ((VarUnitMap -> VarUnitMap) -> UnitSolver ())
-> (VarUnitMap -> VarUnitMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> UnitInfo)
-> VarUnitMap -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith UnitInfo -> UnitInfo -> UnitInfo
forall a b. a -> b -> a
const VarUnitMap
m
          (GivenVarSet -> GivenVarSet) -> UnitSolver ()
modifyGivenVarSet ((GivenVarSet -> GivenVarSet) -> UnitSolver ())
-> (VarUnitMap -> GivenVarSet -> GivenVarSet)
-> VarUnitMap
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GivenVarSet -> GivenVarSet -> GivenVarSet
forall a. Ord a => Set a -> Set a -> Set a
S.union (GivenVarSet -> GivenVarSet -> GivenVarSet)
-> (VarUnitMap -> GivenVarSet)
-> VarUnitMap
-> GivenVarSet
-> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> GivenVarSet
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> GivenVarSet)
-> (VarUnitMap -> [Name]) -> VarUnitMap -> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VV -> Name) -> [VV] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map VV -> Name
forall a b. (a, b) -> a
fst ([VV] -> [Name]) -> (VarUnitMap -> [VV]) -> VarUnitMap -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarUnitMap -> [VV]
forall k a. Map k a -> [k]
M.keys (VarUnitMap -> UnitSolver ()) -> VarUnitMap -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ VarUnitMap
m
    insertPUUnitAssigns UnitInfo
_ ProgramUnit UA
_ [Name]
_ = Name -> UnitSolver ()
forall a. HasCallStack => Name -> a
error Name
"received non-function in insertPUUnitAssigns"

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

-- | Take the unit information from the VarUnitMap and use it to
-- annotate every variable expression in the AST.
annotateAllVariables :: UnitSolver ()
annotateAllVariables :: UnitSolver ()
annotateAllVariables = (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
modifyProgramFileM ((ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ())
-> (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ ProgramFile UA
pf -> do
  VarUnitMap
varUnitMap <- UnitSolver VarUnitMap
getVarUnitMap
  VarUnitMap
importedVariables <- UnitSolver VarUnitMap
getImportedVariables
  let varUnitMap' :: VarUnitMap
varUnitMap' = (UnitInfo -> UnitInfo -> UnitInfo)
-> VarUnitMap -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (((UnitInfo, UnitInfo) -> UnitInfo)
-> UnitInfo -> UnitInfo -> UnitInfo
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (UnitInfo, UnitInfo) -> UnitInfo
forall a b. (a, b) -> b
snd) VarUnitMap
varUnitMap VarUnitMap
importedVariables

  let annotateExp :: Expression UA -> Expression UA
annotateExp e :: Expression UA
e@(F.ExpValue UA
_ SrcSpan
_ (F.ValVariable Name
_))
        | Just UnitInfo
info <- VV -> VarUnitMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
e, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
e) VarUnitMap
varUnitMap' = UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
info Expression UA
e
      -- may need to annotate intrinsics separately
      annotateExp Expression UA
e = Expression UA
e
  ProgramFile UA -> UnitSolver (ProgramFile UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall a b. (a -> b) -> a -> b
$ (Expression UA -> Expression UA)
-> ProgramFile UA -> ProgramFile UA
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi Expression UA -> Expression UA
annotateExp ProgramFile UA
pf

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

-- | Give units to literals based upon the rules of the Literals mode.
--
-- LitUnitless: All literals are unitless.
-- LitPoly:     All literals are polymorphic.
-- LitMixed:    The literal "0" or "0.0" is fully parametric polymorphic.
--              All other literals are monomorphic, possibly unitless.
annotateLiterals :: UnitSolver ()
annotateLiterals :: UnitSolver ()
annotateLiterals = (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
modifyProgramFileM ((ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
annotateLiteralsPU)

annotateLiteralsPU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)
annotateLiteralsPU :: ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
annotateLiteralsPU ProgramUnit UA
pu = do
  LiteralsOpt
mode <- (UnitEnv -> LiteralsOpt)
-> StateT UnitState UnitAnalysis LiteralsOpt
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (UnitOpts -> LiteralsOpt
uoLiterals (UnitOpts -> LiteralsOpt)
-> (UnitEnv -> UnitOpts) -> UnitEnv -> LiteralsOpt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitEnv -> UnitOpts
unitOpts)
  case LiteralsOpt
mode of
    LiteralsOpt
LitUnitless -> ([Block UA] -> StateT UnitState UnitAnalysis [Block UA])
-> ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> [Block UA] -> StateT UnitState UnitAnalysis [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
Expression UA -> f (Expression UA)
expUnitless) ProgramUnit UA
pu
    LiteralsOpt
LitPoly     -> ([Block UA] -> StateT UnitState UnitAnalysis [Block UA])
-> ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> [Block UA] -> StateT UnitState UnitAnalysis [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genParamLit)) ProgramUnit UA
pu
    LiteralsOpt
LitMixed    -> ([Block UA] -> StateT UnitState UnitAnalysis [Block UA])
-> ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> [Block UA] -> StateT UnitState UnitAnalysis [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
expMixed) ProgramUnit UA
pu
  where
    -- Follow the LitMixed rules.
    expMixed :: Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
expMixed Expression UA
e = case Expression UA
e of
      F.ExpValue UA
_ SrcSpan
_ (F.ValInteger Name
i Maybe (KindParam UA)
_)
        | Name -> Integer
forall a. Read a => Name -> a
read Name
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genParamLit Expression UA
e
        | Bool
otherwise   -> StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genUnitLiteral Expression UA
e
      F.ExpValue UA
_ SrcSpan
_ (F.ValReal RealLit
i Maybe (KindParam UA)
_)
        | RealLit -> Double
forall a. (Fractional a, Read a) => RealLit -> a
readRealLit RealLit
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0.0 -> StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genParamLit Expression UA
e
        | Bool
otherwise            -> StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genUnitLiteral Expression UA
e

      F.ExpBinary UA
a SrcSpan
s BinaryOp
op Expression UA
e1 Expression UA
e2
        | BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
F.Multiplication, BinaryOp
F.Division] -> case () of
            -- leave it alone if they're both constants
            ()
_ | Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e1)
              , Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e2)        -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
            -- a constant multiplier is unitless
            ()
_ | Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e1)
              , Just UnitLiteral{} <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1         ->
                Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ UA
-> SrcSpan
-> BinaryOp
-> Expression UA
-> Expression UA
-> Expression UA
forall a.
a
-> SrcSpan
-> BinaryOp
-> Expression a
-> Expression a
-> Expression a
F.ExpBinary UA
a SrcSpan
s BinaryOp
op (UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
UnitlessLit Expression UA
e1) Expression UA
e2
            -- a constant multiplier is unitless
              | Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e2)
              , Just UnitLiteral{} <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2         ->
                Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ UA
-> SrcSpan
-> BinaryOp
-> Expression UA
-> Expression UA
-> Expression UA
forall a.
a
-> SrcSpan
-> BinaryOp
-> Expression a
-> Expression a
-> Expression a
F.ExpBinary UA
a SrcSpan
s BinaryOp
op Expression UA
e1 (UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
UnitlessLit Expression UA
e2)
            ()
_                                                   -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e

      Expression UA
_ | Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e)                -> case Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e of
            -- Treat constant expressions as if they were fresh
            -- literals, unless assigned units already.
            Just UnitLiteral{} -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
genLit Expression UA
e
            Just UnitVar{}     -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
genLit Expression UA
e
            Maybe UnitInfo
_                  -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
        | Bool
otherwise                                             -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e

    -- Set all literals to unitless.
    expUnitless :: Expression UA -> f (Expression UA)
expUnitless Expression UA
e
      | Expression UA -> Bool
isLiteral Expression UA
e = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> f (Expression UA))
-> Expression UA -> f (Expression UA)
forall a b. (a -> b) -> a -> b
$ UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
UnitlessLit Expression UA
e
      | Bool
otherwise   = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e

    -- Set all literals to the result of given monadic computation.
    withLiterals :: f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals f UnitInfo
m Expression UA
e
      | Expression UA -> Bool
isLiteral Expression UA
e = (UnitInfo -> Expression UA -> Expression UA)
-> Expression UA -> UnitInfo -> Expression UA
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo Expression UA
e (UnitInfo -> Expression UA) -> f UnitInfo -> f (Expression UA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f UnitInfo
m
      | Bool
otherwise   = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e

    -- isPolyCtxt = case pu of F.PUFunction {} -> True; F.PUSubroutine {} -> True; _ -> False

    genLit :: Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
genLit Expression UA
e
      | Expression UA -> Bool
isLiteralZero Expression UA
e = StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genParamLit Expression UA
e
      | Bool
otherwise       = StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genUnitLiteral Expression UA
e

-- | Is it a literal, literally?
isLiteral :: F.Expression UA -> Bool
isLiteral :: Expression UA -> Bool
isLiteral (F.ExpValue UA
_ SrcSpan
_ F.ValReal{})    = Bool
True
isLiteral (F.ExpValue UA
_ SrcSpan
_ F.ValInteger{}) = Bool
True
-- allow propagated constants to be interpreted as literals
isLiteral Expression UA
e                                 = Maybe Constant -> Bool
forall a. Maybe a -> Bool
isJust (UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e))

-- | Is expression a literal and is it non-zero?
isLiteralNonZero :: F.Expression UA -> Bool
isLiteralNonZero :: Expression UA -> Bool
isLiteralNonZero (F.ExpValue UA
_ SrcSpan
_ (F.ValInteger Name
i Maybe (KindParam UA)
_)) = Name -> Integer
forall a. Read a => Name -> a
read        Name
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
isLiteralNonZero (F.ExpValue UA
_ SrcSpan
_ (F.ValReal RealLit
i Maybe (KindParam UA)
_))    = RealLit -> Double
forall a. (Fractional a, Read a) => RealLit -> a
readRealLit RealLit
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0.0
-- allow propagated constants to be interpreted as literals
isLiteralNonZero Expression UA
e = case UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e) of
  Just (FA.ConstInt Integer
i)          -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
  Just (FA.ConstUninterpInt Name
s)  -> Name -> Integer
forall a. Read a => Name -> a
read Name
s Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
  Just (FA.ConstUninterpReal Name
s) -> RealLit -> Double
forall a. (Fractional a, Read a) => RealLit -> a
readRealLit (Name -> RealLit
parseRealLit Name
s) Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0.0
  Maybe Constant
_                             -> Bool
False

isLiteralZero :: F.Expression UA -> Bool
isLiteralZero :: Expression UA -> Bool
isLiteralZero Expression UA
x = Expression UA -> Bool
isLiteral Expression UA
x Bool -> Bool -> Bool
&& Bool -> Bool
not (Expression UA -> Bool
isLiteralNonZero Expression UA
x)

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

-- | Filter out redundant constraints.
cullRedundant :: Constraints -> Constraints
cullRedundant :: [Constraint] -> [Constraint]
cullRedundant = [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
nub ([Constraint] -> [Constraint])
-> ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> Maybe Constraint) -> [Constraint] -> [Constraint]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ( \ Constraint
con -> case Constraint
con of
  ConEq UnitInfo
u1 UnitInfo
u2 | UnitInfo
u1 UnitInfo -> UnitInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitInfo
u2                              -> Constraint -> Maybe Constraint
forall a. a -> Maybe a
Just Constraint
con
  ConConj [Constraint]
cs | [Constraint]
cs' <- [Constraint] -> [Constraint]
cullRedundant [Constraint]
cs, Bool -> Bool
not ([Constraint] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Constraint]
cs) -> Constraint -> Maybe Constraint
forall a. a -> Maybe a
Just ([Constraint] -> Constraint
ConConj [Constraint]
cs')
  Constraint
_                                                   -> Maybe Constraint
forall a. Maybe a
Nothing
  )

-- | Convert all parametric templates into actual uses, via substitution.
applyTemplates :: Constraints -> UnitSolver Constraints
-- postcondition: returned constraints lack all Parametric constructors
applyTemplates :: [Constraint] -> UnitSolver [Constraint]
applyTemplates [Constraint]
cons = do
  Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"applyTemplates" [Constraint]
cons
  -- Get a list of the instances of parametric polymorphism from the constraints.
  let instances :: [(Name, Int)]
instances = [(Name, Int)] -> [(Name, Int)]
forall a. Eq a => [a] -> [a]
nub [ (Name
name, Int
i) | UnitParamPosUse ((Name
name, Name
_), Int
_, Int
i) <- [Constraint] -> [UnitInfo]
forall from to. Biplate from to => from -> [to]
universeBi [Constraint]
cons ]

  -- Also generate a list of 'dummy' instances to ensure that every
  -- 'toplevel' function and subroutine is thoroughly expanded and
  -- analysed, even if it is not used in the current ProgramFile. (It
  -- might be part of a library module, for instance).
  ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile
  [(Name, Int)]
dummies <- [ProgramUnit UA]
-> (ProgramUnit UA -> StateT UnitState UnitAnalysis (Name, Int))
-> StateT UnitState UnitAnalysis [(Name, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ProgramFile UA -> [ProgramUnit UA]
forall a. ProgramFile a -> [ProgramUnit a]
topLevelFuncsAndSubs ProgramFile UA
pf) ((ProgramUnit UA -> StateT UnitState UnitAnalysis (Name, Int))
 -> StateT UnitState UnitAnalysis [(Name, Int)])
-> (ProgramUnit UA -> StateT UnitState UnitAnalysis (Name, Int))
-> StateT UnitState UnitAnalysis [(Name, Int)]
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit UA
pu -> do
    Int
ident <- UnitSolver Int
freshId
    (Name, Int) -> StateT UnitState UnitAnalysis (Name, Int)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgramUnit UA -> Name
puName ProgramUnit UA
pu, Int
ident)

  ProgramFile UA -> Text -> UnitSolver ()
forall a. Spanned a => a -> Text -> UnitSolver ()
forall e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' ProgramFile UA
pf (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (Text
"instances: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(Name, Int)] -> Text
forall a. Show a => a -> Text
describeShow [(Name, Int)]
instances)
  ProgramFile UA -> Text -> UnitSolver ()
forall a. Spanned a => a -> Text -> UnitSolver ()
forall e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' ProgramFile UA
pf (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (Text
"dummies: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(Name, Int)] -> Text
forall a. Show a => a -> Text
describeShow [(Name, Int)]
dummies)

  VarUnitMap
importedVariables <- UnitSolver VarUnitMap
getImportedVariables

  -- Prepare constraints for all variables imported via StUse.
  let importedCons :: [Constraint]
importedCons = [ UnitInfo -> UnitInfo -> Constraint
ConEq (VV -> UnitInfo
UnitVar VV
vv) UnitInfo
units | (VV
vv, UnitInfo
units) <- VarUnitMap -> [(VV, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList VarUnitMap
importedVariables ]

  -- Work through the instances, expanding their templates, and
  -- substituting the callId into the abstract parameters.
  [Constraint]
concreteCons <- [Constraint] -> [Constraint]
cullRedundant ([Constraint] -> [Constraint])
-> UnitSolver [Constraint] -> UnitSolver [Constraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  ([Constraint] -> [Constraint] -> [Constraint])
-> UnitSolver [Constraint]
-> UnitSolver [Constraint]
-> UnitSolver [Constraint]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
(++) (([Constraint] -> (Name, Int) -> UnitSolver [Constraint])
-> [Constraint] -> [(Name, Int)] -> UnitSolver [Constraint]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> [Name] -> [Constraint] -> (Name, Int) -> UnitSolver [Constraint]
substInstance Bool
False []) [Constraint]
importedCons [(Name, Int)]
instances)
                              (([Constraint] -> (Name, Int) -> UnitSolver [Constraint])
-> [Constraint] -> [(Name, Int)] -> UnitSolver [Constraint]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> [Name] -> [Constraint] -> (Name, Int) -> UnitSolver [Constraint]
substInstance Bool
True []) [] [(Name, Int)]
dummies)
  Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"applyTemplates: concreteCons" [Constraint]
concreteCons

  -- Also include aliases in the final set of constraints, where
  -- aliases are implemented by simply asserting that they are equal
  -- to their definition.
  UnitAliasMap
aliasMap <- UnitSolver UnitAliasMap
getUnitAliasMap
  let aliases :: [Constraint]
aliases = [ UnitInfo -> UnitInfo -> Constraint
ConEq (Name -> UnitInfo
UnitAlias Name
name) UnitInfo
def | (Name
name, UnitInfo
def) <- UnitAliasMap -> [(Name, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList UnitAliasMap
aliasMap ]
  let transAlias :: UnitInfo -> UnitInfo
transAlias (UnitName Name
a) | Name
a Name -> UnitAliasMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` UnitAliasMap
aliasMap = Name -> UnitInfo
UnitAlias Name
a
      transAlias UnitInfo
u                                    = UnitInfo
u

  Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"aliases" [Constraint]
aliases
  [Constraint] -> UnitSolver [Constraint]
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Constraint] -> UnitSolver [Constraint])
-> ([Constraint] -> [Constraint])
-> [Constraint]
-> UnitSolver [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInfo -> UnitInfo) -> [Constraint] -> [Constraint]
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi UnitInfo -> UnitInfo
transAlias ([Constraint] -> [Constraint])
-> ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Constraint] -> [Constraint]
cullRedundant ([Constraint] -> UnitSolver [Constraint])
-> [Constraint] -> UnitSolver [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cons [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
concreteCons [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
aliases

-- | Look up the Parametric templates for a given function or
-- subroutine, and do the substitutions. Process any additional
-- polymorphic calls that are uncovered, unless they are recursive
-- calls that have already been seen in the current call stack.
substInstance :: Bool -> [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints
substInstance :: Bool
-> [Name] -> [Constraint] -> (Name, Int) -> UnitSolver [Constraint]
substInstance Bool
isDummy [Name]
callStack [Constraint]
output (Name
name, Int
callId) = do
  TemplateMap
tmap <- UnitSolver TemplateMap
getTemplateMap

  -- Look up the templates associated with the given function or
  -- subroutine name. And then transform the templates by generating
  -- new callIds for any constraints created by function or subroutine
  -- calls contained within the templates.
  --
  -- The reason for this is because functions called by functions can
  -- be used in a parametric polymorphic way.

  -- npc <- nameParamConstraints name -- In case it is an imported function, use this.
  let npc :: [a]
npc = [] -- disabled for now
  [Constraint]
template <- (UnitInfo -> StateT UnitState UnitAnalysis UnitInfo)
-> [Constraint] -> UnitSolver [Constraint]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM UnitInfo -> StateT UnitState UnitAnalysis UnitInfo
callIdRemap ([Constraint] -> UnitSolver [Constraint])
-> [Constraint] -> UnitSolver [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
forall a. [a]
npc [Constraint] -> Maybe [Constraint] -> [Constraint]
forall a. a -> Maybe a -> a
`fromMaybe` Name -> TemplateMap -> Maybe [Constraint]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name TemplateMap
tmap
  Name -> [Constraint] -> UnitSolver ()
dumpConsM (Name
"substInstance " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Bool -> Name
forall a. Show a => a -> Name
show Bool
isDummy Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [Name] -> Name
forall a. Show a => a -> Name
show [Name]
callStack Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ (Name, Int) -> Name
forall a. Show a => a -> Name
show (Name
name, Int
callId) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" template lookup") [Constraint]
template

  -- Reset the usCallIdRemap field so that it is ready for the next
  -- set of templates.
  (CallIdMap -> CallIdMap) -> UnitSolver ()
modifyCallIdRemap (CallIdMap -> CallIdMap -> CallIdMap
forall a b. a -> b -> a
const CallIdMap
forall a. IntMap a
IM.empty)

  -- If any new instances are discovered, also process them, unless recursive.
  let instances :: [(Name, Int)]
instances = [(Name, Int)] -> [(Name, Int)]
forall a. Eq a => [a] -> [a]
nub [ (Name
name', Int
i) | UnitParamPosUse ((Name
name', Name
_), Int
_, Int
i) <- [Constraint] -> [UnitInfo]
forall from to. Biplate from to => from -> [to]
universeBi [Constraint]
template ]
  [Constraint]
template' <- if Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
callStack then
                 -- Detected recursion: we do not support polymorphic-unit recursion,
                 -- ergo all subsequent recursive calls are assumed to have the same
                 -- unit-assignments as the first call.
                 [Constraint] -> UnitSolver [Constraint]
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
               else
                 ([Constraint] -> (Name, Int) -> UnitSolver [Constraint])
-> [Constraint] -> [(Name, Int)] -> UnitSolver [Constraint]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> [Name] -> [Constraint] -> (Name, Int) -> UnitSolver [Constraint]
substInstance Bool
False (Name
nameName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
callStack)) [] [(Name, Int)]
instances

  Name -> [Constraint] -> UnitSolver ()
dumpConsM (Name
"instantiating " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ (Name, Int) -> Name
forall a. Show a => a -> Name
show (Name
name, Int
callId) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
": (output ++ template) is") ([Constraint]
output [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
template)
  Name -> [Constraint] -> UnitSolver ()
dumpConsM (Name
"instantiating " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ (Name, Int) -> Name
forall a. Show a => a -> Name
show (Name
name, Int
callId) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
": (template') is") [Constraint]
template'

  -- Convert abstract parametric units into concrete ones.

  let output' :: [Constraint]
output' = -- Do not instantiate explicitly annotated polymorphic
                -- variables from current context when looking at dummy (name, callId)
                (if Bool
isDummy then [Constraint]
output [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
template
                            else Int -> [Constraint] -> [Constraint]
forall a. Data a => Int -> a -> a
instantiate Int
callId ([Constraint]
output [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
template)) [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++

                -- Only instantiate explicitly annotated polymorphic
                -- variables from nested function/subroutine calls.
                Int -> [Constraint] -> [Constraint]
forall a. Data a => Int -> a -> a
instantiate Int
callId [Constraint]
template'

  Name -> [Constraint] -> UnitSolver ()
dumpConsM (Name
"final output for " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ (Name, Int) -> Name
forall a. Show a => a -> Name
show (Name
name, Int
callId)) [Constraint]
output'

  [Constraint] -> UnitSolver [Constraint]
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Constraint]
output'

-- -- | Generate constraints from a NameParamMap entry.
-- nameParamConstraints :: F.Name -> UnitSolver Constraints
-- nameParamConstraints fname = do
--   let filterForName (NPKParam (n, _) _) _ = n == fname
--       filterForName _ _                   = False
--   nlst <- (M.toList . M.filterWithKey filterForName) <$> getNameParamMap
--   pure [ ConEq (UnitParamPosAbs (n, pos)) (foldUnits units) | (NPKParam n pos, units) <- nlst ]

-- | If given a usage of a parametric unit, rewrite the callId field
-- to follow an existing mapping in the usCallIdRemap state field, or
-- generate a new callId and add it to the usCallIdRemap state field.
callIdRemap :: UnitInfo -> UnitSolver UnitInfo
callIdRemap :: UnitInfo -> StateT UnitState UnitAnalysis UnitInfo
callIdRemap UnitInfo
info = (CallIdMap -> UnitSolver (UnitInfo, CallIdMap))
-> StateT UnitState UnitAnalysis UnitInfo
forall a. (CallIdMap -> UnitSolver (a, CallIdMap)) -> UnitSolver a
modifyCallIdRemapM ((CallIdMap -> UnitSolver (UnitInfo, CallIdMap))
 -> StateT UnitState UnitAnalysis UnitInfo)
-> (CallIdMap -> UnitSolver (UnitInfo, CallIdMap))
-> StateT UnitState UnitAnalysis UnitInfo
forall a b. (a -> b) -> a -> b
$ \ CallIdMap
idMap -> case UnitInfo
info of
    UnitParamPosUse (VV
n, Int
p, Int
i)
      | Just Int
i' <- Int -> CallIdMap -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i CallIdMap
idMap -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
n, Int
p, Int
i'), CallIdMap
idMap)
      | Bool
otherwise                    -> UnitSolver Int
freshId UnitSolver Int
-> (Int -> UnitSolver (UnitInfo, CallIdMap))
-> UnitSolver (UnitInfo, CallIdMap)
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
                                          (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
n, Int
p, Int
i'), Int -> Int -> CallIdMap -> CallIdMap
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
i' CallIdMap
idMap)
    UnitParamVarUse (VV
n, VV
v, Int
i)
      | Just Int
i' <- Int -> CallIdMap -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i CallIdMap
idMap -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, VV, Int) -> UnitInfo
UnitParamVarUse (VV
n, VV
v, Int
i'), CallIdMap
idMap)
      | Bool
otherwise                    -> UnitSolver Int
freshId UnitSolver Int
-> (Int -> UnitSolver (UnitInfo, CallIdMap))
-> UnitSolver (UnitInfo, CallIdMap)
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
                                          (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, VV, Int) -> UnitInfo
UnitParamVarUse (VV
n, VV
v, Int
i'), Int -> Int -> CallIdMap -> CallIdMap
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
i' CallIdMap
idMap)
    UnitParamLitUse (Int
l, Int
i)
      | Just Int
i' <- Int -> CallIdMap -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i CallIdMap
idMap -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Int) -> UnitInfo
UnitParamLitUse (Int
l, Int
i'), CallIdMap
idMap)
      | Bool
otherwise                    -> UnitSolver Int
freshId UnitSolver Int
-> (Int -> UnitSolver (UnitInfo, CallIdMap))
-> UnitSolver (UnitInfo, CallIdMap)
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
                                          (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Int) -> UnitInfo
UnitParamLitUse (Int
l, Int
i'), Int -> Int -> CallIdMap -> CallIdMap
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
i' CallIdMap
idMap)
    UnitParamEAPUse (VV
v, Int
i)
      | Just Int
i' <- Int -> CallIdMap -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i CallIdMap
idMap -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, Int) -> UnitInfo
UnitParamEAPUse (VV
v, Int
i'), CallIdMap
idMap)
      | Bool
otherwise                    -> UnitSolver Int
freshId UnitSolver Int
-> (Int -> UnitSolver (UnitInfo, CallIdMap))
-> UnitSolver (UnitInfo, CallIdMap)
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
                                          (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, Int) -> UnitInfo
UnitParamEAPUse (VV
v, Int
i'), Int -> Int -> CallIdMap -> CallIdMap
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
i' CallIdMap
idMap)

    UnitInfo
_                                -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnitInfo
info, CallIdMap
idMap)


-- | Convert a parametric template into a particular use.
instantiate :: Data a => Int -> a -> a
instantiate :: forall a. Data a => Int -> a -> a
instantiate Int
callId = (UnitInfo -> UnitInfo) -> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ((UnitInfo -> UnitInfo) -> a -> a)
-> (UnitInfo -> UnitInfo) -> a -> a
forall a b. (a -> b) -> a -> b
$ \ UnitInfo
info -> case UnitInfo
info of
  UnitParamPosAbs (VV
name, Int
position) -> (VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
name, Int
position, Int
callId)
  UnitParamLitAbs Int
litId            -> (Int, Int) -> UnitInfo
UnitParamLitUse (Int
litId, Int
callId)
  UnitParamVarAbs (VV
fname, VV
vname)   -> (VV, VV, Int) -> UnitInfo
UnitParamVarUse (VV
fname, VV
vname, Int
callId)
  UnitParamEAPAbs VV
vname            -> (VV, Int) -> UnitInfo
UnitParamEAPUse (VV
vname, Int
callId)
  UnitInfo
_                                -> UnitInfo
info

-- | Return a list of ProgramUnits that might be considered 'toplevel'
-- in the ProgramFile, e.g., possible exports. These must be analysed
-- independently of whether they are actually used in the same file,
-- because other files might use them.
topLevelFuncsAndSubs :: F.ProgramFile a -> [F.ProgramUnit a]
topLevelFuncsAndSubs :: forall a. ProgramFile a -> [ProgramUnit a]
topLevelFuncsAndSubs (F.ProgramFile MetaInfo
_ [ProgramUnit a]
pus) = ProgramUnit a -> [ProgramUnit a]
forall {a}. ProgramUnit a -> [ProgramUnit a]
topLevel (ProgramUnit a -> [ProgramUnit a])
-> [ProgramUnit a] -> [ProgramUnit a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ProgramUnit a]
pus
  where
    topLevel :: ProgramUnit a -> [ProgramUnit a]
topLevel (F.PUModule a
_ SrcSpan
_ Name
_ [Block a]
_ (Just [ProgramUnit a]
contains)) = ProgramUnit a -> [ProgramUnit a]
topLevel (ProgramUnit a -> [ProgramUnit a])
-> [ProgramUnit a] -> [ProgramUnit a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ProgramUnit a]
contains
    topLevel (F.PUMain a
_ SrcSpan
_ Maybe Name
_ [Block a]
_ (Just [ProgramUnit a]
contains))   = ProgramUnit a -> [ProgramUnit a]
topLevel (ProgramUnit a -> [ProgramUnit a])
-> [ProgramUnit a] -> [ProgramUnit a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ProgramUnit a]
contains
    topLevel f :: ProgramUnit a
f@F.PUFunction{}                  = ProgramUnit a -> [ProgramUnit a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramUnit a
f
    topLevel s :: ProgramUnit a
s@F.PUSubroutine{}                = ProgramUnit a -> [ProgramUnit a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramUnit a
s
    topLevel ProgramUnit a
_                                    = []

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

-- | Gather all constraints from the main blocks of the AST, as well as from the varUnitMap
extractConstraints :: UnitSolver Constraints
extractConstraints :: UnitSolver [Constraint]
extractConstraints = do
  ProgramFile UA
pf         <- UnitSolver (ProgramFile UA)
getProgramFile
  Map Name (DeclContext, SrcSpan)
dmap       <- UnitAnalysis (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
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 (Map Name (DeclContext, SrcSpan))
 -> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> (AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
    -> UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> UnitAnalysis (Map Name (DeclContext, SrcSpan))
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 (Map Name (DeclContext, SrcSpan))
 -> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall a b. (a -> b) -> a -> b
$ Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (ProgramFile UA -> Map Name (DeclContext, SrcSpan)
forall a.
Data a =>
ProgramFile (Analysis a) -> Map Name (DeclContext, SrcSpan)
extractDeclMap ProgramFile UA
pf) (Map Name (DeclContext, SrcSpan)
 -> Map Name (DeclContext, SrcSpan))
-> (ModFiles -> Map Name (DeclContext, SrcSpan))
-> ModFiles
-> Map Name (DeclContext, SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModFiles -> Map Name (DeclContext, SrcSpan)
combinedDeclMap (ModFiles -> Map Name (DeclContext, SrcSpan))
-> AnalysisT () () IO ModFiles
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnalysisT () () IO ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
  VarUnitMap
varUnitMap <- UnitSolver VarUnitMap
getVarUnitMap
  [Constraint] -> UnitSolver [Constraint]
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Constraint] -> UnitSolver [Constraint])
-> [Constraint] -> UnitSolver [Constraint]
forall a b. (a -> b) -> a -> b
$ [ Constraint
con | Block UA
b <- ProgramFile UA -> [Block UA]
mainBlocks ProgramFile UA
pf, con :: Constraint
con@ConEq{} <- Block UA -> [Constraint]
forall from to. Biplate from to => from -> [to]
universeBi Block UA
b ] [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++
           [ UnitInfo -> UnitInfo -> Constraint
ConEq (Map Name (DeclContext, SrcSpan) -> VV -> UnitInfo
toUnitVar Map Name (DeclContext, SrcSpan)
dmap VV
v) UnitInfo
u | (VV
v, UnitInfo
u) <- VarUnitMap -> [(VV, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList VarUnitMap
varUnitMap ]

-- | A list of blocks considered to be part of the 'main' program.
mainBlocks :: F.ProgramFile UA -> [F.Block UA]
mainBlocks :: ProgramFile UA -> [Block UA]
mainBlocks = (ProgramUnit UA -> [Block UA]) -> [ProgramUnit UA] -> [Block UA]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ProgramUnit UA -> [Block UA]
forall a. ProgramUnit a -> [Block a]
getBlocks ([ProgramUnit UA] -> [Block UA])
-> (ProgramFile UA -> [ProgramUnit UA])
-> ProgramFile UA
-> [Block UA]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi
  where
    getBlocks :: ProgramUnit a -> [Block a]
getBlocks (F.PUMain a
_ SrcSpan
_ Maybe Name
_ [Block a]
bs Maybe [ProgramUnit a]
_)   = [Block a]
bs
    getBlocks (F.PUModule a
_ SrcSpan
_ Name
_ [Block a]
bs Maybe [ProgramUnit a]
_) = [Block a]
bs
    getBlocks ProgramUnit a
_                       = []

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

-- | Propagate* functions: decorate the AST with constraints, given
-- that variables have all been annotated.
propagateUnits :: UnitSolver ()
-- precondition: all variables have already been annotated
propagateUnits :: UnitSolver ()
propagateUnits = (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
modifyProgramFileM ((ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ())
-> (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (Block UA -> StateT UnitState UnitAnalysis (Block UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Block UA -> StateT UnitState UnitAnalysis (Block UA)
propagateInterface (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA
-> UnitSolver (ProgramFile UA)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
                                      (ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
propagatePU        (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA
-> UnitSolver (ProgramFile UA)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
                                      (DoSpecification UA
 -> StateT UnitState UnitAnalysis (DoSpecification UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM DoSpecification UA
-> StateT UnitState UnitAnalysis (DoSpecification UA)
propagateDoSpec    (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA
-> UnitSolver (ProgramFile UA)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
                                      (Statement UA -> StateT UnitState UnitAnalysis (Statement UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
propagateStatement (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA
-> UnitSolver (ProgramFile UA)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
                                      (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
propagateExp

propagateExp :: F.Expression UA -> UnitSolver (F.Expression UA)
propagateExp :: Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
propagateExp Expression UA
e = case Expression UA
e of
  F.ExpValue{}                           -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e -- all values should already be annotated
  F.ExpBinary UA
_ SrcSpan
_ BinaryOp
F.Multiplication Expression UA
e1 Expression UA
e2 -> (UnitInfo -> UnitInfo -> UnitInfo)
-> Maybe UnitInfo
-> Maybe UnitInfo
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {a} {b}.
Applicative f =>
(a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f (Expression UA)
setF2 UnitInfo -> UnitInfo -> UnitInfo
UnitMul (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)
  F.ExpBinary UA
_ SrcSpan
_ BinaryOp
F.Division Expression UA
e1 Expression UA
e2       -> (UnitInfo -> UnitInfo -> UnitInfo)
-> Maybe UnitInfo
-> Maybe UnitInfo
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {a} {b}.
Applicative f =>
(a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f (Expression UA)
setF2 UnitInfo -> UnitInfo -> UnitInfo
UnitMul (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) ((UnitInfo -> Double -> UnitInfo) -> Double -> UnitInfo -> UnitInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitInfo -> Double -> UnitInfo
UnitPow (-Double
1) (UnitInfo -> UnitInfo) -> Maybe UnitInfo -> Maybe UnitInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)
  F.ExpBinary UA
_ SrcSpan
_ BinaryOp
F.Exponentiation Expression UA
e1 Expression UA
e2 -> (UnitInfo -> Double -> UnitInfo)
-> Maybe UnitInfo
-> Maybe Double
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {a} {b}.
Applicative f =>
(a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f (Expression UA)
setF2 UnitInfo -> Double -> UnitInfo
UnitPow (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe Double
forall a. Expression a -> Maybe Double
constantExpression Expression UA
e2)
  F.ExpBinary UA
_ SrcSpan
_ BinaryOp
o Expression UA
e1 Expression UA
e2 | BinOpKind -> BinaryOp -> Bool
isOp BinOpKind
AddOp BinaryOp
o -> (UnitInfo -> UnitInfo -> Constraint)
-> Maybe UnitInfo
-> Maybe UnitInfo
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {b}.
Applicative f =>
(UnitInfo -> b -> Constraint)
-> Maybe UnitInfo -> Maybe b -> f (Expression UA)
setF2C UnitInfo -> UnitInfo -> Constraint
ConEq  (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)
                          | BinOpKind -> BinaryOp -> Bool
isOp BinOpKind
RelOp BinaryOp
o -> (UnitInfo -> UnitInfo -> Constraint)
-> Maybe UnitInfo
-> Maybe UnitInfo
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {b}.
Applicative f =>
(UnitInfo -> b -> Constraint)
-> Maybe UnitInfo -> Maybe b -> f (Expression UA)
setF2C UnitInfo -> UnitInfo -> Constraint
ConEq  (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)
  F.ExpFunctionCall {}                   -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
propagateFunctionCall Expression UA
e
  F.ExpSubscript UA
_ SrcSpan
_ Expression UA
e1 AList Index UA
_                -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ Maybe UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => Maybe UnitInfo -> f UA -> f UA
UA.maybeSetUnitInfo (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) Expression UA
e
  F.ExpUnary UA
_ SrcSpan
_ UnaryOp
_ Expression UA
e1                    -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ Maybe UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => Maybe UnitInfo -> f UA -> f UA
UA.maybeSetUnitInfo (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) Expression UA
e
  F.ExpInitialisation{}                  -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
  Expression UA
_                                      -> do
    Expression UA -> Text -> UnitSolver ()
forall a. Spanned a => a -> Text -> UnitSolver ()
forall e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' Expression UA
e (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Text
"progagateExp: unhandled " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expression UA -> Text
forall a. Show a => a -> Text
describeShow Expression UA
e
    Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
  where
    -- Shorter names for convenience functions.
    setF2 :: (a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f (Expression UA)
setF2 a -> b -> UnitInfo
f Maybe a
u1 Maybe b
u2  = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> f (Expression UA))
-> Expression UA -> f (Expression UA)
forall a b. (a -> b) -> a -> b
$ (a -> b -> UnitInfo)
-> Maybe a -> Maybe b -> Expression UA -> Expression UA
forall (f :: * -> *) a b.
Annotated f =>
(a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f UA -> f UA
UA.maybeSetUnitInfoF2 a -> b -> UnitInfo
f Maybe a
u1 Maybe b
u2 Expression UA
e
    -- Remember, not only set a constraint, but also give a unit!
    setF2C :: (UnitInfo -> b -> Constraint)
-> Maybe UnitInfo -> Maybe b -> f (Expression UA)
setF2C UnitInfo -> b -> Constraint
f Maybe UnitInfo
u1 Maybe b
u2 = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> f (Expression UA))
-> (Expression UA -> Expression UA)
-> Expression UA
-> f (Expression UA)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => Maybe UnitInfo -> f UA -> f UA
UA.maybeSetUnitInfo Maybe UnitInfo
u1 (Expression UA -> f (Expression UA))
-> Expression UA -> f (Expression UA)
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> b -> Constraint)
-> Maybe UnitInfo -> Maybe b -> Expression UA -> Expression UA
forall (f :: * -> *) a b.
Annotated f =>
(a -> b -> Constraint) -> Maybe a -> Maybe b -> f UA -> f UA
UA.maybeSetUnitConstraintF2 UnitInfo -> b -> Constraint
f Maybe UnitInfo
u1 Maybe b
u2 Expression UA
e

propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA)
propagateFunctionCall :: Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
propagateFunctionCall (F.ExpFunctionCall UA
a SrcSpan
s Expression UA
f (F.AList UA
a' SrcSpan
s' [Argument UA]
args)) = do
  (UnitInfo
info, [Argument UA]
args') <- Expression UA
-> [Argument UA] -> UnitSolver (UnitInfo, [Argument UA])
callHelper Expression UA
f [Argument UA]
args
  let cons :: [Constraint]
cons = UnitInfo -> Expression UA -> [Argument UA] -> [Constraint]
forall (t :: * -> *) a b.
Foldable t =>
UnitInfo -> Expression (Analysis a) -> t b -> [Constraint]
intrinsicHelper UnitInfo
info Expression UA
f [Argument UA]
args'
  Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> (Expression UA -> Expression UA)
-> Expression UA
-> StateT UnitState UnitAnalysis (Expression UA)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint ([Constraint] -> Constraint
ConConj [Constraint]
cons) (Expression UA -> Expression UA)
-> (Expression UA -> Expression UA)
-> Expression UA
-> Expression UA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
info (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ UA
-> SrcSpan -> Expression UA -> AList Argument UA -> Expression UA
forall a.
a -> SrcSpan -> Expression a -> AList Argument a -> Expression a
F.ExpFunctionCall UA
a SrcSpan
s Expression UA
f (UA -> SrcSpan -> [Argument UA] -> AList Argument UA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList UA
a' SrcSpan
s' [Argument UA]
args')
propagateFunctionCall Expression UA
_ = Name -> StateT UnitState UnitAnalysis (Expression UA)
forall a. HasCallStack => Name -> a
error Name
"received non-function-call in propagateFunctionCall"

propagateDoSpec :: F.DoSpecification UA -> UnitSolver (F.DoSpecification UA)
propagateDoSpec :: DoSpecification UA
-> StateT UnitState UnitAnalysis (DoSpecification UA)
propagateDoSpec ast :: DoSpecification UA
ast@(F.DoSpecification UA
_ SrcSpan
_ (F.StExpressionAssign UA
_ SrcSpan
_ Expression UA
e1 Expression UA
_) Expression UA
e2 Maybe (Expression UA)
m_e3) = do
  -- express constraints between the iteration variable, the bounding
  -- expressions and the step expression, or treat the step expression
  -- as a literal 1 if not specified.
  DoSpecification UA
-> StateT UnitState UnitAnalysis (DoSpecification UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DoSpecification UA
 -> StateT UnitState UnitAnalysis (DoSpecification UA))
-> (Maybe Constraint -> DoSpecification UA)
-> Maybe Constraint
-> StateT UnitState UnitAnalysis (DoSpecification UA)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DoSpecification UA
-> (Constraint -> DoSpecification UA)
-> Maybe Constraint
-> DoSpecification UA
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DoSpecification UA
ast ((Constraint -> DoSpecification UA -> DoSpecification UA)
-> DoSpecification UA -> Constraint -> DoSpecification UA
forall a b c. (a -> b -> c) -> b -> a -> c
flip Constraint -> DoSpecification UA -> DoSpecification UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint DoSpecification UA
ast) (Maybe Constraint
 -> StateT UnitState UnitAnalysis (DoSpecification UA))
-> Maybe Constraint
-> StateT UnitState UnitAnalysis (DoSpecification UA)
forall a b. (a -> b) -> a -> b
$ [Constraint] -> Constraint
ConConj ([Constraint] -> Constraint)
-> Maybe [Constraint] -> Maybe Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe [Constraint]] -> Maybe [Constraint]
forall a. Monoid a => [a] -> a
mconcat [
        -- units(e1) ~ units(e2)
        (Constraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[]) (Constraint -> [Constraint])
-> Maybe Constraint -> Maybe [Constraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnitInfo -> UnitInfo -> Constraint)
-> Maybe UnitInfo -> Maybe UnitInfo -> Maybe Constraint
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 UnitInfo -> UnitInfo -> Constraint
ConEq (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)

        -- units(e1) ~ units(e3) or if e3 not specified then units(e1) ~ 1 in a polymorphic context
        , do UnitInfo
u1 <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1
             UnitInfo
u3 <- (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo (Expression UA -> Maybe UnitInfo)
-> Maybe (Expression UA) -> Maybe UnitInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Expression UA)
m_e3) Maybe UnitInfo -> Maybe UnitInfo -> Maybe UnitInfo
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` if UnitInfo -> Bool
isMonomorphic UnitInfo
u1 then Maybe UnitInfo
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero else UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnitInfo
UnitlessVar
             [Constraint] -> Maybe [Constraint]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u1 UnitInfo
u3]

        -- units(e2) ~ units(e3) or if e3 not specified then units(e2) ~ 1 in a polymorphic context
        , do UnitInfo
u2 <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1
             UnitInfo
u3 <- (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo (Expression UA -> Maybe UnitInfo)
-> Maybe (Expression UA) -> Maybe UnitInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Expression UA)
m_e3) Maybe UnitInfo -> Maybe UnitInfo -> Maybe UnitInfo
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` if UnitInfo -> Bool
isMonomorphic UnitInfo
u2 then Maybe UnitInfo
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero else UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnitInfo
UnitlessVar
             [Constraint] -> Maybe [Constraint]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u2 UnitInfo
u3]
        ]
propagateDoSpec DoSpecification UA
_ = Name -> StateT UnitState UnitAnalysis (DoSpecification UA)
forall a. HasCallStack => Name -> a
error Name
"propagateDoSpec: called on invalid DoSpec"

propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA)
propagateStatement :: Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
propagateStatement Statement UA
stmt = case Statement UA
stmt of
  F.StExpressionAssign UA
_ SrcSpan
_ Expression UA
e1 Expression UA
e2               -> Expression UA
-> Expression UA
-> Statement UA
-> StateT UnitState UnitAnalysis (Statement UA)
forall (f :: * -> *).
Annotated f =>
Expression UA -> Expression UA -> f UA -> UnitSolver (f UA)
literalAssignmentSpecialCase Expression UA
e1 Expression UA
e2 Statement UA
stmt
  F.StCall UA
a SrcSpan
s Expression UA
sub (F.AList UA
a' SrcSpan
s' [Argument UA]
args) -> do
    (UnitInfo
info, [Argument UA]
args') <- Expression UA
-> [Argument UA] -> UnitSolver (UnitInfo, [Argument UA])
callHelper Expression UA
sub [Argument UA]
args
    let cons :: [Constraint]
cons = UnitInfo -> Expression UA -> [Argument UA] -> [Constraint]
forall (t :: * -> *) a b.
Foldable t =>
UnitInfo -> Expression (Analysis a) -> t b -> [Constraint]
intrinsicHelper UnitInfo
info Expression UA
sub [Argument UA]
args'
    Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement UA -> StateT UnitState UnitAnalysis (Statement UA))
-> (Statement UA -> Statement UA)
-> Statement UA
-> StateT UnitState UnitAnalysis (Statement UA)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint -> Statement UA -> Statement UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint ([Constraint] -> Constraint
ConConj [Constraint]
cons) (Statement UA -> StateT UnitState UnitAnalysis (Statement UA))
-> Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
forall a b. (a -> b) -> a -> b
$ UA -> SrcSpan -> Expression UA -> AList Argument UA -> Statement UA
forall a.
a -> SrcSpan -> Expression a -> AList Argument a -> Statement a
F.StCall UA
a SrcSpan
s Expression UA
sub (UA -> SrcSpan -> [Argument UA] -> AList Argument UA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList UA
a' SrcSpan
s' [Argument UA]
args')
  F.StDeclaration {}                           -> (Declarator UA -> StateT UnitState UnitAnalysis (Declarator UA))
-> Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Declarator UA -> StateT UnitState UnitAnalysis (Declarator UA)
propagateDeclarator Statement UA
stmt
  Statement UA
_                                            -> Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Statement UA
stmt

propagateDeclarator :: F.Declarator UA -> UnitSolver (F.Declarator UA)
propagateDeclarator :: Declarator UA -> StateT UnitState UnitAnalysis (Declarator UA)
propagateDeclarator Declarator UA
decl = case Declarator UA
decl of
  F.Declarator UA
_ SrcSpan
_ Expression UA
e1 DeclaratorType UA
_ Maybe (Expression UA)
_ (Just Expression UA
e2) -> Expression UA
-> Expression UA
-> Declarator UA
-> StateT UnitState UnitAnalysis (Declarator UA)
forall (f :: * -> *).
Annotated f =>
Expression UA -> Expression UA -> f UA -> UnitSolver (f UA)
literalAssignmentSpecialCase Expression UA
e1 Expression UA
e2 Declarator UA
decl
  Declarator UA
_                                 -> Declarator UA -> StateT UnitState UnitAnalysis (Declarator UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Declarator UA
decl

-- Allow literal assignment to overload the non-polymorphic
-- unit-assignment of the non-zero literal.
literalAssignmentSpecialCase :: (F.Annotated f)
                             => F.Expression UA -> F.Expression UA
                             -> f UA -> UnitSolver (f UA)
literalAssignmentSpecialCase :: forall (f :: * -> *).
Annotated f =>
Expression UA -> Expression UA -> f UA -> UnitSolver (f UA)
literalAssignmentSpecialCase Expression UA
e1 Expression UA
e2 f UA
ast
  | Expression UA -> Bool
isLiteralZero Expression UA
e2 = f UA -> StateT UnitState UnitAnalysis (f UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f UA
ast
  | Expression UA -> Bool
isLiteral Expression UA
e2
  , Just UnitInfo
u1            <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1
  , Just UnitLiteral{} <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2
  , UnitInfo -> Bool
isMonomorphic UnitInfo
u1 = f UA -> StateT UnitState UnitAnalysis (f UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f UA
ast
  -- otherwise express the constraint between LHS and RHS of assignment.
  | Bool
otherwise = f UA -> StateT UnitState UnitAnalysis (f UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f UA -> StateT UnitState UnitAnalysis (f UA))
-> f UA -> StateT UnitState UnitAnalysis (f UA)
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> Constraint)
-> Maybe UnitInfo -> Maybe UnitInfo -> f UA -> f UA
forall (f :: * -> *) a b.
Annotated f =>
(a -> b -> Constraint) -> Maybe a -> Maybe b -> f UA -> f UA
UA.maybeSetUnitConstraintF2 UnitInfo -> UnitInfo -> Constraint
ConEq (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2) f UA
ast

-- Generic Interface template mapping will be same as first module procedure.
propagateInterface :: F.Block UA -> UnitSolver (F.Block UA)
propagateInterface :: Block UA -> StateT UnitState UnitAnalysis (Block UA)
propagateInterface b :: Block UA
b@(F.BlInterface UA
_ SrcSpan
_ (Just Expression UA
e) Bool
_ [ProgramUnit UA]
_ [Block UA]
bs) = do
  let iname :: Name
iname = Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
e
  case [ Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
e1 | F.StModuleProcedure UA
_ SrcSpan
_ (F.AList UA
_ SrcSpan
_ (Expression UA
e1:[Expression UA]
_)) <- [Block UA] -> [Statement UA]
forall from to. Biplate from to => from -> [to]
universeBi [Block UA]
bs :: [F.Statement UA] ] of
    Name
mpname:[Name]
_ -> do
      -- translate any instance of mpname into iname within the template
      let trans :: [Constraint] -> [Constraint]
trans = (Name -> Name) -> [Constraint] -> [Constraint]
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (\ Name
x -> if Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
mpname then Name
iname else Name
x)
      -- copy (translated) template from first module procedure to interface
      (TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap ((TemplateMap -> TemplateMap) -> UnitSolver ())
-> (TemplateMap -> TemplateMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ TemplateMap
m -> TemplateMap -> Maybe TemplateMap -> TemplateMap
forall a. a -> Maybe a -> a
fromMaybe TemplateMap
m ((\ [Constraint]
t -> Name -> [Constraint] -> TemplateMap -> TemplateMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
iname ([Constraint] -> [Constraint]
trans [Constraint]
t) TemplateMap
m) ([Constraint] -> TemplateMap)
-> Maybe [Constraint] -> Maybe TemplateMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TemplateMap -> Maybe [Constraint]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
mpname TemplateMap
m)
    [Name]
_        ->
      () -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Block UA -> StateT UnitState UnitAnalysis (Block UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block UA
b

propagateInterface Block UA
b = Block UA -> StateT UnitState UnitAnalysis (Block UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block UA
b

propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)
propagatePU :: ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
propagatePU ProgramUnit UA
pu = do
  let name :: Name
name     = ProgramUnit UA -> Name
puName ProgramUnit UA
pu
  let sname :: Name
sname    = ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu
  let nn :: VV
nn       = (Name
name, Name
sname)
  let bodyCons :: [Constraint]
bodyCons = [ Constraint
con | con :: Constraint
con@ConEq{} <- ProgramUnit UA -> [Constraint]
forall from to. Biplate from to => from -> [to]
universeBi ProgramUnit UA
pu ] -- Constraints within the PU.

  VarUnitMap
varMap <- UnitSolver VarUnitMap
getVarUnitMap

  -- If any of the function/subroutine parameters was given an
  -- explicit unit annotation, then create a constraint between that
  -- explicit unit and the UnitParamPosAbs corresponding to the
  -- parameter. This way all other uses of the parameter get linked to
  -- the explicit unit annotation as well.
  [Constraint]
givenCons <- [(Int, VV)]
-> ((Int, VV) -> StateT UnitState UnitAnalysis Constraint)
-> UnitSolver [Constraint]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ProgramUnit UA -> [(Int, VV)]
indexedParams ProgramUnit UA
pu) (((Int, VV) -> StateT UnitState UnitAnalysis Constraint)
 -> UnitSolver [Constraint])
-> ((Int, VV) -> StateT UnitState UnitAnalysis Constraint)
-> UnitSolver [Constraint]
forall a b. (a -> b) -> a -> b
$ \ (Int
i, VV
param) ->
    case VV -> VarUnitMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VV
param VarUnitMap
varMap of
      Just UnitParamPosAbs{}    -> Constraint -> StateT UnitState UnitAnalysis Constraint
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint -> StateT UnitState UnitAnalysis Constraint)
-> (UnitInfo -> Constraint)
-> UnitInfo
-> StateT UnitState UnitAnalysis Constraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitInfo -> Constraint
ConEq ((VV, VV) -> UnitInfo
UnitParamVarAbs (VV
nn, VV
param)) (UnitInfo -> StateT UnitState UnitAnalysis Constraint)
-> UnitInfo -> StateT UnitState UnitAnalysis Constraint
forall a b. (a -> b) -> a -> b
$ (VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
i)
      Just UnitInfo
u                    -> Constraint -> StateT UnitState UnitAnalysis Constraint
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint -> StateT UnitState UnitAnalysis Constraint)
-> (UnitInfo -> Constraint)
-> UnitInfo
-> StateT UnitState UnitAnalysis Constraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u (UnitInfo -> StateT UnitState UnitAnalysis Constraint)
-> UnitInfo -> StateT UnitState UnitAnalysis Constraint
forall a b. (a -> b) -> a -> b
$ (VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
i)
      Maybe UnitInfo
_                         -> Constraint -> StateT UnitState UnitAnalysis Constraint
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint -> StateT UnitState UnitAnalysis Constraint)
-> (UnitInfo -> Constraint)
-> UnitInfo
-> StateT UnitState UnitAnalysis Constraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitInfo -> Constraint
ConEq ((VV, VV) -> UnitInfo
UnitParamVarAbs (VV
nn, VV
param)) (UnitInfo -> StateT UnitState UnitAnalysis Constraint)
-> UnitInfo -> StateT UnitState UnitAnalysis Constraint
forall a b. (a -> b) -> a -> b
$ (VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
i)

  let cons :: [Constraint]
cons = [Constraint]
givenCons [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
bodyCons
  case ProgramUnit UA
pu of F.PUFunction {}   -> (TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap (Name -> [Constraint] -> TemplateMap -> TemplateMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name [Constraint]
cons)
             F.PUSubroutine {} -> (TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap (Name -> [Constraint] -> TemplateMap -> TemplateMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name [Constraint]
cons)
             ProgramUnit UA
_                 -> () -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- Set the unitInfo field of a function program unit to be the same
  -- as the unitInfo of its result.
  let pu' :: ProgramUnit UA
pu' = case (ProgramUnit UA
pu, ProgramUnit UA -> [(Int, VV)]
indexedParams ProgramUnit UA
pu) of
              (F.PUFunction {}, (Int
0, VV
res):[(Int, VV)]
_) -> UnitInfo -> ProgramUnit UA -> ProgramUnit UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo ((VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
0) UnitInfo -> Maybe UnitInfo -> UnitInfo
forall a. a -> Maybe a -> a
`fromMaybe` VV -> VarUnitMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VV
res VarUnitMap
varMap) ProgramUnit UA
pu
              (ProgramUnit UA, [(Int, VV)])
_                             -> ProgramUnit UA
pu

  ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint -> ProgramUnit UA -> ProgramUnit UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint ([Constraint] -> Constraint
ConConj [Constraint]
cons) ProgramUnit UA
pu')

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

-- | Coalesce various function and subroutine call common code.
callHelper :: F.Expression UA -> [F.Argument UA] -> UnitSolver (UnitInfo, [F.Argument UA])
callHelper :: Expression UA
-> [Argument UA] -> UnitSolver (UnitInfo, [Argument UA])
callHelper Expression UA
nexp [Argument UA]
args = do
  let name :: VV
name = (Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
nexp, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
nexp)
  let ctyp :: Maybe ConstructType
ctyp = IDType -> Maybe ConstructType
FA.idCType (IDType -> Maybe ConstructType)
-> Maybe IDType -> Maybe ConstructType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UA -> Maybe IDType
forall a. Analysis a -> Maybe IDType
FA.idType (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
nexp)
  Int
callId <- case Maybe ConstructType
ctyp of
    Just ConstructType
FA.CTExternal -> Int -> UnitSolver Int
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0  -- if external with no further info then no polymorphism
    Maybe ConstructType
_                  -> UnitSolver Int
freshId -- every call-site gets its own unique identifier
  let eachArg :: Int -> Argument UA -> Argument UA
eachArg Int
i arg :: Argument UA
arg@(F.Argument UA
_ SrcSpan
_ Maybe Name
_ ArgumentExpression UA
e)
        -- add site-specific parametric constraints to each argument
        | Just UnitInfo
u <- ArgumentExpression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo ArgumentExpression UA
e = Constraint -> Argument UA -> Argument UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint (UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u ((VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
name, Int
i, Int
callId))) Argument UA
arg
        | Bool
otherwise               = Argument UA
arg
  let args' :: [Argument UA]
args' = (Int -> Argument UA -> Argument UA)
-> [Int] -> [Argument UA] -> [Argument UA]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Argument UA -> Argument UA
eachArg [Int
1..] [Argument UA]
args
  -- build a site-specific parametric unit for use on a return variable, if any
  let info :: UnitInfo
info = (VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
name, Int
0, Int
callId)
  (UnitInfo, [Argument UA]) -> UnitSolver (UnitInfo, [Argument UA])
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnitInfo
info, [Argument UA]
args')

-- FIXME: use this function to create a list of constraints on intrinsic call-sites...
intrinsicHelper :: Foldable t => UnitInfo -> F.Expression (FA.Analysis a) -> t b -> [Constraint]
intrinsicHelper :: forall (t :: * -> *) a b.
Foldable t =>
UnitInfo -> Expression (Analysis a) -> t b -> [Constraint]
intrinsicHelper (UnitParamPosUse (VV
_, Int
_, Int
callId)) f :: Expression (Analysis a)
f@(F.ExpValue Analysis a
_ SrcSpan
_ (F.ValIntrinsic Name
_)) t b
args
  | Just (UnitInfo
retU, [UnitInfo]
argUs) <- Name -> Maybe (UnitInfo, [UnitInfo])
intrinsicLookup Name
sname = (Int -> UnitInfo -> Constraint)
-> [Int] -> [UnitInfo] -> [Constraint]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> UnitInfo -> Constraint
eachArg [Int
0..Int
numArgs] (UnitInfo
retUUnitInfo -> [UnitInfo] -> [UnitInfo]
forall a. a -> [a] -> [a]
:[UnitInfo]
argUs)
  where
    numArgs :: Int
numArgs     = t b -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t b
args
    sname :: Name
sname       = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
f
    vname :: Name
vname       = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
f
    eachArg :: Int -> UnitInfo -> Constraint
eachArg Int
i UnitInfo
u = UnitInfo -> UnitInfo -> Constraint
ConEq ((VV, Int, Int) -> UnitInfo
UnitParamPosUse ((Name
vname, Name
sname), Int
i, Int
callId)) (Int -> UnitInfo -> UnitInfo
forall a. Data a => Int -> a -> a
instantiate Int
callId UnitInfo
u)
intrinsicHelper UnitInfo
_ Expression (Analysis a)
_ t b
_ = []

-- | Get info about intrinsics by source name 'sname', taking into
-- account the special case of those with arbitrary number of
-- arguments.
intrinsicLookup :: F.Name -> Maybe (UnitInfo, [UnitInfo])
intrinsicLookup :: Name -> Maybe (UnitInfo, [UnitInfo])
intrinsicLookup Name
sname = do
  (UnitInfo
retU, [UnitInfo]
argUs) <- Name
-> Map Name (UnitInfo, [UnitInfo]) -> Maybe (UnitInfo, [UnitInfo])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
sname Map Name (UnitInfo, [UnitInfo])
intrinsicUnits
  (UnitInfo, [UnitInfo]) -> Maybe (UnitInfo, [UnitInfo])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfo
retU, if Name
sname Name -> GivenVarSet -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` GivenVarSet
specialCaseArbitraryArgs then [UnitInfo] -> [UnitInfo]
forall a. HasCallStack => [a] -> [a]
cycle [UnitInfo]
argUs else [UnitInfo]
argUs)

-- | Generate a unique identifier for a literal encountered in the code.
genUnitLiteral :: UnitSolver UnitInfo
genUnitLiteral :: StateT UnitState UnitAnalysis UnitInfo
genUnitLiteral = Int -> UnitInfo
UnitLiteral (Int -> UnitInfo)
-> UnitSolver Int -> StateT UnitState UnitAnalysis UnitInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitSolver Int
freshId

-- | Generate a unique identifier for a polymorphic literal encountered in the code.
genParamLit :: UnitSolver UnitInfo
genParamLit :: StateT UnitState UnitAnalysis UnitInfo
genParamLit = Int -> UnitInfo
UnitParamLitAbs (Int -> UnitInfo)
-> UnitSolver Int -> StateT UnitState UnitAnalysis UnitInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitSolver Int
freshId

-- Operate only on the blocks of a program unit, not the contained sub-programunits.
modifyPUBlocksM :: Monad m => ([F.Block a] -> m [F.Block a]) -> F.ProgramUnit a -> m (F.ProgramUnit a)
modifyPUBlocksM :: forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM [Block a] -> m [Block a]
f ProgramUnit a
pu = case ProgramUnit a
pu of
  F.PUMain a
a SrcSpan
s Maybe Name
n [Block a]
b Maybe [ProgramUnit a]
pus                    -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a
-> SrcSpan
-> Maybe Name
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> Maybe Name
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUMain a
a SrcSpan
s Maybe Name
n [Block a]
b' Maybe [ProgramUnit a]
pus
  F.PUModule a
a SrcSpan
s Name
n [Block a]
b Maybe [ProgramUnit a]
pus                  -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a
-> SrcSpan
-> Name
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> Name
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUModule a
a SrcSpan
s Name
n [Block a]
b' Maybe [ProgramUnit a]
pus
  F.PUSubroutine a
a SrcSpan
s PrefixSuffix a
r Name
n Maybe (AList Expression a)
p [Block a]
b Maybe [ProgramUnit a]
subs         -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a
-> SrcSpan
-> PrefixSuffix a
-> Name
-> Maybe (AList Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> PrefixSuffix a
-> Name
-> Maybe (AList Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUSubroutine a
a SrcSpan
s PrefixSuffix a
r Name
n Maybe (AList Expression a)
p [Block a]
b' Maybe [ProgramUnit a]
subs
  F.PUFunction   a
a SrcSpan
s Maybe (TypeSpec a)
r PrefixSuffix a
rec Name
n Maybe (AList Expression a)
p Maybe (Expression a)
res [Block a]
b Maybe [ProgramUnit a]
subs -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a
-> SrcSpan
-> Maybe (TypeSpec a)
-> PrefixSuffix a
-> Name
-> Maybe (AList Expression a)
-> Maybe (Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> Maybe (TypeSpec a)
-> PrefixSuffix a
-> Name
-> Maybe (AList Expression a)
-> Maybe (Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUFunction a
a SrcSpan
s Maybe (TypeSpec a)
r PrefixSuffix a
rec Name
n Maybe (AList Expression a)
p Maybe (Expression a)
res [Block a]
b' Maybe [ProgramUnit a]
subs
  F.PUBlockData  a
a SrcSpan
s Maybe Name
n [Block a]
b                  -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a -> SrcSpan -> Maybe Name -> [Block a] -> ProgramUnit a
forall a. a -> SrcSpan -> Maybe Name -> [Block a] -> ProgramUnit a
F.PUBlockData  a
a SrcSpan
s Maybe Name
n [Block a]
b'
  F.PUComment {}                          -> ProgramUnit a -> m (ProgramUnit a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramUnit a
pu -- no blocks

-- Fortran semantics for interpretation of constant expressions
-- involving numeric literals.
data FNum = FReal Double | FInt Integer

fnumToDouble :: FNum -> Double
fnumToDouble :: FNum -> Double
fnumToDouble (FReal Double
x) = Double
x
fnumToDouble (FInt Integer
x)  = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x

fAdd, fSub, fMul, fDiv, fPow :: FNum -> FNum -> FNum
fAdd :: FNum -> FNum -> FNum
fAdd (FReal Double
x) FNum
fy      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ FNum -> Double
fnumToDouble FNum
fy
fAdd FNum
fx (FReal Double
y)      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ FNum -> Double
fnumToDouble FNum
fx Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y
fAdd (FInt Integer
x) (FInt Integer
y) = Integer -> FNum
FInt  (Integer -> FNum) -> Integer -> FNum
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
y
fSub :: FNum -> FNum -> FNum
fSub (FReal Double
x) FNum
fy      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- FNum -> Double
fnumToDouble FNum
fy
fSub FNum
fx (FReal Double
y)      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ FNum -> Double
fnumToDouble FNum
fx Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
y
fSub (FInt Integer
x) (FInt Integer
y) = Integer -> FNum
FInt  (Integer -> FNum) -> Integer -> FNum
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y
fMul :: FNum -> FNum -> FNum
fMul (FReal Double
x) FNum
fy      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* FNum -> Double
fnumToDouble FNum
fy
fMul FNum
fx (FReal Double
y)      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ FNum -> Double
fnumToDouble FNum
fx Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
y
fMul (FInt Integer
x) (FInt Integer
y) = Integer -> FNum
FInt  (Integer -> FNum) -> Integer -> FNum
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
y
fDiv :: FNum -> FNum -> FNum
fDiv (FReal Double
x) FNum
fy      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ FNum -> Double
fnumToDouble FNum
fy
fDiv FNum
fx (FReal Double
y)      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ FNum -> Double
fnumToDouble FNum
fx Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
y
fDiv (FInt Integer
x) (FInt Integer
y) = Integer -> FNum
FInt  (Integer -> FNum) -> Integer -> FNum
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
y  -- Haskell quot truncates towards zero, like Fortran
fPow :: FNum -> FNum -> FNum
fPow (FReal Double
x) FNum
fy      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Floating a => a -> a -> a
** FNum -> Double
fnumToDouble FNum
fy
fPow FNum
fx (FReal Double
y)      = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ FNum -> Double
fnumToDouble FNum
fx Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
y
fPow (FInt Integer
x) (FInt Integer
y)
  | Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0             = Integer -> FNum
FInt  (Integer -> FNum) -> Integer -> FNum
forall a b. (a -> b) -> a -> b
$ Integer
x Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
y
  | Bool
otherwise          = Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x Double -> Integer -> Double
forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Integer
y

fDivMaybe :: Maybe FNum -> Maybe FNum -> Maybe FNum
fDivMaybe :: Maybe FNum -> Maybe FNum -> Maybe FNum
fDivMaybe Maybe FNum
mx Maybe FNum
my
  | Just FNum
y <- Maybe FNum
my,
    FNum -> Double
fnumToDouble FNum
y Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0.0 = Maybe FNum
forall a. Maybe a
Nothing
  | Bool
otherwise             = (FNum -> FNum -> FNum) -> Maybe FNum -> Maybe FNum -> Maybe FNum
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 FNum -> FNum -> FNum
fDiv Maybe FNum
mx Maybe FNum
my

-- | Statically computes if the expression is a constant value.
constantExpression :: F.Expression a -> Maybe Double
constantExpression :: forall a. Expression a -> Maybe Double
constantExpression Expression a
expr = FNum -> Double
fnumToDouble (FNum -> Double) -> Maybe FNum -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> Maybe FNum
forall {a}. Expression a -> Maybe FNum
ce Expression a
expr
  where
    ce :: Expression a -> Maybe FNum
ce Expression a
e = case Expression a
e of
      (F.ExpValue a
_ SrcSpan
_ (F.ValInteger Name
i Maybe (KindParam a)
_))      -> FNum -> Maybe FNum
forall a. a -> Maybe a
Just (FNum -> Maybe FNum) -> FNum -> Maybe FNum
forall a b. (a -> b) -> a -> b
$ Integer -> FNum
FInt (Integer -> FNum) -> Integer -> FNum
forall a b. (a -> b) -> a -> b
$ Name -> Integer
forall a. Read a => Name -> a
read Name
i
      (F.ExpValue a
_ SrcSpan
_ (F.ValReal RealLit
r Maybe (KindParam a)
_))         -> FNum -> Maybe FNum
forall a. a -> Maybe a
Just (FNum -> Maybe FNum) -> FNum -> Maybe FNum
forall a b. (a -> b) -> a -> b
$ Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ RealLit -> Double
forall a. (Fractional a, Read a) => RealLit -> a
readRealLit RealLit
r
      (F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Addition Expression a
e1 Expression a
e2)       -> (FNum -> FNum -> FNum) -> Maybe FNum -> Maybe FNum -> Maybe FNum
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 FNum -> FNum -> FNum
fAdd (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
      (F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Subtraction Expression a
e1 Expression a
e2)    -> (FNum -> FNum -> FNum) -> Maybe FNum -> Maybe FNum -> Maybe FNum
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 FNum -> FNum -> FNum
fSub (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
      (F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Multiplication Expression a
e1 Expression a
e2) -> (FNum -> FNum -> FNum) -> Maybe FNum -> Maybe FNum -> Maybe FNum
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 FNum -> FNum -> FNum
fMul (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
      (F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Division Expression a
e1 Expression a
e2)       -> Maybe FNum -> Maybe FNum -> Maybe FNum
fDivMaybe (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
      (F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Exponentiation Expression a
e1 Expression a
e2) -> (FNum -> FNum -> FNum) -> Maybe FNum -> Maybe FNum -> Maybe FNum
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 FNum -> FNum -> FNum
fPow (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
      -- FIXME: expand...
      Expression a
_                                        -> Maybe FNum
forall a. Maybe a
Nothing

-- | Asks the question: is the operator within the given category?
isOp :: BinOpKind -> F.BinaryOp -> Bool
isOp :: BinOpKind -> BinaryOp -> Bool
isOp BinOpKind
cat = (BinOpKind -> BinOpKind -> Bool
forall a. Eq a => a -> a -> Bool
== BinOpKind
cat) (BinOpKind -> Bool) -> (BinaryOp -> BinOpKind) -> BinaryOp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinaryOp -> BinOpKind
binOpKind

data BinOpKind = AddOp | MulOp | DivOp | PowerOp | LogicOp | RelOp deriving BinOpKind -> BinOpKind -> Bool
(BinOpKind -> BinOpKind -> Bool)
-> (BinOpKind -> BinOpKind -> Bool) -> Eq BinOpKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BinOpKind -> BinOpKind -> Bool
== :: BinOpKind -> BinOpKind -> Bool
$c/= :: BinOpKind -> BinOpKind -> Bool
/= :: BinOpKind -> BinOpKind -> Bool
Eq
binOpKind :: F.BinaryOp -> BinOpKind
binOpKind :: BinaryOp -> BinOpKind
binOpKind BinaryOp
F.Addition         = BinOpKind
AddOp
binOpKind BinaryOp
F.Subtraction      = BinOpKind
AddOp
binOpKind BinaryOp
F.Multiplication   = BinOpKind
MulOp
binOpKind BinaryOp
F.Division         = BinOpKind
DivOp
binOpKind BinaryOp
F.Exponentiation   = BinOpKind
PowerOp
binOpKind BinaryOp
F.Concatenation    = BinOpKind
AddOp
binOpKind BinaryOp
F.GT               = BinOpKind
RelOp
binOpKind BinaryOp
F.GTE              = BinOpKind
RelOp
binOpKind BinaryOp
F.LT               = BinOpKind
RelOp
binOpKind BinaryOp
F.LTE              = BinOpKind
RelOp
binOpKind BinaryOp
F.EQ               = BinOpKind
RelOp
binOpKind BinaryOp
F.NE               = BinOpKind
RelOp
binOpKind BinaryOp
F.Or               = BinOpKind
LogicOp
binOpKind BinaryOp
F.And              = BinOpKind
LogicOp
binOpKind BinaryOp
F.XOr              = BinOpKind
LogicOp
binOpKind BinaryOp
F.Equivalent       = BinOpKind
RelOp
binOpKind BinaryOp
F.NotEquivalent    = BinOpKind
RelOp
binOpKind (F.BinCustom Name
_)    = BinOpKind
RelOp

-- | Get information about imported variables coming from mod files.
getImportedVariables :: UnitSolver (M.Map VV UnitInfo)
getImportedVariables :: UnitSolver VarUnitMap
getImportedVariables = do
  ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile
  NameParamMap
nmap <- UnitSolver NameParamMap
getNameParamMap
  -- Translate a Use AST node into a pair mapping unique name to 'local' source name in this program file.
  let useToPair :: Use (Analysis a) -> VV
useToPair (F.UseID Analysis a
_ SrcSpan
_ Expression (Analysis a)
e) = (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e, Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e)
      useToPair (F.UseRename Analysis a
_ SrcSpan
_ Expression (Analysis a)
e1 Expression (Analysis a)
_) = (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e1, Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e1) -- (unique name, 'local' source name)
  -- A map of modules -> (maps of variables -> their unit info).
  let modnmaps :: [Map NameParamKey [UnitInfo]]
modnmaps = [ [(NameParamKey, [UnitInfo])] -> Map NameParamKey [UnitInfo]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (((NameParamKey, [UnitInfo]) -> Maybe (NameParamKey, [UnitInfo]))
-> [(NameParamKey, [UnitInfo])] -> [(NameParamKey, [UnitInfo])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NameParamKey, [UnitInfo]) -> Maybe (NameParamKey, [UnitInfo])
forall {b}. (NameParamKey, b) -> Maybe (NameParamKey, b)
f (Map NameParamKey [UnitInfo] -> [(NameParamKey, [UnitInfo])]
forall k a. Map k a -> [(k, a)]
M.toList Map NameParamKey [UnitInfo]
npkmap))
                 -- find all StUse statements and identify variables that need to be imported from nmap
                 | F.StUse UA
_ SrcSpan
_ Expression UA
e Maybe ModuleNature
_ Only
only Maybe (AList Use UA)
alist <- ProgramFile UA -> [Statement UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [ F.Statement UA ]
                 , let mod :: Name
mod = Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
e
                 , let uses :: [VV]
uses = (Use UA -> VV) -> [Use UA] -> [VV]
forall a b. (a -> b) -> [a] -> [b]
map Use UA -> VV
forall {a}. Use (Analysis a) -> VV
useToPair ([Use UA] -> Maybe [Use UA] -> [Use UA]
forall a. a -> Maybe a -> a
fromMaybe [] (AList Use UA -> [Use UA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip (AList Use UA -> [Use UA])
-> Maybe (AList Use UA) -> Maybe [Use UA]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (AList Use UA)
alist))
                 , Just Map NameParamKey [UnitInfo]
npkmap <- [ProgramUnitName
-> NameParamMap -> Maybe (Map NameParamKey [UnitInfo])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Name -> ProgramUnitName
F.Named Name
mod) NameParamMap
nmap]
                 , let f :: (NameParamKey, b) -> Maybe (NameParamKey, b)
f (NameParamKey
npk, b
ui) = case NameParamKey
npk of
                         (NPKVariable (Name
var, Name
src))
                           -- import all variables from module -- apply any renames from uses
                           | Only
only Only -> Only -> Bool
forall a. Eq a => a -> a -> Bool
== Only
F.Permissive -> (NameParamKey, b) -> Maybe (NameParamKey, b)
forall a. a -> Maybe a
Just (VV -> NameParamKey
NPKVariable (Name
var, Name
src Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
`fromMaybe` Name -> [VV] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
var [VV]
uses), b
ui)
                           -- only import variable mentioned in uses
                           | Just Name
src' <- Name -> [VV] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
var [VV]
uses -> (NameParamKey, b) -> Maybe (NameParamKey, b)
forall a. a -> Maybe a
Just (VV -> NameParamKey
NPKVariable (Name
var, Name
src'), b
ui)
                         NameParamKey
_ -> Maybe (NameParamKey, b)
forall a. Maybe a
Nothing
                 ]
  VarUnitMap -> UnitSolver VarUnitMap
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarUnitMap -> UnitSolver VarUnitMap)
-> VarUnitMap -> UnitSolver VarUnitMap
forall a b. (a -> b) -> a -> b
$ [(VV, UnitInfo)] -> VarUnitMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (VV
vv, [UnitInfo] -> UnitInfo
forall (t :: * -> *). Foldable t => t UnitInfo -> UnitInfo
foldUnits [UnitInfo]
units) | (NPKVariable VV
vv, [UnitInfo]
units) <- Map NameParamKey [UnitInfo] -> [(NameParamKey, [UnitInfo])]
forall k a. Map k a -> [(k, a)]
M.toList ([Map NameParamKey [UnitInfo]] -> Map NameParamKey [UnitInfo]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions [Map NameParamKey [UnitInfo]]
modnmaps) ]

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

logDebugNoOrigin :: Text -> UnitSolver ()
logDebugNoOrigin :: Text -> UnitSolver ()
logDebugNoOrigin Text
msg = do
  ProgramFile UA
pf <- (UnitState -> ProgramFile UA) -> UnitSolver (ProgramFile UA)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets UnitState -> ProgramFile UA
usProgramFile
  ProgramFile UA -> Text -> UnitSolver ()
forall a. Spanned a => a -> Text -> UnitSolver ()
forall e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' ProgramFile UA
pf Text
msg

dumpConsM :: String -> Constraints -> UnitSolver ()
dumpConsM :: Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
str = Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Constraint] -> Text) -> [Constraint] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Constraint] -> Name) -> [Constraint] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> Name)
-> ([Constraint] -> [Name]) -> [Constraint] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int -> Char -> Name
forall a. Int -> a -> [a]
replicate Int
50 Char
'-', Name
str Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
":"][Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++) ([Name] -> [Name])
-> ([Constraint] -> [Name]) -> [Constraint] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++[Int -> Char -> Name
forall a. Int -> a -> [a]
replicate Int
50 Char
'^']) ([Name] -> [Name])
-> ([Constraint] -> [Name]) -> [Constraint] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Constraint -> Name
f
  where
    f :: Constraint -> Name
f (ConEq UnitInfo
u1 UnitInfo
u2)  = [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)
    f (ConConj [Constraint]
cons) = Name -> [Name] -> Name
forall a. [a] -> [[a]] -> [a]
intercalate Name
" && " ((Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Constraint -> Name
f [Constraint]
cons)

debugLogging :: UnitSolver ()
debugLogging :: UnitSolver ()
debugLogging = do
    (Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Constraint] -> Text) -> [Constraint] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Constraint] -> Name) -> [Constraint] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> Name)
-> ([Constraint] -> [Name]) -> [Constraint] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> Name
"  ***AbsConstraint: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2))) ([Constraint] -> UnitSolver ())
-> UnitSolver [Constraint] -> UnitSolver ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UnitSolver [Constraint]
extractConstraints
    ProgramFile UA
pf   <- UnitSolver (ProgramFile UA)
getProgramFile
    [Constraint]
cons <- UnitSolver [Constraint]
getConstraints
    VarUnitMap
vum  <- UnitSolver VarUnitMap
getVarUnitMap
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ [ Name
"  " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ UnitInfo -> Name
forall a. Show a => a -> Name
show UnitInfo
info Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" :: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
n | ((Name
n, Name
_), UnitInfo
info) <- VarUnitMap -> [(VV, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList VarUnitMap
vum ]
    Text -> UnitSolver ()
logDebugNoOrigin Text
""
    UnitAliasMap
uam <- UnitSolver UnitAliasMap
getUnitAliasMap
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ [ Name
"  " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
n Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" = " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ UnitInfo -> Name
forall a. Show a => a -> Name
show UnitInfo
info | (Name
n, UnitInfo
info) <- UnitAliasMap -> [(Name, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList UnitAliasMap
uam ]
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> Name
"  ***Constraint: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) [Constraint]
cons
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ [Constraint] -> Text
forall a. Show a => a -> Text
describeShow [Constraint]
cons Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
    [ProgramUnit UA]
-> (ProgramUnit UA -> UnitSolver ()) -> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf) ((ProgramUnit UA -> UnitSolver ()) -> UnitSolver ())
-> (ProgramUnit UA -> UnitSolver ()) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit UA
pu -> case ProgramUnit UA
pu of
      F.PUFunction {}
        | Just (ConConj [Constraint]
con) <- ProgramUnit UA -> Maybe Constraint
forall (f :: * -> *). Annotated f => f UA -> Maybe Constraint
UA.getConstraint ProgramUnit UA
pu ->
          Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (ProgramUnit UA -> Name
puName ProgramUnit UA
pu Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
":")Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:(Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> Name
"    constraint: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) [Constraint]
con
      F.PUSubroutine {}
        | Just (ConConj [Constraint]
con) <- ProgramUnit UA -> Maybe Constraint
forall (f :: * -> *). Annotated f => f UA -> Maybe Constraint
UA.getConstraint ProgramUnit UA
pu ->
          Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (ProgramUnit UA -> Name
puName ProgramUnit UA
pu Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
":")Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:(Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> Name
"    constraint: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) [Constraint]
con
      ProgramUnit UA
_ -> () -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    let (Matrix Double
lhsM, Matrix Double
rhsM, [Int]
_, Array Int UnitInfo
lhsColA, Array Int UnitInfo
rhsColA) = [Constraint]
-> (Matrix Double, Matrix Double, [Int], Array Int UnitInfo,
    Array Int UnitInfo)
constraintsToMatrices [Constraint]
cons
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nLHS Cols:"
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Array Int UnitInfo -> Text
forall a. Show a => a -> Text
describeShow Array Int UnitInfo
lhsColA
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nRHS Cols:"
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Array Int UnitInfo -> Text
forall a. Show a => a -> Text
describeShow Array Int UnitInfo
rhsColA
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nLHS M:"
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double -> Text
forall a. Show a => a -> Text
describeShow Matrix Double
lhsM
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nRHS M:"
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double -> Text
forall a. Show a => a -> Text
describeShow Matrix Double
rhsM
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nAUG M:"
    let augM :: Matrix Double
augM = if Matrix Double -> Int
forall t. Matrix t -> Int
H.rows Matrix Double
rhsM Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Matrix Double -> Int
forall t. Matrix t -> Int
H.cols Matrix Double
rhsM Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Matrix Double
lhsM else [[Matrix Double]] -> Matrix Double
forall t. Element t => [[Matrix t]] -> Matrix t
H.fromBlocks [[Matrix Double
lhsM, Matrix Double
rhsM]]
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double -> Text
forall a. Show a => a -> Text
describeShow Matrix Double
augM
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nSolved (hnf) M:"
    let hnfM :: Matrix Double
hnfM = Matrix Double -> Matrix Double
Flint.hnf Matrix Double
augM
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double -> Text
forall a. Show a => a -> Text
describeShow Matrix Double
hnfM
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nSolved (normHNF) M:"
    let (Matrix Double
solvedM, [Int]
newColIndices) = Matrix Double -> (Matrix Double, [Int])
Flint.normHNF Matrix Double
augM
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> (Matrix Double -> Text) -> Matrix Double -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matrix Double -> Text
forall a. Show a => a -> Text
describeShow (Matrix Double -> UnitSolver ()) -> Matrix Double -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double
solvedM
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Text
"newColIndices = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Int] -> Text
forall a. Show a => a -> Text
describeShow [Int]
newColIndices
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nLHS Cols with newColIndices:"
    let lhsCols :: [UnitInfo]
lhsCols = Array Int UnitInfo -> [UnitInfo]
forall i e. Array i e -> [e]
A.elems Array Int UnitInfo
lhsColA [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ (Int -> UnitInfo) -> [Int] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Array Int UnitInfo
lhsColA Array Int UnitInfo -> Int -> UnitInfo
forall i e. Ix i => Array i e -> i -> e
A.!) [Int]
newColIndices
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text)
-> ([(Int, UnitInfo)] -> Name) -> [(Int, UnitInfo)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> Name)
-> ([(Int, UnitInfo)] -> [Name]) -> [(Int, UnitInfo)] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, UnitInfo) -> Name) -> [(Int, UnitInfo)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Int, UnitInfo) -> Name
forall a. Show a => a -> Name
show ([(Int, UnitInfo)] -> Text) -> [(Int, UnitInfo)] -> Text
forall a b. (a -> b) -> a -> b
$ [Int] -> [UnitInfo] -> [(Int, UnitInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0::Int)..] [UnitInfo]
lhsCols
    -- logDebugNoOrigin "--------------------------------------------------\nSolved (SVD) M:"
    -- logDebugNoOrigin $ show (H.linearSolveSVD lhsM rhsM)
    -- logDebugNoOrigin "--------------------------------------------------\nSingular Values:"
    -- logDebugNoOrigin $ show (H.singularValues lhsM)
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------"
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Text
"Rank LHS: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
describeShow (Matrix Double -> Int
forall t. Field t => Matrix t -> Int
H.rank Matrix Double
lhsM)
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------"
    let augA :: Matrix Double
augA = if Matrix Double -> Int
forall t. Matrix t -> Int
H.rows Matrix Double
rhsM Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Matrix Double -> Int
forall t. Matrix t -> Int
H.cols Matrix Double
rhsM Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Matrix Double
lhsM else [[Matrix Double]] -> Matrix Double
forall t. Element t => [[Matrix t]] -> Matrix t
H.fromBlocks [[Matrix Double
lhsM, Matrix Double
rhsM]]
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Text
"Rank Augmented: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
describeShow (Matrix Double -> Int
forall t. Field t => Matrix t -> Int
H.rank Matrix Double
augA)
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nGenUnitAssignments:"
    let unitAssignments :: [([UnitInfo], UnitInfo)]
unitAssignments = [Constraint] -> [([UnitInfo], UnitInfo)]
genUnitAssignments [Constraint]
cons
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (([UnitInfo], UnitInfo) -> Name)
-> [([UnitInfo], UnitInfo)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ ([UnitInfo]
u1s, UnitInfo
u2) -> Name
"  ***UnitAssignment: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show [UnitInfo]
u1s Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\n") [([UnitInfo], UnitInfo)]
unitAssignments
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------"
    let unitAssignmentsSBV :: [(UnitInfo, UnitInfo)]
unitAssignmentsSBV = [Constraint] -> [(UnitInfo, UnitInfo)]
BackendSBV.genUnitAssignments [Constraint]
cons
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ ((UnitInfo, UnitInfo) -> Name) -> [(UnitInfo, UnitInfo)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (UnitInfo
u1s, UnitInfo
u2) -> Name
"  ***UnitAssignmentSBV: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ UnitInfo -> Name
forall a. Show a => a -> Name
show UnitInfo
u1s Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) [(UnitInfo, UnitInfo)]
unitAssignmentsSBV
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nProvenance:"
    let (Matrix Double
augM', Provenance
p) = Matrix Double -> (Matrix Double, Provenance)
provenance Matrix Double
augM
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> (Matrix Double -> Text) -> Matrix Double -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matrix Double -> Text
forall a. Show a => a -> Text
describeShow (Matrix Double -> UnitSolver ()) -> Matrix Double -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double
augM'
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> (Provenance -> Text) -> Provenance -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Provenance -> Text
forall a. Show a => a -> Text
describeShow (Provenance -> UnitSolver ()) -> Provenance -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Provenance
p

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

-- convenience
puName :: F.ProgramUnit UA -> F.Name
puName :: ProgramUnit UA -> Name
puName ProgramUnit UA
pu
  | F.Named Name
n <- ProgramUnit UA -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
FA.puName ProgramUnit UA
pu = Name
n
  | Bool
otherwise                 = Name
"_nameless"

puSrcName :: F.ProgramUnit UA -> F.Name
puSrcName :: ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu
  | F.Named Name
n <- ProgramUnit UA -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
FA.puSrcName ProgramUnit UA
pu = Name
n
  | Bool
otherwise                    = Name
"_nameless"

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

-- | Intrinics that take arbitrary number of arguments. Entry in table
-- 'intrinsicUnits' will contain a single item in the argument list,
-- corresponding to the template used for all arguments.
specialCaseArbitraryArgs :: S.Set F.Name
specialCaseArbitraryArgs :: GivenVarSet
specialCaseArbitraryArgs = [Name] -> GivenVarSet
forall a. Ord a => [a] -> Set a
S.fromList [ Name
"max", Name
"max0", Name
"amax1", Name
"dmax1", Name
"amax0", Name
"max1"
                                      , Name
"min", Name
"min0", Name
"amin1", Name
"dmin1", Name
"amin0", Name
"min1" ]

-- | Intrinsics table: name => (return-unit, parameter-units). See also 'specialCaseArbitraryArgs'.
intrinsicUnits :: M.Map F.Name (UnitInfo, [UnitInfo])
intrinsicUnits :: Map Name (UnitInfo, [UnitInfo])
intrinsicUnits =
  [(Name, (UnitInfo, [UnitInfo]))] -> Map Name (UnitInfo, [UnitInfo])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ (Name
"transfer", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
    , (Name
"abs", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"iabs", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"dabs", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"cabs", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"aimag", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"aint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"dint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"anint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"dnint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"cmplx", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"conjg", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"dble", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"dim", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"idim", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"ddim", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"dprod", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"ceiling", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"floor", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"int", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"ifix", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"idint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"maxval", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"minval", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"max", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))   -- special case: arbitrary # of parameters
    , (Name
"min", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))   -- special case: arbitrary # of parameters
    , (Name
"min0", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))  -- special case: arbitrary # of parameters
    , (Name
"amin1", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")])) -- special case: arbitrary # of parameters
    , (Name
"dmin1", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")])) -- special case: arbitrary # of parameters
    , (Name
"amin0", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")])) -- special case: arbitrary # of parameters
    , (Name
"min1", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))  -- special case: arbitrary # of parameters
    , (Name
"mod", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
    , (Name
"modulo", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
    , (Name
"amod", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
    , (Name
"dmod", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
    , (Name
"nint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"real", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"float", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"sngl", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"sign", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
    , (Name
"isign", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
    , (Name
"dsign", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
    , (Name
"present", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [UnitInfo
UnitlessVar]))
    , (Name
"sqrt", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [UnitInfo -> Double -> UnitInfo
UnitPow (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")) Double
2]))
    , (Name
"dsqrt", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [UnitInfo -> Double -> UnitInfo
UnitPow (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")) Double
2]))
    , (Name
"csqrt", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [UnitInfo -> Double -> UnitInfo
UnitPow (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")) Double
2]))
    , (Name
"exp", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dexp", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"cexp", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"alog", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dlog", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"clog", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"alog10", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dlog10", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"sin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dsin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"csin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"cos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dcos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"ccos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"tan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dtan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"asin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dasin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"acos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dacos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"atan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"datan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"atan2", (UnitInfo
UnitlessVar, [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"datan2", (UnitInfo
UnitlessVar, [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    , (Name
"sinh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dsinh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"cosh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dcosh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"tanh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"dtanh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , (Name
"iand", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
    ]

-- Others: reshape, merge need special handling

-- | Compile a program to a 'ModFile' containing units information.
compileUnits :: UnitOpts -> ModFiles -> F.ProgramFile Annotation -> IO ModFile
compileUnits :: UnitOpts -> ModFiles -> ProgramFile A -> IO ModFile
compileUnits UnitOpts
uo ModFiles
mfs ProgramFile A
pf = do
  let (ProgramFile UA
pf', ModuleMap
_, TypeEnv
_) = ModFiles
-> ProgramFile (UnitAnnotation A)
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall a.
Data a =>
ModFiles
-> ProgramFile a -> (ProgramFile (Analysis a), ModuleMap, TypeEnv)
withCombinedEnvironment ModFiles
mfs (ProgramFile (UnitAnnotation A)
 -> (ProgramFile UA, ModuleMap, TypeEnv))
-> (ProgramFile A -> ProgramFile (UnitAnnotation A))
-> ProgramFile A
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (A -> UnitAnnotation A)
-> ProgramFile A -> ProgramFile (UnitAnnotation A)
forall a b. (a -> b) -> ProgramFile a -> ProgramFile b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap A -> UnitAnnotation A
forall a. a -> UnitAnnotation a
UA.mkUnitAnnotation (ProgramFile A -> (ProgramFile UA, ModuleMap, TypeEnv))
-> ProgramFile A -> (ProgramFile UA, ModuleMap, TypeEnv)
forall a b. (a -> b) -> a -> b
$ ProgramFile A
pf

  let analysis :: AnalysisT () () IO (CompiledUnits, UnitState)
analysis = ReaderT UnitEnv (AnalysisT () () IO) (CompiledUnits, UnitState)
-> UnitEnv -> AnalysisT () () IO (CompiledUnits, UnitState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (UnitSolver CompiledUnits
-> ReaderT UnitEnv (AnalysisT () () IO) (CompiledUnits, UnitState)
forall a. UnitSolver a -> UnitAnalysis (a, UnitState)
runInference UnitSolver CompiledUnits
runCompileUnits) (UnitEnv -> AnalysisT () () IO (CompiledUnits, UnitState))
-> UnitEnv -> AnalysisT () () IO (CompiledUnits, UnitState)
forall a b. (a -> b) -> a -> b
$
        UnitEnv
        { unitOpts :: UnitOpts
unitOpts = UnitOpts
uo
        , unitProgramFile :: ProgramFile A
unitProgramFile = ProgramFile A
pf
        }

  AnalysisReport () () (CompiledUnits, UnitState)
report <- Name
-> LogOutput IO
-> LogLevel
-> ModFiles
-> AnalysisT () () IO (CompiledUnits, UnitState)
-> IO (AnalysisReport () () (CompiledUnits, UnitState))
forall (m :: * -> *) e w a.
(Monad m, Describe e, Describe w) =>
Name
-> LogOutput m
-> LogLevel
-> ModFiles
-> AnalysisT e w m a
-> m (AnalysisReport e w a)
runAnalysisT (ProgramFile A -> Name
forall a. ProgramFile a -> Name
F.pfGetFilename ProgramFile A
pf) (Bool -> LogOutput IO
forall (m :: * -> *). Monad m => Bool -> LogOutput m
logOutputNone Bool
True) LogLevel
LogError ModFiles
mfs AnalysisT () () IO (CompiledUnits, UnitState)
analysis

  case AnalysisReport () () (CompiledUnits, UnitState)
report AnalysisReport () () (CompiledUnits, UnitState)
-> Getting
     (First CompiledUnits)
     (AnalysisReport () () (CompiledUnits, UnitState))
     CompiledUnits
-> Maybe CompiledUnits
forall s a. s -> Getting (First a) s a -> Maybe a
^? (AnalysisResult () (CompiledUnits, UnitState)
 -> Const
      (First CompiledUnits)
      (AnalysisResult () (CompiledUnits, UnitState)))
-> AnalysisReport () () (CompiledUnits, UnitState)
-> Const
     (First CompiledUnits)
     (AnalysisReport () () (CompiledUnits, UnitState))
forall e w r1 r2 (f :: * -> *).
Functor f =>
(AnalysisResult e r1 -> f (AnalysisResult e r2))
-> AnalysisReport e w r1 -> f (AnalysisReport e w r2)
arResult ((AnalysisResult () (CompiledUnits, UnitState)
  -> Const
       (First CompiledUnits)
       (AnalysisResult () (CompiledUnits, UnitState)))
 -> AnalysisReport () () (CompiledUnits, UnitState)
 -> Const
      (First CompiledUnits)
      (AnalysisReport () () (CompiledUnits, UnitState)))
-> ((CompiledUnits -> Const (First CompiledUnits) CompiledUnits)
    -> AnalysisResult () (CompiledUnits, UnitState)
    -> Const
         (First CompiledUnits)
         (AnalysisResult () (CompiledUnits, UnitState)))
-> Getting
     (First CompiledUnits)
     (AnalysisReport () () (CompiledUnits, UnitState))
     CompiledUnits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CompiledUnits, UnitState)
 -> Const (First CompiledUnits) (CompiledUnits, UnitState))
-> AnalysisResult () (CompiledUnits, UnitState)
-> Const
     (First CompiledUnits)
     (AnalysisResult () (CompiledUnits, UnitState))
forall e r1 r2 (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p r1 (f r2) -> p (AnalysisResult e r1) (f (AnalysisResult e r2))
_ARSuccess (((CompiledUnits, UnitState)
  -> Const (First CompiledUnits) (CompiledUnits, UnitState))
 -> AnalysisResult () (CompiledUnits, UnitState)
 -> Const
      (First CompiledUnits)
      (AnalysisResult () (CompiledUnits, UnitState)))
-> ((CompiledUnits -> Const (First CompiledUnits) CompiledUnits)
    -> (CompiledUnits, UnitState)
    -> Const (First CompiledUnits) (CompiledUnits, UnitState))
-> (CompiledUnits -> Const (First CompiledUnits) CompiledUnits)
-> AnalysisResult () (CompiledUnits, UnitState)
-> Const
     (First CompiledUnits)
     (AnalysisResult () (CompiledUnits, UnitState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompiledUnits -> Const (First CompiledUnits) CompiledUnits)
-> (CompiledUnits, UnitState)
-> Const (First CompiledUnits) (CompiledUnits, UnitState)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (CompiledUnits, UnitState)
  (CompiledUnits, UnitState)
  CompiledUnits
  CompiledUnits
_1 of
    Just CompiledUnits
cu -> ModFile -> IO ModFile
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgramFile UA -> CompiledUnits -> ModFile
genUnitsModFile ProgramFile UA
pf' CompiledUnits
cu)
    Maybe CompiledUnits
Nothing -> Name -> IO ModFile
forall a. Name -> IO a
forall (m :: * -> *) a. MonadFail m => Name -> m a
fail Name
"compileUnits: units analysis failed"