{- |
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 #-}

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.BBlocks as FAB
import qualified Language.Fortran.Analysis.DataFlow as FAD
import           Language.Fortran.Parser.Utils (readReal, readInteger)
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, [Char]
_) =
        Writer [Char] (ProgramFile UA) -> (ProgramFile UA, [Char])
forall w a. Writer w a -> (a, w)
runWriter (Writer [Char] (ProgramFile UA) -> (ProgramFile UA, [Char]))
-> Writer [Char] (ProgramFile UA) -> (ProgramFile UA, [Char])
forall a b. (a -> b) -> a -> b
$ SpecParser UnitParseError UnitStatement
-> (SrcSpan
    -> SpecParseError UnitParseError -> WriterT [Char] Identity ())
-> ProgramFile UA
-> Writer [Char] (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 -> [Char] -> WriterT [Char] Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell ([Char] -> WriterT [Char] Identity ())
-> [Char] -> WriterT [Char] Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [Char]
forall a. Show a => a -> [Char]
show SrcSpan
srcSpan [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SpecParseError UnitParseError -> [Char]
forall a. Show a => a -> [Char]
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.
  Constraints
abstractCons <- UnitSolver Constraints
extractConstraints
  [Char] -> Constraints -> UnitSolver ()
dumpConsM [Char]
"***abstractCons" Constraints
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.
  Constraints
cons <- Constraints -> UnitSolver Constraints
applyTemplates Constraints
abstractCons
  [Char] -> Constraints -> UnitSolver ()
dumpConsM [Char]
"***concreteCons" Constraints
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

  (Constraints -> Constraints) -> UnitSolver ()
modifyConstraints (Constraints -> Constraints -> Constraints
forall a b. a -> b -> a
const Constraints
cons)

  UnitSolver ()
debugLogging

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

  let (ProgramFile UA
pf', ModuleMap
_, TypeEnv
_) = ModFiles
-> ProgramFile (UnitAnnotation Annotation)
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall a.
Data a =>
ModFiles
-> ProgramFile a -> (ProgramFile (Analysis a), ModuleMap, TypeEnv)
withCombinedEnvironment ModFiles
mfs (ProgramFile (UnitAnnotation Annotation)
 -> (ProgramFile UA, ModuleMap, TypeEnv))
-> (ProgramFile Annotation
    -> ProgramFile (UnitAnnotation Annotation))
-> ProgramFile Annotation
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Annotation -> UnitAnnotation Annotation)
-> ProgramFile Annotation
-> ProgramFile (UnitAnnotation Annotation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotation -> UnitAnnotation Annotation
forall a. a -> UnitAnnotation a
UA.mkUnitAnnotation (ProgramFile Annotation -> (ProgramFile UA, ModuleMap, TypeEnv))
-> ProgramFile Annotation -> (ProgramFile UA, ModuleMap, TypeEnv)
forall a b. (a -> b) -> a -> b
$ ProgramFile Annotation
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 (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 -> [Char]
puName ProgramUnit UA
pu, ProgramUnit UA -> [Char]
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
_ [Char]
_ 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
_ [Char]
_ Maybe (AList Expression UA)
Nothing Maybe (Expression UA)
_ [Block UA]
_ Maybe [ProgramUnit UA]
_              <- ProgramUnit UA
pu = [(Int
0, ([Char]
fname, [Char]
sfname))]
  | F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ [Char]
_ (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
_ [Char]
_ (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
$ ([Char]
fname, [Char]
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
_ [Char]
_ (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 :: [Char]
fname  = ProgramUnit UA -> [Char]
puName ProgramUnit UA
pu
    sfname :: [Char]
sfname = ProgramUnit UA -> [Char]
puSrcName ProgramUnit UA
pu
    toVV :: Expression (Analysis a) -> VV
toVV Expression (Analysis a)
e = (Expression (Analysis a) -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression (Analysis a)
e, Expression (Analysis a) -> [Char]
forall a. Expression (Analysis a) -> [Char]
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 [Char] (DeclContext, SrcSpan)
dmap <- ReaderT
  UnitEnv (AnalysisT () () IO) (Map [Char] (DeclContext, SrcSpan))
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (Map [Char] (DeclContext, SrcSpan))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT
   UnitEnv (AnalysisT () () IO) (Map [Char] (DeclContext, SrcSpan))
 -> StateT
      UnitState
      (ReaderT UnitEnv (AnalysisT () () IO))
      (Map [Char] (DeclContext, SrcSpan)))
-> (AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
    -> ReaderT
         UnitEnv (AnalysisT () () IO) (Map [Char] (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (Map [Char] (DeclContext, SrcSpan))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
-> ReaderT
     UnitEnv (AnalysisT () () IO) (Map [Char] (DeclContext, SrcSpan))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
 -> StateT
      UnitState
      (ReaderT UnitEnv (AnalysisT () () IO))
      (Map [Char] (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (Map [Char] (DeclContext, SrcSpan))
forall a b. (a -> b) -> a -> b
$ Map [Char] (DeclContext, SrcSpan)
-> Map [Char] (DeclContext, SrcSpan)
-> Map [Char] (DeclContext, SrcSpan)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (ProgramFile UA -> Map [Char] (DeclContext, SrcSpan)
forall a.
Data a =>
ProgramFile (Analysis a) -> Map [Char] (DeclContext, SrcSpan)
extractDeclMap ProgramFile UA
pf) (Map [Char] (DeclContext, SrcSpan)
 -> Map [Char] (DeclContext, SrcSpan))
-> (ModFiles -> Map [Char] (DeclContext, SrcSpan))
-> ModFiles
-> Map [Char] (DeclContext, SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModFiles -> Map [Char] (DeclContext, SrcSpan)
combinedDeclMap (ModFiles -> Map [Char] (DeclContext, SrcSpan))
-> AnalysisT () () IO ModFiles
-> AnalysisT () () IO (Map [Char] (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA))
 -> UnitSolver ())
-> (ProgramUnit UA
    -> StateT
         UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA))
-> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit UA
pu ->
    ([Block UA]
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [Block UA])
-> ProgramUnit UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> [Block UA]
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (Map [Char] (DeclContext, SrcSpan)
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
insertUndeterminedUnitVar Map [Char] (DeclContext, SrcSpan)
dmap)) ProgramUnit UA
pu

-- Specifically handle variables
insertUndeterminedUnitVar :: DeclMap -> F.Expression UA -> UnitSolver (F.Expression UA)
insertUndeterminedUnitVar :: Map [Char] (DeclContext, SrcSpan)
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
insertUndeterminedUnitVar Map [Char] (DeclContext, SrcSpan)
dmap v :: Expression UA
v@(F.ExpValue UA
_ SrcSpan
_ (F.ValVariable [Char]
_))
  | Just (FA.IDType { idVType :: IDType -> Maybe BaseType
FA.idVType = Just BaseType
bty }) <- UA -> Maybe IDType
forall a. Analysis a -> Maybe IDType
FA.idType (Expression UA -> UA
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
v)
  , BaseType
bty BaseType -> [BaseType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BaseType]
acceptableTypes = do
  let vname :: [Char]
vname = Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression UA
v
  let sname :: [Char]
sname = Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
srcName Expression UA
v
  let unit :: UnitInfo
unit  = Map [Char] (DeclContext, SrcSpan) -> VV -> UnitInfo
toUnitVar Map [Char] (DeclContext, SrcSpan)
dmap ([Char]
vname, [Char]
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 -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression UA
v, Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
srcName Expression UA
v) UnitInfo
unit
  Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
v
insertUndeterminedUnitVar Map [Char] (DeclContext, SrcSpan)
_ Expression UA
e = Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
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 [Char] (DeclContext, SrcSpan) -> VV -> UnitInfo
toUnitVar Map [Char] (DeclContext, SrcSpan)
dmap ([Char]
vname, [Char]
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
<$> [Char]
-> Map [Char] (DeclContext, SrcSpan)
-> Maybe (DeclContext, SrcSpan)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
vname Map [Char] (DeclContext, SrcSpan)
dmap of
      Just (DCFunction (F.Named [Char]
fvname, F.Named [Char]
fsname))   -> (VV, VV) -> UnitInfo
UnitParamVarAbs (([Char]
fvname, [Char]
fsname), ([Char]
vname, [Char]
sname))
      Just (DCSubroutine (F.Named [Char]
fvname, F.Named [Char]
fsname)) -> (VV, VV) -> UnitInfo
UnitParamVarAbs (([Char]
fvname, [Char]
fsname), ([Char]
vname, [Char]
sname))
      Maybe DeclContext
_                                                    -> VV -> UnitInfo
UnitVar ([Char]
vname, [Char]
sname)

-- Insert undetermined units annotations on the following types of variables.
acceptableTypes :: [F.BaseType]
acceptableTypes :: [BaseType]
acceptableTypes = [BaseType
F.TypeReal, BaseType
F.TypeDoublePrecision, BaseType
F.TypeComplex, BaseType
F.TypeDoubleComplex, BaseType
F.TypeInteger]

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

-- | 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 [Char]
f)) (UnitName a :: [Char]
a@(Char
'\'':[Char]
_)) = VV -> UnitInfo
UnitParamEAPAbs ([Char]
a, [Char]
f [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 [[Char]]
vars) UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec
      , Just ProgramUnit UA
pu                                      <- Maybe (ProgramUnit UA)
mPU = UnitInfo -> ProgramUnit UA -> [[Char]] -> UnitSolver ()
insertPUUnitAssigns (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST) ProgramUnit UA
pu [[Char]]
vars
      -- Add a new unit alias.
      | Just (P.UnitAlias [Char]
name UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec = (UnitAliasMap -> UnitAliasMap) -> UnitSolver ()
modifyUnitAliasMap ([Char] -> UnitInfo -> UnitAliasMap -> UnitAliasMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
name (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST))
      | Bool
otherwise                                 = () -> UnitSolver ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        mSpec :: Maybe UnitStatement
mSpec = UnitAnnotation Annotation -> Maybe UnitStatement
forall a. UnitAnnotation a -> Maybe UnitStatement
UA.unitSpec (UA -> UnitAnnotation Annotation
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
        mPU :: Maybe (ProgramUnit UA)
mPU   = UnitAnnotation Annotation -> Maybe (ProgramUnit UA)
forall a.
UnitAnnotation a
-> Maybe (ProgramUnit (Analysis (UnitAnnotation a)))
UA.unitPU   (UA -> UnitAnnotation Annotation
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 [[Char]]
vars) UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec
      , Just Block UA
b                                       <- Maybe (Block UA)
mBlock = Maybe ProgramUnitName
-> UnitInfo -> Block UA -> [[Char]] -> UnitSolver ()
insertBlockUnitAssigns Maybe ProgramUnitName
pname (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST) Block UA
b [[Char]]
vars
      -- Add a new unit alias.
      | Just (P.UnitAlias [Char]
name UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec  = (UnitAliasMap -> UnitAliasMap) -> UnitSolver ()
modifyUnitAliasMap ([Char] -> UnitInfo -> UnitAliasMap -> UnitAliasMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
name (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST))
      | Bool
otherwise                                  = () -> UnitSolver ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      where
        mSpec :: Maybe UnitStatement
mSpec  = UnitAnnotation Annotation -> Maybe UnitStatement
forall a. UnitAnnotation a -> Maybe UnitStatement
UA.unitSpec  (UA -> UnitAnnotation Annotation
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
        mBlock :: Maybe (Block UA)
mBlock = UnitAnnotation Annotation -> Maybe (Block UA)
forall a.
UnitAnnotation a -> Maybe (Block (Analysis (UnitAnnotation a)))
UA.unitBlock (UA -> UnitAnnotation Annotation
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
    checkBlockComment Maybe ProgramUnitName
_ Block UA
_ = [Char] -> UnitSolver ()
forall a. HasCallStack => [Char] -> a
error [Char]
"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 -> [[Char]] -> 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)) [[Char]]
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 -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression UA
e, Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
srcName Expression UA
e), UnitInfo
info')
                         | e :: Expression UA
e@(F.ExpValue UA
_ SrcSpan
_ (F.ValVariable [Char]
_)) <- AList Declarator UA -> [Expression UA]
forall from to. Biplate from to => from -> [to]
universeBi AList Declarator UA
decls :: [F.Expression UA]
                         , [Char]
varRealName <- [[Char]]
varRealNames
                         , [Char]
varRealName [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
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
. [[Char]] -> GivenVarSet
forall a. Ord a => [a] -> Set a
S.fromList ([[Char]] -> GivenVarSet)
-> (VarUnitMap -> [[Char]]) -> VarUnitMap -> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VV -> [Char]) -> [VV] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map VV -> [Char]
forall a b. (a, b) -> a
fst ([VV] -> [[Char]])
-> (VarUnitMap -> [VV]) -> VarUnitMap -> [[Char]]
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
_ [[Char]]
_ = [Char] -> UnitSolver ()
forall a. HasCallStack => [Char] -> a
error [Char]
"received non-statement/declaration in insertBlockUnitAssigns"

    -- Insert unit annotation for function return variable
    insertPUUnitAssigns :: UnitInfo -> F.ProgramUnit UA -> [String] -> UnitSolver ()
    insertPUUnitAssigns :: UnitInfo -> ProgramUnit UA -> [[Char]] -> UnitSolver ()
insertPUUnitAssigns UnitInfo
info pu :: ProgramUnit UA
pu@(F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ [Char]
_ Maybe (AList Expression UA)
_ Maybe (Expression UA)
mret [Block UA]
_ Maybe [ProgramUnit UA]
_) [[Char]]
varRealNames
      | ([Char]
retUniq, [Char]
retSrc) <- case Maybe (Expression UA)
mret of Just Expression UA
ret -> (Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
FA.varName Expression UA
ret, Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
FA.srcName Expression UA
ret)
                                          Maybe (Expression UA)
Nothing  -> (ProgramUnit UA -> [Char]
puName ProgramUnit UA
pu, ProgramUnit UA -> [Char]
puSrcName ProgramUnit UA
pu)
      , [Char]
retSrc [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
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 [ (([Char]
retUniq, [Char]
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
. [[Char]] -> GivenVarSet
forall a. Ord a => [a] -> Set a
S.fromList ([[Char]] -> GivenVarSet)
-> (VarUnitMap -> [[Char]]) -> VarUnitMap -> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VV -> [Char]) -> [VV] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map VV -> [Char]
forall a b. (a, b) -> a
fst ([VV] -> [[Char]])
-> (VarUnitMap -> [VV]) -> VarUnitMap -> [[Char]]
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
_ [[Char]]
_ = [Char] -> UnitSolver ()
forall a. HasCallStack => [Char] -> a
error [Char]
"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 [Char]
_))
        | Just UnitInfo
info <- VV -> VarUnitMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression UA
e, Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
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 (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA)
annotateLiteralsPU)

annotateLiteralsPU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)
annotateLiteralsPU :: ProgramUnit UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA)
annotateLiteralsPU ProgramUnit UA
pu = do
  LiteralsOpt
mode <- (UnitEnv -> LiteralsOpt)
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) 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 (ReaderT UnitEnv (AnalysisT () () IO)) [Block UA])
-> ProgramUnit UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> [Block UA]
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *).
Applicative f =>
Expression UA -> f (Expression UA)
expUnitless) ProgramUnit UA
pu
    LiteralsOpt
LitPoly     -> ([Block UA]
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [Block UA])
-> ProgramUnit UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> [Block UA]
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *).
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
genParamLit)) ProgramUnit UA
pu
    LiteralsOpt
LitMixed    -> ([Block UA]
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [Block UA])
-> ProgramUnit UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> [Block UA]
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
expMixed) ProgramUnit UA
pu
  where
    -- Follow the LitMixed rules.
    expMixed :: Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
expMixed Expression UA
e = case Expression UA
e of
      F.ExpValue UA
_ SrcSpan
_ (F.ValInteger [Char]
i) | [Char] -> Maybe Integer
readInteger [Char]
i Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0 -> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *).
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
genParamLit Expression UA
e
                                      | Bool
otherwise               -> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *).
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
genUnitLiteral Expression UA
e
      F.ExpValue UA
_ SrcSpan
_ (F.ValReal [Char]
i) | [Char] -> Maybe Double
readReal [Char]
i Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double -> Maybe Double
forall a. a -> Maybe a
Just Double
0       -> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *).
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
genParamLit Expression UA
e
                                   | Bool
otherwise                  -> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *).
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) 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 (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 (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 (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e2)        -> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
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 (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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 (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
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 (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
genLit Expression UA
e
            Just UnitVar{}     -> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
genLit Expression UA
e
            Maybe UnitInfo
_                  -> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
        | Bool
otherwise                                             -> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
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 (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 (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 (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
genLit Expression UA
e
      | Expression UA -> Bool
isLiteralZero Expression UA
e = StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *).
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
genParamLit Expression UA
e
      | Bool
otherwise       = StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *).
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) 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 [Char]
_))    = Bool
True
isLiteral (F.ExpValue UA
_ SrcSpan
_ (F.ValInteger [Char]
_)) = 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 (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 [Char]
i)) = [Char] -> Maybe Integer
readInteger [Char]
i Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0
isLiteralNonZero (F.ExpValue UA
_ SrcSpan
_ (F.ValReal [Char]
i))    = [Char] -> Maybe Double
readReal [Char]
i    Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double -> Maybe Double
forall a. a -> Maybe a
Just Double
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 (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 [Char]
s)  -> [Char] -> Maybe Integer
readInteger [Char]
s Maybe Integer -> Maybe Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0
  Just (FA.ConstUninterpReal [Char]
s) -> [Char] -> Maybe Double
readReal [Char]
s Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double -> Maybe Double
forall a. a -> Maybe a
Just Double
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 :: Constraints -> Constraints
cullRedundant = Constraints -> Constraints
forall a. Eq a => [a] -> [a]
nub (Constraints -> Constraints)
-> (Constraints -> Constraints) -> Constraints -> Constraints
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> Maybe Constraint) -> Constraints -> Constraints
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 Constraints
cs | Constraints
cs' <- Constraints -> Constraints
cullRedundant Constraints
cs, Bool -> Bool
not (Constraints -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Constraints
cs) -> Constraint -> Maybe Constraint
forall a. a -> Maybe a
Just (Constraints -> Constraint
ConConj Constraints
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 :: Constraints -> UnitSolver Constraints
applyTemplates Constraints
cons = do
  [Char] -> Constraints -> UnitSolver ()
dumpConsM [Char]
"applyTemplates" Constraints
cons
  -- Get a list of the instances of parametric polymorphism from the constraints.
  let instances :: [([Char], Int)]
instances = [([Char], Int)] -> [([Char], Int)]
forall a. Eq a => [a] -> [a]
nub [ ([Char]
name, Int
i) | UnitParamPosUse (([Char]
name, [Char]
_), Int
_, Int
i) <- Constraints -> [UnitInfo]
forall from to. Biplate from to => from -> [to]
universeBi Constraints
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
  [([Char], Int)]
dummies <- [ProgramUnit UA]
-> (ProgramUnit UA
    -> StateT
         UnitState (ReaderT UnitEnv (AnalysisT () () IO)) ([Char], Int))
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [([Char], 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 (ReaderT UnitEnv (AnalysisT () () IO)) ([Char], Int))
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [([Char], Int)])
-> (ProgramUnit UA
    -> StateT
         UnitState (ReaderT UnitEnv (AnalysisT () () IO)) ([Char], Int))
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) [([Char], Int)]
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit UA
pu -> do
    Int
ident <- UnitSolver Int
freshId
    ([Char], Int)
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) ([Char], Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgramUnit UA -> [Char]
puName ProgramUnit UA
pu, Int
ident)

  ProgramFile UA -> 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
<> [([Char], Int)] -> Text
forall a. Show a => a -> Text
describeShow [([Char], Int)]
instances)
  ProgramFile UA -> 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
<> [([Char], Int)] -> Text
forall a. Show a => a -> Text
describeShow [([Char], Int)]
dummies)

  VarUnitMap
importedVariables <- UnitSolver VarUnitMap
getImportedVariables

  -- Prepare constraints for all variables imported via StUse.
  let importedCons :: Constraints
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.
  Constraints
concreteCons <- Constraints -> Constraints
cullRedundant (Constraints -> Constraints)
-> UnitSolver Constraints -> UnitSolver Constraints
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  (Constraints -> Constraints -> Constraints)
-> UnitSolver Constraints
-> UnitSolver Constraints
-> UnitSolver Constraints
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Constraints -> Constraints -> Constraints
forall a. [a] -> [a] -> [a]
(++) ((Constraints -> ([Char], Int) -> UnitSolver Constraints)
-> Constraints -> [([Char], Int)] -> UnitSolver Constraints
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> [[Char]]
-> Constraints
-> ([Char], Int)
-> UnitSolver Constraints
substInstance Bool
False []) Constraints
importedCons [([Char], Int)]
instances)
                              ((Constraints -> ([Char], Int) -> UnitSolver Constraints)
-> Constraints -> [([Char], Int)] -> UnitSolver Constraints
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> [[Char]]
-> Constraints
-> ([Char], Int)
-> UnitSolver Constraints
substInstance Bool
True []) [] [([Char], Int)]
dummies)
  [Char] -> Constraints -> UnitSolver ()
dumpConsM [Char]
"applyTemplates: concreteCons" Constraints
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 :: Constraints
aliases = [ UnitInfo -> UnitInfo -> Constraint
ConEq ([Char] -> UnitInfo
UnitAlias [Char]
name) UnitInfo
def | ([Char]
name, UnitInfo
def) <- UnitAliasMap -> [([Char], UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList UnitAliasMap
aliasMap ]
  let transAlias :: UnitInfo -> UnitInfo
transAlias (UnitName [Char]
a) | [Char]
a [Char] -> UnitAliasMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` UnitAliasMap
aliasMap = [Char] -> UnitInfo
UnitAlias [Char]
a
      transAlias UnitInfo
u                                    = UnitInfo
u

  [Char] -> Constraints -> UnitSolver ()
dumpConsM [Char]
"aliases" Constraints
aliases
  Constraints -> UnitSolver Constraints
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraints -> UnitSolver Constraints)
-> (Constraints -> Constraints)
-> Constraints
-> UnitSolver Constraints
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInfo -> UnitInfo) -> Constraints -> Constraints
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi UnitInfo -> UnitInfo
transAlias (Constraints -> Constraints)
-> (Constraints -> Constraints) -> Constraints -> Constraints
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraints -> Constraints
cullRedundant (Constraints -> UnitSolver Constraints)
-> Constraints -> UnitSolver Constraints
forall a b. (a -> b) -> a -> b
$ Constraints
cons Constraints -> Constraints -> Constraints
forall a. [a] -> [a] -> [a]
++ Constraints
concreteCons Constraints -> Constraints -> Constraints
forall a. [a] -> [a] -> [a]
++ Constraints
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
-> [[Char]]
-> Constraints
-> ([Char], Int)
-> UnitSolver Constraints
substInstance Bool
isDummy [[Char]]
callStack Constraints
output ([Char]
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
  Constraints
template <- (UnitInfo
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo)
-> Constraints -> UnitSolver Constraints
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM UnitInfo
-> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
callIdRemap (Constraints -> UnitSolver Constraints)
-> Constraints -> UnitSolver Constraints
forall a b. (a -> b) -> a -> b
$ Constraints
forall a. [a]
npc Constraints -> Maybe Constraints -> Constraints
forall a. a -> Maybe a -> a
`fromMaybe` [Char] -> TemplateMap -> Maybe Constraints
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
name TemplateMap
tmap
  [Char] -> Constraints -> UnitSolver ()
dumpConsM ([Char]
"substInstance " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
isDummy [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
callStack [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char], Int) -> [Char]
forall a. Show a => a -> [Char]
show ([Char]
name, Int
callId) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" template lookup") Constraints
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 :: [([Char], Int)]
instances = [([Char], Int)] -> [([Char], Int)]
forall a. Eq a => [a] -> [a]
nub [ ([Char]
name', Int
i) | UnitParamPosUse (([Char]
name', [Char]
_), Int
_, Int
i) <- Constraints -> [UnitInfo]
forall from to. Biplate from to => from -> [to]
universeBi Constraints
template ]
  Constraints
template' <- if [Char]
name [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
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.
                 Constraints -> UnitSolver Constraints
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
               else
                 (Constraints -> ([Char], Int) -> UnitSolver Constraints)
-> Constraints -> [([Char], Int)] -> UnitSolver Constraints
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> [[Char]]
-> Constraints
-> ([Char], Int)
-> UnitSolver Constraints
substInstance Bool
False ([Char]
name[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
callStack)) [] [([Char], Int)]
instances

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

  -- Convert abstract parametric units into concrete ones.

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

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

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

  Constraints -> UnitSolver Constraints
forall (f :: * -> *) a. Applicative f => a -> f a
pure Constraints
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 (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
callIdRemap UnitInfo
info = (CallIdMap -> UnitSolver (UnitInfo, CallIdMap))
-> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
forall a. (CallIdMap -> UnitSolver (a, CallIdMap)) -> UnitSolver a
modifyCallIdRemapM ((CallIdMap -> UnitSolver (UnitInfo, CallIdMap))
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo)
-> (CallIdMap -> UnitSolver (UnitInfo, CallIdMap))
-> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) 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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
                                          (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
                                          (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
                                          (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
                                          (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
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 (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 :: 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 :: 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
_ [Char]
_ [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 [Char]
_ [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 (f :: * -> *) a. Applicative f => a -> f a
pure ProgramUnit a
f
    topLevel s :: ProgramUnit a
s@F.PUSubroutine{}                = ProgramUnit a -> [ProgramUnit 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 Constraints
extractConstraints = do
  ProgramFile UA
pf         <- UnitSolver (ProgramFile UA)
getProgramFile
  Map [Char] (DeclContext, SrcSpan)
dmap       <- ReaderT
  UnitEnv (AnalysisT () () IO) (Map [Char] (DeclContext, SrcSpan))
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (Map [Char] (DeclContext, SrcSpan))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT
   UnitEnv (AnalysisT () () IO) (Map [Char] (DeclContext, SrcSpan))
 -> StateT
      UnitState
      (ReaderT UnitEnv (AnalysisT () () IO))
      (Map [Char] (DeclContext, SrcSpan)))
-> (AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
    -> ReaderT
         UnitEnv (AnalysisT () () IO) (Map [Char] (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (Map [Char] (DeclContext, SrcSpan))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
-> ReaderT
     UnitEnv (AnalysisT () () IO) (Map [Char] (DeclContext, SrcSpan))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
 -> StateT
      UnitState
      (ReaderT UnitEnv (AnalysisT () () IO))
      (Map [Char] (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map [Char] (DeclContext, SrcSpan))
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (Map [Char] (DeclContext, SrcSpan))
forall a b. (a -> b) -> a -> b
$ Map [Char] (DeclContext, SrcSpan)
-> Map [Char] (DeclContext, SrcSpan)
-> Map [Char] (DeclContext, SrcSpan)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (ProgramFile UA -> Map [Char] (DeclContext, SrcSpan)
forall a.
Data a =>
ProgramFile (Analysis a) -> Map [Char] (DeclContext, SrcSpan)
extractDeclMap ProgramFile UA
pf) (Map [Char] (DeclContext, SrcSpan)
 -> Map [Char] (DeclContext, SrcSpan))
-> (ModFiles -> Map [Char] (DeclContext, SrcSpan))
-> ModFiles
-> Map [Char] (DeclContext, SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModFiles -> Map [Char] (DeclContext, SrcSpan)
combinedDeclMap (ModFiles -> Map [Char] (DeclContext, SrcSpan))
-> AnalysisT () () IO ModFiles
-> AnalysisT () () IO (Map [Char] (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
  Constraints -> UnitSolver Constraints
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraints -> UnitSolver Constraints)
-> Constraints -> UnitSolver Constraints
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 -> Constraints
forall from to. Biplate from to => from -> [to]
universeBi Block UA
b ] Constraints -> Constraints -> Constraints
forall a. [a] -> [a] -> [a]
++
           [ UnitInfo -> UnitInfo -> Constraint
ConEq (Map [Char] (DeclContext, SrcSpan) -> VV -> UnitInfo
toUnitVar Map [Char] (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 [Char]
_ [Block a]
bs Maybe [ProgramUnit a]
_)   = [Block a]
bs
    getBlocks (F.PUModule a
_ SrcSpan
_ [Char]
_ [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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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
      (ReaderT UnitEnv (AnalysisT () () IO))
      (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
     (ReaderT UnitEnv (AnalysisT () () IO))
     (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
propagateExp

propagateExp :: F.Expression UA -> UnitSolver (F.Expression UA)
propagateExp :: Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
propagateExp Expression UA
e = case Expression UA
e of
  F.ExpValue{}                           -> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
propagateFunctionCall Expression UA
e
  F.ExpSubscript UA
_ SrcSpan
_ Expression UA
e1 AList Index UA
_                -> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
  Expression UA
_                                      -> do
    Expression UA -> 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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
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 (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 (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
propagateFunctionCall (F.ExpFunctionCall UA
a SrcSpan
s Expression UA
f Maybe (AList Argument UA)
Nothing)                     = do
  (UnitInfo
info, [Argument UA]
_) <- Expression UA
-> [Argument UA] -> UnitSolver (UnitInfo, [Argument UA])
callHelper Expression UA
f []
  let cons :: Constraints
cons = UnitInfo -> Expression UA -> [Any] -> Constraints
forall (t :: * -> *) a b.
Foldable t =>
UnitInfo -> Expression (Analysis a) -> t b -> Constraints
intrinsicHelper UnitInfo
info Expression UA
f []
  Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> (Expression UA -> Expression UA)
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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 (Constraints -> Constraint
ConConj Constraints
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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall a b. (a -> b) -> a -> b
$ UA
-> SrcSpan
-> Expression UA
-> Maybe (AList Argument UA)
-> Expression UA
forall a.
a
-> SrcSpan
-> Expression a
-> Maybe (AList Argument a)
-> Expression a
F.ExpFunctionCall UA
a SrcSpan
s Expression UA
f Maybe (AList Argument UA)
forall a. Maybe a
Nothing
propagateFunctionCall (F.ExpFunctionCall UA
a SrcSpan
s Expression UA
f (Just (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 :: Constraints
cons = UnitInfo -> Expression UA -> [Argument UA] -> Constraints
forall (t :: * -> *) a b.
Foldable t =>
UnitInfo -> Expression (Analysis a) -> t b -> Constraints
intrinsicHelper UnitInfo
info Expression UA
f [Argument UA]
args'
  Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> (Expression UA -> Expression UA)
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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 (Constraints -> Constraint
ConConj Constraints
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 (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA))
-> Expression UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall a b. (a -> b) -> a -> b
$ UA
-> SrcSpan
-> Expression UA
-> Maybe (AList Argument UA)
-> Expression UA
forall a.
a
-> SrcSpan
-> Expression a
-> Maybe (AList Argument a)
-> Expression a
F.ExpFunctionCall UA
a SrcSpan
s Expression UA
f (AList Argument UA -> Maybe (AList Argument UA)
forall a. a -> Maybe a
Just (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
_ = [Char]
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Expression UA)
forall a. HasCallStack => [Char] -> a
error [Char]
"received non-function-call in propagateFunctionCall"

propagateDoSpec :: F.DoSpecification UA -> UnitSolver (F.DoSpecification UA)
propagateDoSpec :: DoSpecification UA
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (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
     (ReaderT UnitEnv (AnalysisT () () IO))
     (DoSpecification UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DoSpecification UA
 -> StateT
      UnitState
      (ReaderT UnitEnv (AnalysisT () () IO))
      (DoSpecification UA))
-> (Maybe Constraint -> DoSpecification UA)
-> Maybe Constraint
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (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
      (ReaderT UnitEnv (AnalysisT () () IO))
      (DoSpecification UA))
-> Maybe Constraint
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (DoSpecification UA)
forall a b. (a -> b) -> a -> b
$ Constraints -> Constraint
ConConj (Constraints -> Constraint)
-> Maybe Constraints -> Maybe Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe Constraints] -> Maybe Constraints
forall a. Monoid a => [a] -> a
mconcat [
        -- units(e1) ~ units(e2)
        (Constraint -> Constraints -> Constraints
forall a. a -> [a] -> [a]
:[]) (Constraint -> Constraints)
-> Maybe Constraint -> Maybe Constraints
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 (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` if UnitInfo -> Bool
isMonomorphic UnitInfo
u1 then Maybe UnitInfo
forall (m :: * -> *) a. MonadPlus m => m a
mzero else UnitInfo -> Maybe UnitInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnitInfo
UnitlessVar
             Constraints -> Maybe Constraints
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 (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` if UnitInfo -> Bool
isMonomorphic UnitInfo
u2 then Maybe UnitInfo
forall (m :: * -> *) a. MonadPlus m => m a
mzero else UnitInfo -> Maybe UnitInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnitInfo
UnitlessVar
             Constraints -> Maybe Constraints
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u2 UnitInfo
u3]
        ]
propagateDoSpec DoSpecification UA
_ = [Char]
-> StateT
     UnitState
     (ReaderT UnitEnv (AnalysisT () () IO))
     (DoSpecification UA)
forall a. HasCallStack => [Char] -> a
error [Char]
"propagateDoSpec: called on invalid DoSpec"

propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA)
propagateStatement :: Statement UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (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 (Just (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 :: Constraints
cons = UnitInfo -> Expression UA -> [Argument UA] -> Constraints
forall (t :: * -> *) a b.
Foldable t =>
UnitInfo -> Expression (Analysis a) -> t b -> Constraints
intrinsicHelper UnitInfo
info Expression UA
sub [Argument UA]
args'
    Statement UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Statement UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Statement UA))
-> (Statement UA -> Statement UA)
-> Statement UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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 (Constraints -> Constraint
ConConj Constraints
cons) (Statement UA
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Statement UA))
-> Statement UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Statement UA)
forall a b. (a -> b) -> a -> b
$ UA
-> SrcSpan
-> Expression UA
-> Maybe (AList Argument UA)
-> Statement UA
forall a.
a
-> SrcSpan
-> Expression a
-> Maybe (AList Argument a)
-> Statement a
F.StCall UA
a SrcSpan
s Expression UA
sub (AList Argument UA -> Maybe (AList Argument UA)
forall a. a -> Maybe a
Just (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Declarator UA))
-> Statement UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Statement UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Declarator UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Declarator UA)
propagateDeclarator Statement UA
stmt
  Statement UA
_                                            -> Statement UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Statement UA)
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 (ReaderT UnitEnv (AnalysisT () () IO)) (Declarator UA)
propagateDeclarator Declarator UA
decl = case Declarator UA
decl of
  F.DeclVariable UA
_ SrcSpan
_ Expression UA
e1 Maybe (Expression UA)
_ (Just Expression UA
e2) -> Expression UA
-> Expression UA
-> Declarator UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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
  F.DeclArray UA
_ SrcSpan
_ Expression UA
e1 AList DimensionDeclarator UA
_ Maybe (Expression UA)
_ (Just Expression UA
e2)  -> Expression UA
-> Expression UA
-> Declarator UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Declarator UA)
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 :: 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 -> UnitSolver (f UA)
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 -> UnitSolver (f UA)
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 -> UnitSolver (f UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f UA -> UnitSolver (f UA)) -> f UA -> UnitSolver (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 (ReaderT UnitEnv (AnalysisT () () IO)) (Block UA)
propagateInterface b :: Block UA
b@(F.BlInterface UA
_ SrcSpan
_ (Just Expression UA
e) Bool
_ [ProgramUnit UA]
_ [Block UA]
bs) = do
  let iname :: [Char]
iname = Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression UA
e
  case [ Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
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
    [Char]
mpname:[[Char]]
_ -> do
      -- translate any instance of mpname into iname within the template
      let trans :: Constraints -> Constraints
trans = ([Char] -> [Char]) -> Constraints -> Constraints
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (\ [Char]
x -> if [Char]
x [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
mpname then [Char]
iname else [Char]
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 ((\ Constraints
t -> [Char] -> Constraints -> TemplateMap -> TemplateMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
iname (Constraints -> Constraints
trans Constraints
t) TemplateMap
m) (Constraints -> TemplateMap)
-> Maybe Constraints -> Maybe TemplateMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> TemplateMap -> Maybe Constraints
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
mpname TemplateMap
m)
    [[Char]]
_        ->
      () -> UnitSolver ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Block UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Block UA)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block UA
b

propagateInterface Block UA
b = Block UA
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) (Block UA)
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 (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA)
propagatePU ProgramUnit UA
pu = do
  let name :: [Char]
name     = ProgramUnit UA -> [Char]
puName ProgramUnit UA
pu
  let sname :: [Char]
sname    = ProgramUnit UA -> [Char]
puSrcName ProgramUnit UA
pu
  let nn :: VV
nn       = ([Char]
name, [Char]
sname)
  let bodyCons :: Constraints
bodyCons = [ Constraint
con | con :: Constraint
con@ConEq{} <- ProgramUnit UA -> Constraints
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.
  Constraints
givenCons <- [(Int, VV)]
-> ((Int, VV)
    -> StateT
         UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint)
-> UnitSolver Constraints
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 (ReaderT UnitEnv (AnalysisT () () IO)) Constraint)
 -> UnitSolver Constraints)
-> ((Int, VV)
    -> StateT
         UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint)
-> UnitSolver Constraints
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 (ReaderT UnitEnv (AnalysisT () () IO)) Constraint
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint)
-> (UnitInfo -> Constraint)
-> UnitInfo
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) 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 (ReaderT UnitEnv (AnalysisT () () IO)) Constraint)
-> UnitInfo
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint
forall a b. (a -> b) -> a -> b
$ (VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
i)
      Just UnitInfo
u                    -> Constraint
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint)
-> (UnitInfo -> Constraint)
-> UnitInfo
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u (UnitInfo
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint)
-> UnitInfo
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint
forall a b. (a -> b) -> a -> b
$ (VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
i)
      Maybe UnitInfo
_                         -> Constraint
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint
 -> StateT
      UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint)
-> (UnitInfo -> Constraint)
-> UnitInfo
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) 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 (ReaderT UnitEnv (AnalysisT () () IO)) Constraint)
-> UnitInfo
-> StateT
     UnitState (ReaderT UnitEnv (AnalysisT () () IO)) Constraint
forall a b. (a -> b) -> a -> b
$ (VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
i)

  let cons :: Constraints
cons = Constraints
givenCons Constraints -> Constraints -> Constraints
forall a. [a] -> [a] -> [a]
++ Constraints
bodyCons
  case ProgramUnit UA
pu of F.PUFunction {}   -> (TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap ([Char] -> Constraints -> TemplateMap -> TemplateMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
name Constraints
cons)
             F.PUSubroutine {} -> (TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap ([Char] -> Constraints -> TemplateMap -> TemplateMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
name Constraints
cons)
             ProgramUnit UA
_                 -> () -> UnitSolver ()
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 (ReaderT UnitEnv (AnalysisT () () IO)) (ProgramUnit UA)
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 (Constraints -> Constraint
ConConj Constraints
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 -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression UA
nexp, Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
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 (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 (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 [Char]
_ Expression UA
e)
        -- add site-specific parametric constraints to each argument
        | Just UnitInfo
u <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression 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 (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 :: UnitInfo -> Expression (Analysis a) -> t b -> Constraints
intrinsicHelper (UnitParamPosUse (VV
_, Int
_, Int
callId)) f :: Expression (Analysis a)
f@(F.ExpValue Analysis a
_ SrcSpan
_ (F.ValIntrinsic [Char]
_)) t b
args
  | Just (UnitInfo
retU, [UnitInfo]
argUs) <- [Char] -> Maybe (UnitInfo, [UnitInfo])
intrinsicLookup [Char]
sname = (Int -> UnitInfo -> Constraint)
-> [Int] -> [UnitInfo] -> Constraints
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 (t :: * -> *) a. Foldable t => t a -> Int
length t b
args
    sname :: [Char]
sname       = Expression (Analysis a) -> [Char]
forall a. Expression (Analysis a) -> [Char]
srcName Expression (Analysis a)
f
    vname :: [Char]
vname       = Expression (Analysis a) -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression (Analysis a)
f
    eachArg :: Int -> UnitInfo -> Constraint
eachArg Int
i UnitInfo
u = UnitInfo -> UnitInfo -> Constraint
ConEq ((VV, Int, Int) -> UnitInfo
UnitParamPosUse (([Char]
vname, [Char]
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 :: [Char] -> Maybe (UnitInfo, [UnitInfo])
intrinsicLookup [Char]
sname = do
  (UnitInfo
retU, [UnitInfo]
argUs) <- [Char]
-> Map [Char] (UnitInfo, [UnitInfo])
-> Maybe (UnitInfo, [UnitInfo])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
sname Map [Char] (UnitInfo, [UnitInfo])
intrinsicUnits
  (UnitInfo, [UnitInfo]) -> Maybe (UnitInfo, [UnitInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfo
retU, if [Char]
sname [Char] -> GivenVarSet -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` GivenVarSet
specialCaseArbitraryArgs then [UnitInfo] -> [UnitInfo]
forall a. [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 (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
genUnitLiteral = Int -> UnitInfo
UnitLiteral (Int -> UnitInfo)
-> UnitSolver Int
-> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) 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 (ReaderT UnitEnv (AnalysisT () () IO)) UnitInfo
genParamLit = Int -> UnitInfo
UnitParamLitAbs (Int -> UnitInfo)
-> UnitSolver Int
-> StateT UnitState (ReaderT UnitEnv (AnalysisT () () IO)) 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 :: ([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 [Char]
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 (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 [Char]
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> Maybe [Char]
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUMain a
a SrcSpan
s Maybe [Char]
n [Block a]
b' Maybe [ProgramUnit a]
pus
  F.PUModule a
a SrcSpan
s [Char]
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 (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
-> [Char]
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> [Char]
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUModule a
a SrcSpan
s [Char]
n [Block a]
b' Maybe [ProgramUnit a]
pus
  F.PUSubroutine a
a SrcSpan
s PrefixSuffix a
r [Char]
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 (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
-> [Char]
-> Maybe (AList Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> PrefixSuffix a
-> [Char]
-> Maybe (AList Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUSubroutine a
a SrcSpan
s PrefixSuffix a
r [Char]
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 [Char]
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 (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
-> [Char]
-> Maybe (AList Expression a)
-> Maybe (Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> Maybe (TypeSpec a)
-> PrefixSuffix a
-> [Char]
-> 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 [Char]
n Maybe (AList Expression a)
p Maybe (Expression a)
res [Block a]
b' Maybe [ProgramUnit a]
subs
  F.PUBlockData  a
a SrcSpan
s Maybe [Char]
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 (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 [Char] -> [Block a] -> ProgramUnit a
forall a.
a -> SrcSpan -> Maybe [Char] -> [Block a] -> ProgramUnit a
F.PUBlockData  a
a SrcSpan
s Maybe [Char]
n [Block a]
b'
  F.PUComment {}                          -> ProgramUnit a -> m (ProgramUnit 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 :: 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 [Char]
i))        -> Integer -> FNum
FInt (Integer -> FNum) -> Maybe Integer -> Maybe FNum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe Integer
readInteger [Char]
i
      (F.ExpValue a
_ SrcSpan
_ (F.ValReal [Char]
r))           -> Double -> FNum
FReal (Double -> FNum) -> Maybe Double -> Maybe FNum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe Double
readReal [Char]
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
/= :: BinOpKind -> BinOpKind -> Bool
$c/= :: BinOpKind -> BinOpKind -> Bool
== :: BinOpKind -> BinOpKind -> Bool
$c== :: 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 [Char]
_)    = 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) -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression (Analysis a)
e, Expression (Analysis a) -> [Char]
forall a. Expression (Analysis a) -> [Char]
srcName Expression (Analysis a)
e)
      useToPair (F.UseRename Analysis a
_ SrcSpan
_ Expression (Analysis a)
e1 Expression (Analysis a)
_) = (Expression (Analysis a) -> [Char]
forall a. Expression (Analysis a) -> [Char]
varName Expression (Analysis a)
e1, Expression (Analysis a) -> [Char]
forall a. Expression (Analysis a) -> [Char]
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 :: [Char]
mod = Expression UA -> [Char]
forall a. Expression (Analysis a) -> [Char]
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 ([Char] -> ProgramUnitName
F.Named [Char]
mod) NameParamMap
nmap]
                 , let f :: (NameParamKey, b) -> Maybe (NameParamKey, b)
f (NameParamKey
npk, b
ui) = case NameParamKey
npk of
                         (NPKVariable ([Char]
var, [Char]
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 ([Char]
var, [Char]
src [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
`fromMaybe` [Char] -> [VV] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
var [VV]
uses), b
ui)
                           -- only import variable mentioned in uses
                           | Just [Char]
src' <- [Char] -> [VV] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
var [VV]
uses -> (NameParamKey, b) -> Maybe (NameParamKey, b)
forall a. a -> Maybe a
Just (VV -> NameParamKey
NPKVariable ([Char]
var, [Char]
src'), b
ui)
                         NameParamKey
_ -> Maybe (NameParamKey, b)
forall a. Maybe a
Nothing
                 ]
  VarUnitMap -> UnitSolver VarUnitMap
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 e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' ProgramFile UA
pf Text
msg

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

debugLogging :: UnitSolver ()
debugLogging :: UnitSolver ()
debugLogging = do
    (Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> (Constraints -> Text) -> Constraints -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. Describe a => a -> Text
describe ([Char] -> Text) -> (Constraints -> [Char]) -> Constraints -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> [Char])
-> (Constraints -> [[Char]]) -> Constraints -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> [Char]) -> Constraints -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> [Char]
"  ***AbsConstraint: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" === " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2))) (Constraints -> UnitSolver ())
-> UnitSolver Constraints -> UnitSolver ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UnitSolver Constraints
extractConstraints
    ProgramFile UA
pf   <- UnitSolver (ProgramFile UA)
getProgramFile
    Constraints
cons <- UnitSolver Constraints
getConstraints
    VarUnitMap
vum  <- UnitSolver VarUnitMap
getVarUnitMap
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([[Char]] -> Text) -> [[Char]] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. Describe a => a -> Text
describe ([Char] -> Text) -> ([[Char]] -> [Char]) -> [[Char]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> UnitSolver ()) -> [[Char]] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ [ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ UnitInfo -> [Char]
forall a. Show a => a -> [Char]
show UnitInfo
info [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
n | (([Char]
n, [Char]
_), 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 ())
-> ([[Char]] -> Text) -> [[Char]] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. Describe a => a -> Text
describe ([Char] -> Text) -> ([[Char]] -> [Char]) -> [[Char]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> UnitSolver ()) -> [[Char]] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ [ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ UnitInfo -> [Char]
forall a. Show a => a -> [Char]
show UnitInfo
info | ([Char]
n, UnitInfo
info) <- UnitAliasMap -> [([Char], UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList UnitAliasMap
uam ]
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([[Char]] -> Text) -> [[Char]] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. Describe a => a -> Text
describe ([Char] -> Text) -> ([[Char]] -> [Char]) -> [[Char]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> UnitSolver ()) -> [[Char]] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (Constraint -> [Char]) -> Constraints -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> [Char]
"  ***Constraint: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" === " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) Constraints
cons
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Constraints -> Text
forall a. Show a => a -> Text
describeShow Constraints
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 Constraints
con) <- ProgramUnit UA -> Maybe Constraint
forall (f :: * -> *). Annotated f => f UA -> Maybe Constraint
UA.getConstraint ProgramUnit UA
pu ->
          Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([[Char]] -> Text) -> [[Char]] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. Describe a => a -> Text
describe ([Char] -> Text) -> ([[Char]] -> [Char]) -> [[Char]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> UnitSolver ()) -> [[Char]] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (ProgramUnit UA -> [Char]
puName ProgramUnit UA
pu [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":")[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:(Constraint -> [Char]) -> Constraints -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> [Char]
"    constraint: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" === " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) Constraints
con
      F.PUSubroutine {}
        | Just (ConConj Constraints
con) <- ProgramUnit UA -> Maybe Constraint
forall (f :: * -> *). Annotated f => f UA -> Maybe Constraint
UA.getConstraint ProgramUnit UA
pu ->
          Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([[Char]] -> Text) -> [[Char]] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. Describe a => a -> Text
describe ([Char] -> Text) -> ([[Char]] -> [Char]) -> [[Char]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> UnitSolver ()) -> [[Char]] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (ProgramUnit UA -> [Char]
puName ProgramUnit UA
pu [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":")[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:(Constraint -> [Char]) -> Constraints -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> [Char]
"    constraint: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" === " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) Constraints
con
      ProgramUnit UA
_ -> () -> UnitSolver ()
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) = Constraints
-> (Matrix Double, Matrix Double, [Int], Array Int UnitInfo,
    Array Int UnitInfo)
constraintsToMatrices Constraints
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
$ [Char] -> Text
forall a. Describe a => a -> Text
describe ([Char] -> Text)
-> ([(Int, UnitInfo)] -> [Char]) -> [(Int, UnitInfo)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> [Char])
-> ([(Int, UnitInfo)] -> [[Char]]) -> [(Int, UnitInfo)] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, UnitInfo) -> [Char]) -> [(Int, UnitInfo)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Int, UnitInfo) -> [Char]
forall a. Show a => a -> [Char]
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 = Constraints -> [([UnitInfo], UnitInfo)]
genUnitAssignments Constraints
cons
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([[Char]] -> Text) -> [[Char]] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. Describe a => a -> Text
describe ([Char] -> Text) -> ([[Char]] -> [Char]) -> [[Char]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> UnitSolver ()) -> [[Char]] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (([UnitInfo], UnitInfo) -> [Char])
-> [([UnitInfo], UnitInfo)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ ([UnitInfo]
u1s, UnitInfo
u2) -> [Char]
"  ***UnitAssignment: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show [UnitInfo]
u1s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" === " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n") [([UnitInfo], UnitInfo)]
unitAssignments
    Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------"
    let unitAssignmentsSBV :: [(UnitInfo, UnitInfo)]
unitAssignmentsSBV = Constraints -> [(UnitInfo, UnitInfo)]
BackendSBV.genUnitAssignments Constraints
cons
    Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([[Char]] -> Text) -> [[Char]] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
forall a. Describe a => a -> Text
describe ([Char] -> Text) -> ([[Char]] -> [Char]) -> [[Char]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> UnitSolver ()) -> [[Char]] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ ((UnitInfo, UnitInfo) -> [Char])
-> [(UnitInfo, UnitInfo)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (UnitInfo
u1s, UnitInfo
u2) -> [Char]
"  ***UnitAssignmentSBV: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ UnitInfo -> [Char]
forall a. Show a => a -> [Char]
show UnitInfo
u1s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" === " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char]
puName ProgramUnit UA
pu
  | F.Named [Char]
n <- ProgramUnit UA -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
FA.puName ProgramUnit UA
pu = [Char]
n
  | Bool
otherwise                 = [Char]
"_nameless"

puSrcName :: F.ProgramUnit UA -> F.Name
puSrcName :: ProgramUnit UA -> [Char]
puSrcName ProgramUnit UA
pu
  | F.Named [Char]
n <- ProgramUnit UA -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
FA.puSrcName ProgramUnit UA
pu = [Char]
n
  | Bool
otherwise                    = [Char]
"_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 = [[Char]] -> GivenVarSet
forall a. Ord a => [a] -> Set a
S.fromList [ [Char]
"max", [Char]
"max0", [Char]
"amax1", [Char]
"dmax1", [Char]
"amax0", [Char]
"max1"
                                      , [Char]
"min", [Char]
"min0", [Char]
"amin1", [Char]
"dmin1", [Char]
"amin0", [Char]
"min1" ]

-- | Intrinsics table: name => (return-unit, parameter-units). See also 'specialCaseArbitraryArgs'.
intrinsicUnits :: M.Map F.Name (UnitInfo, [UnitInfo])
intrinsicUnits :: Map [Char] (UnitInfo, [UnitInfo])
intrinsicUnits =
  [([Char], (UnitInfo, [UnitInfo]))]
-> Map [Char] (UnitInfo, [UnitInfo])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
    [ ([Char]
"transfer", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'b", [Char]
"'b"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'b", [Char]
"'b")]))
    , ([Char]
"abs", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"iabs", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"dabs", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"cabs", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"aimag", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"aint", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"dint", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"anint", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"dnint", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"cmplx", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"conjg", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"dble", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"dim", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"idim", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"ddim", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"dprod", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"ceiling", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"floor", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"int", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"ifix", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"idint", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"maxval", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"minval", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"max", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))   -- special case: arbitrary # of parameters
    , ([Char]
"min", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))   -- special case: arbitrary # of parameters
    , ([Char]
"min0", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))  -- special case: arbitrary # of parameters
    , ([Char]
"amin1", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")])) -- special case: arbitrary # of parameters
    , ([Char]
"dmin1", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")])) -- special case: arbitrary # of parameters
    , ([Char]
"amin0", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")])) -- special case: arbitrary # of parameters
    , ([Char]
"min1", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))  -- special case: arbitrary # of parameters
    , ([Char]
"mod", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'b", [Char]
"'b")]))
    , ([Char]
"modulo", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'b", [Char]
"'b")]))
    , ([Char]
"amod", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'b", [Char]
"'b")]))
    , ([Char]
"dmod", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'b", [Char]
"'b")]))
    , ([Char]
"nint", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"real", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"float", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"sngl", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"sign", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'b", [Char]
"'b")]))
    , ([Char]
"isign", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'b", [Char]
"'b")]))
    , ([Char]
"dsign", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'b", [Char]
"'b")]))
    , ([Char]
"present", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [UnitInfo
UnitlessVar]))
    , ([Char]
"sqrt", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [UnitInfo -> Double -> UnitInfo
UnitPow (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")) Double
2]))
    , ([Char]
"dsqrt", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [UnitInfo -> Double -> UnitInfo
UnitPow (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")) Double
2]))
    , ([Char]
"csqrt", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [UnitInfo -> Double -> UnitInfo
UnitPow (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")) Double
2]))
    , ([Char]
"exp", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dexp", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"cexp", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"alog", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dlog", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"clog", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"alog10", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dlog10", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"sin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dsin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"csin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"cos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dcos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"ccos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"tan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dtan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"asin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dasin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"acos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dacos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"atan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"datan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"atan2", (UnitInfo
UnitlessVar, [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"datan2", (UnitInfo
UnitlessVar, [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a")]))
    , ([Char]
"sinh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dsinh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"cosh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dcosh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"tanh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"dtanh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
    , ([Char]
"iand", (VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), [VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'a"), VV -> UnitInfo
UnitParamEAPAbs ([Char]
"'a", [Char]
"'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 Annotation -> IO ModFile
compileUnits UnitOpts
uo ModFiles
mfs ProgramFile Annotation
pf = do
  let (ProgramFile UA
pf', ModuleMap
_, TypeEnv
_) = ModFiles
-> ProgramFile (UnitAnnotation Annotation)
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall a.
Data a =>
ModFiles
-> ProgramFile a -> (ProgramFile (Analysis a), ModuleMap, TypeEnv)
withCombinedEnvironment ModFiles
mfs (ProgramFile (UnitAnnotation Annotation)
 -> (ProgramFile UA, ModuleMap, TypeEnv))
-> (ProgramFile Annotation
    -> ProgramFile (UnitAnnotation Annotation))
-> ProgramFile Annotation
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Annotation -> UnitAnnotation Annotation)
-> ProgramFile Annotation
-> ProgramFile (UnitAnnotation Annotation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotation -> UnitAnnotation Annotation
forall a. a -> UnitAnnotation a
UA.mkUnitAnnotation (ProgramFile Annotation -> (ProgramFile UA, ModuleMap, TypeEnv))
-> ProgramFile Annotation -> (ProgramFile UA, ModuleMap, TypeEnv)
forall a b. (a -> b) -> a -> b
$ ProgramFile Annotation
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 -> ProgramFile Annotation -> UnitEnv
UnitEnv
        { unitOpts :: UnitOpts
unitOpts = UnitOpts
uo
        , unitProgramFile :: ProgramFile Annotation
unitProgramFile = ProgramFile Annotation
pf
        }

  AnalysisReport () () (CompiledUnits, UnitState)
report <- [Char]
-> LogOutput IO
-> LogLevel
-> ModFiles
-> AnalysisT () () IO (CompiledUnits, UnitState)
-> IO (AnalysisReport () () (CompiledUnits, UnitState))
forall (m :: * -> *) e w a.
(Monad m, Describe e, Describe w) =>
[Char]
-> LogOutput m
-> LogLevel
-> ModFiles
-> AnalysisT e w m a
-> m (AnalysisReport e w a)
runAnalysisT (ProgramFile Annotation -> [Char]
forall a. ProgramFile a -> [Char]
F.pfGetFilename ProgramFile Annotation
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.
Lens
  (AnalysisReport e w r1)
  (AnalysisReport e w r2)
  (AnalysisResult e r1)
  (AnalysisResult e 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.
Prism (AnalysisResult e r2) (AnalysisResult e r1) r2 r1
_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
_1 of
    Just CompiledUnits
cu -> ModFile -> IO ModFile
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgramFile UA -> CompiledUnits -> ModFile
genUnitsModFile ProgramFile UA
pf' CompiledUnits
cu)
    Maybe CompiledUnits
Nothing -> [Char] -> IO ModFile
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"compileUnits: units analysis failed"