{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Camfort.Specification.Units.Analysis
( UnitAnalysis
, compileUnits
, initInference
, runInference
, runUnitAnalysis
, puName
, puSrcName
) where
import Camfort.Analysis
import Camfort.Analysis.Annotations (Annotation)
import Camfort.Analysis.CommentAnnotator (annotateComments)
import Camfort.Analysis.Logger (LogLevel(..))
import Camfort.Analysis.ModFile (withCombinedEnvironment)
import qualified Camfort.Specification.Units.Annotation as UA
import Camfort.Specification.Units.Environment
import Camfort.Specification.Units.InferenceBackend
import qualified Camfort.Specification.Units.InferenceBackendFlint as Flint
import qualified Camfort.Specification.Units.InferenceBackendSBV as BackendSBV
import Camfort.Specification.Units.ModFile
(genUnitsModFile, initializeModFiles, runCompileUnits)
import Camfort.Specification.Units.Monad
import Camfort.Specification.Units.MonadTypes
import Camfort.Specification.Units.Parser (unitParser)
import qualified Camfort.Specification.Units.Parser.Types as P
import Control.Lens ((^?), _1)
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Writer.Lazy
import qualified Data.Array as A
import Data.Data (Data)
import Data.Generics.Uniplate.Operations
import qualified Data.IntMap.Strict as IM
import Data.List (nub, intercalate)
import qualified Data.Map.Strict as M
import Data.Maybe (isJust, fromMaybe, mapMaybe)
import qualified Data.Set as S
import Data.Text (Text)
import qualified Language.Fortran.AST as F
import Language.Fortran.Analysis (constExp, varName, srcName)
import qualified Language.Fortran.Analysis as FA
import qualified Language.Fortran.Analysis.SemanticTypes as FAS
import qualified Language.Fortran.Analysis.BBlocks as FAB
import qualified Language.Fortran.Analysis.DataFlow as FAD
import Language.Fortran.AST.Literal.Real (readRealLit, parseRealLit)
import Language.Fortran.Util.ModFile
import qualified Numeric.LinearAlgebra as H
import Prelude hiding (mod)
initInference :: UnitSolver ()
initInference :: UnitSolver ()
initInference = do
ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile
let (ProgramFile UA
linkedPF, Name
_) =
Writer Name (ProgramFile UA) -> (ProgramFile UA, Name)
forall w a. Writer w a -> (a, w)
runWriter (Writer Name (ProgramFile UA) -> (ProgramFile UA, Name))
-> Writer Name (ProgramFile UA) -> (ProgramFile UA, Name)
forall a b. (a -> b) -> a -> b
$ SpecParser UnitParseError UnitStatement
-> (SrcSpan
-> SpecParseError UnitParseError -> WriterT Name Identity ())
-> ProgramFile UA
-> Writer Name (ProgramFile UA)
forall (m :: * -> *) e a ast.
(Monad m, Data a, Linkable a, ASTEmbeddable a ast) =>
SpecParser e ast
-> (SrcSpan -> SpecParseError e -> m ())
-> ProgramFile a
-> m (ProgramFile a)
annotateComments SpecParser UnitParseError UnitStatement
unitParser
(\SrcSpan
srcSpan SpecParseError UnitParseError
err -> Name -> WriterT Name Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Name -> WriterT Name Identity ())
-> Name -> WriterT Name Identity ()
forall a b. (a -> b) -> a -> b
$ Name
"Error " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
srcSpan Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
": " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ SpecParseError UnitParseError -> Name
forall a. Show a => a -> Name
show SpecParseError UnitParseError
err) ProgramFile UA
pf
(ProgramFile UA -> ProgramFile UA) -> UnitSolver ()
modifyProgramFile ((ProgramFile UA -> ProgramFile UA) -> UnitSolver ())
-> (ProgramFile UA -> ProgramFile UA) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ ProgramFile UA -> ProgramFile UA -> ProgramFile UA
forall a b. a -> b -> a
const ProgramFile UA
linkedPF
UnitSolver ()
insertGivenUnits
UnitSolver ()
insertParametricUnits
UnitSolver ()
insertUndeterminedUnits
UnitSolver ()
annotateAllVariables
UnitSolver ()
annotateLiterals
UnitSolver ()
propagateUnits
[Constraint]
abstractCons <- UnitSolver [Constraint]
extractConstraints
Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"***abstractCons" [Constraint]
abstractCons
[Constraint]
cons <- [Constraint] -> UnitSolver [Constraint]
applyTemplates [Constraint]
abstractCons
Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"***concreteCons" [Constraint]
cons
(ProgramFile UA -> ProgramFile UA) -> UnitSolver ()
modifyProgramFile ProgramFile UA -> ProgramFile UA
UA.cleanLinks
([Constraint] -> [Constraint]) -> UnitSolver ()
modifyConstraints ([Constraint] -> [Constraint] -> [Constraint]
forall a b. a -> b -> a
const [Constraint]
cons)
UnitSolver ()
debugLogging
runInference :: UnitSolver a -> UnitAnalysis (a, UnitState)
runInference :: forall a. UnitSolver a -> UnitAnalysis (a, UnitState)
runInference UnitSolver a
solver = do
ProgramFile A
pf <- (UnitEnv -> ProgramFile A)
-> ReaderT UnitEnv (AnalysisT () () IO) (ProgramFile A)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks UnitEnv -> ProgramFile A
unitProgramFile
ModFiles
mfs <- AnalysisT () () IO ModFiles
-> ReaderT UnitEnv (AnalysisT () () IO) ModFiles
forall (m :: * -> *) a. Monad m => m a -> ReaderT UnitEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift AnalysisT () () IO ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
let (ProgramFile UA
pf', ModuleMap
_, TypeEnv
_) = ModFiles
-> ProgramFile (UnitAnnotation A)
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall a.
Data a =>
ModFiles
-> ProgramFile a -> (ProgramFile (Analysis a), ModuleMap, TypeEnv)
withCombinedEnvironment ModFiles
mfs (ProgramFile (UnitAnnotation A)
-> (ProgramFile UA, ModuleMap, TypeEnv))
-> (ProgramFile A -> ProgramFile (UnitAnnotation A))
-> ProgramFile A
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (A -> UnitAnnotation A)
-> ProgramFile A -> ProgramFile (UnitAnnotation A)
forall a b. (a -> b) -> ProgramFile a -> ProgramFile b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap A -> UnitAnnotation A
forall a. a -> UnitAnnotation a
UA.mkUnitAnnotation (ProgramFile A -> (ProgramFile UA, ModuleMap, TypeEnv))
-> ProgramFile A -> (ProgramFile UA, ModuleMap, TypeEnv)
forall a b. (a -> b) -> a -> b
$ ProgramFile A
pf
let pvm :: ParamVarMap
pvm = ModFiles -> ParamVarMap
combinedParamVarMap ModFiles
mfs
let pf'' :: ProgramFile UA
pf'' = ProgramFile UA -> ProgramFile UA
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
FAD.analyseConstExps (ProgramFile UA -> ProgramFile UA)
-> (ProgramFile UA -> ProgramFile UA)
-> ProgramFile UA
-> ProgramFile UA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParamVarMap -> ProgramFile UA -> ProgramFile UA
forall a.
Data a =>
ParamVarMap -> ProgramFile (Analysis a) -> ProgramFile (Analysis a)
FAD.analyseParameterVars ParamVarMap
pvm (ProgramFile UA -> ProgramFile UA)
-> (ProgramFile UA -> ProgramFile UA)
-> ProgramFile UA
-> ProgramFile UA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramFile UA -> ProgramFile UA
forall a.
Data a =>
ProgramFile (Analysis a) -> ProgramFile (Analysis a)
FAB.analyseBBlocks (ProgramFile UA -> ProgramFile UA)
-> ProgramFile UA -> ProgramFile UA
forall a b. (a -> b) -> a -> b
$ ProgramFile UA
pf'
ProgramFile UA -> UnitSolver a -> UnitAnalysis (a, UnitState)
forall a.
ProgramFile UA -> UnitSolver a -> UnitAnalysis (a, UnitState)
runUnitSolver ProgramFile UA
pf'' (UnitSolver a -> UnitAnalysis (a, UnitState))
-> UnitSolver a -> UnitAnalysis (a, UnitState)
forall a b. (a -> b) -> a -> b
$ do
UnitSolver ()
initializeModFiles
UnitSolver ()
initInference
UnitSolver a
solver
insertParametricUnits :: UnitSolver ()
insertParametricUnits :: UnitSolver ()
insertParametricUnits = UnitSolver (ProgramFile UA)
getProgramFile UnitSolver (ProgramFile UA)
-> (ProgramFile UA -> UnitSolver ()) -> UnitSolver ()
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((ProgramUnit UA -> UnitSolver ())
-> [ProgramUnit UA] -> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProgramUnit UA -> UnitSolver ()
paramPU ([ProgramUnit UA] -> UnitSolver ())
-> (ProgramFile UA -> [ProgramUnit UA])
-> ProgramFile UA
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi)
where
paramPU :: ProgramUnit UA -> UnitSolver ()
paramPU ProgramUnit UA
pu =
[(Int, VV)] -> ((Int, VV) -> UnitSolver ()) -> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProgramUnit UA -> [(Int, VV)]
indexedParams ProgramUnit UA
pu) (((Int, VV) -> UnitSolver ()) -> UnitSolver ())
-> ((Int, VV) -> UnitSolver ()) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ (Int
i, VV
param) ->
(VarUnitMap -> VarUnitMap) -> UnitSolver ()
modifyVarUnitMap ((VarUnitMap -> VarUnitMap) -> UnitSolver ())
-> (VarUnitMap -> VarUnitMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> UnitInfo)
-> VV -> UnitInfo -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (((UnitInfo, UnitInfo) -> UnitInfo)
-> UnitInfo -> UnitInfo -> UnitInfo
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (UnitInfo, UnitInfo) -> UnitInfo
forall a b. (a, b) -> b
snd) VV
param ((VV, Int) -> UnitInfo
UnitParamPosAbs (VV
fname, Int
i))
where
fname :: VV
fname = (ProgramUnit UA -> Name
puName ProgramUnit UA
pu, ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu)
indexedParams :: F.ProgramUnit UA -> [(Int, VV)]
indexedParams :: ProgramUnit UA -> [(Int, VV)]
indexedParams ProgramUnit UA
pu
| F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ Maybe (AList Expression UA)
Nothing (Just Expression UA
r) [Block UA]
_ Maybe [ProgramUnit UA]
_ <- ProgramUnit UA
pu = [(Int
0, Expression UA -> VV
forall {a}. Expression (Analysis a) -> VV
toVV Expression UA
r)]
| F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ Maybe (AList Expression UA)
Nothing Maybe (Expression UA)
_ [Block UA]
_ Maybe [ProgramUnit UA]
_ <- ProgramUnit UA
pu = [(Int
0, (Name
fname, Name
sfname))]
| F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ (Just AList Expression UA
paList) (Just Expression UA
r) [Block UA]
_ Maybe [ProgramUnit UA]
_ <- ProgramUnit UA
pu = [Int] -> [VV] -> [(Int, VV)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([VV] -> [(Int, VV)]) -> [VV] -> [(Int, VV)]
forall a b. (a -> b) -> a -> b
$ (Expression UA -> VV) -> [Expression UA] -> [VV]
forall a b. (a -> b) -> [a] -> [b]
map Expression UA -> VV
forall {a}. Expression (Analysis a) -> VV
toVV (Expression UA
r Expression UA -> [Expression UA] -> [Expression UA]
forall a. a -> [a] -> [a]
: AList Expression UA -> [Expression UA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList Expression UA
paList)
| F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ (Just AList Expression UA
paList) Maybe (Expression UA)
_ [Block UA]
_ Maybe [ProgramUnit UA]
_ <- ProgramUnit UA
pu = [Int] -> [VV] -> [(Int, VV)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([VV] -> [(Int, VV)]) -> [VV] -> [(Int, VV)]
forall a b. (a -> b) -> a -> b
$ (Name
fname, Name
sfname) VV -> [VV] -> [VV]
forall a. a -> [a] -> [a]
: (Expression UA -> VV) -> [Expression UA] -> [VV]
forall a b. (a -> b) -> [a] -> [b]
map Expression UA -> VV
forall {a}. Expression (Analysis a) -> VV
toVV (AList Expression UA -> [Expression UA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList Expression UA
paList)
| F.PUSubroutine UA
_ SrcSpan
_ PrefixSuffix UA
_ Name
_ (Just AList Expression UA
paList) [Block UA]
_ Maybe [ProgramUnit UA]
_ <- ProgramUnit UA
pu = [Int] -> [VV] -> [(Int, VV)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([VV] -> [(Int, VV)]) -> [VV] -> [(Int, VV)]
forall a b. (a -> b) -> a -> b
$ (Expression UA -> VV) -> [Expression UA] -> [VV]
forall a b. (a -> b) -> [a] -> [b]
map Expression UA -> VV
forall {a}. Expression (Analysis a) -> VV
toVV (AList Expression UA -> [Expression UA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip AList Expression UA
paList)
| Bool
otherwise = []
where
fname :: Name
fname = ProgramUnit UA -> Name
puName ProgramUnit UA
pu
sfname :: Name
sfname = ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu
toVV :: Expression (Analysis a) -> VV
toVV Expression (Analysis a)
e = (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e, Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e)
insertUndeterminedUnits :: UnitSolver ()
insertUndeterminedUnits :: UnitSolver ()
insertUndeterminedUnits = do
ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile
Map Name (DeclContext, SrcSpan)
dmap <- UnitAnalysis (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall (m :: * -> *) a. Monad m => m a -> StateT UnitState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UnitAnalysis (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> (AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall (m :: * -> *) a. Monad m => m a -> ReaderT UnitEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall a b. (a -> b) -> a -> b
$ Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (ProgramFile UA -> Map Name (DeclContext, SrcSpan)
forall a.
Data a =>
ProgramFile (Analysis a) -> Map Name (DeclContext, SrcSpan)
extractDeclMap ProgramFile UA
pf) (Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan))
-> (ModFiles -> Map Name (DeclContext, SrcSpan))
-> ModFiles
-> Map Name (DeclContext, SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModFiles -> Map Name (DeclContext, SrcSpan)
combinedDeclMap (ModFiles -> Map Name (DeclContext, SrcSpan))
-> AnalysisT () () IO ModFiles
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnalysisT () () IO ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
[ProgramUnit UA]
-> (ProgramUnit UA
-> StateT UnitState UnitAnalysis (ProgramUnit UA))
-> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [F.ProgramUnit UA]) ((ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA))
-> UnitSolver ())
-> (ProgramUnit UA
-> StateT UnitState UnitAnalysis (ProgramUnit UA))
-> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit UA
pu ->
([Block UA] -> StateT UnitState UnitAnalysis [Block UA])
-> ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> [Block UA] -> StateT UnitState UnitAnalysis [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (Map Name (DeclContext, SrcSpan)
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
insertUndeterminedUnitVar Map Name (DeclContext, SrcSpan)
dmap)) ProgramUnit UA
pu
insertUndeterminedUnitVar :: DeclMap -> F.Expression UA -> UnitSolver (F.Expression UA)
insertUndeterminedUnitVar :: Map Name (DeclContext, SrcSpan)
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
insertUndeterminedUnitVar Map Name (DeclContext, SrcSpan)
dmap v :: Expression UA
v@(F.ExpValue UA
_ SrcSpan
_ (F.ValVariable Name
_))
| Just (FA.IDType { idVType :: IDType -> Maybe SemType
FA.idVType = Just SemType
sty }) <- UA -> Maybe IDType
forall a. Analysis a -> Maybe IDType
FA.idType (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
v)
, SemType -> Bool
isAcceptableType SemType
sty = do
let vname :: Name
vname = Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
v
let sname :: Name
sname = Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
v
let unit :: UnitInfo
unit = Map Name (DeclContext, SrcSpan) -> VV -> UnitInfo
toUnitVar Map Name (DeclContext, SrcSpan)
dmap (Name
vname, Name
sname)
(VarUnitMap -> VarUnitMap) -> UnitSolver ()
modifyVarUnitMap ((VarUnitMap -> VarUnitMap) -> UnitSolver ())
-> (VarUnitMap -> VarUnitMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> UnitInfo)
-> VV -> UnitInfo -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (((UnitInfo, UnitInfo) -> UnitInfo)
-> UnitInfo -> UnitInfo -> UnitInfo
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (UnitInfo, UnitInfo) -> UnitInfo
forall a b. (a, b) -> b
snd) (Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
v, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
v) UnitInfo
unit
Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
v
insertUndeterminedUnitVar Map Name (DeclContext, SrcSpan)
_ Expression UA
e = Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
toUnitVar :: DeclMap -> VV -> UnitInfo
toUnitVar :: Map Name (DeclContext, SrcSpan) -> VV -> UnitInfo
toUnitVar Map Name (DeclContext, SrcSpan)
dmap (Name
vname, Name
sname) = UnitInfo
unit
where
unit :: UnitInfo
unit = case (DeclContext, SrcSpan) -> DeclContext
forall a b. (a, b) -> a
fst ((DeclContext, SrcSpan) -> DeclContext)
-> Maybe (DeclContext, SrcSpan) -> Maybe DeclContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name
-> Map Name (DeclContext, SrcSpan) -> Maybe (DeclContext, SrcSpan)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
vname Map Name (DeclContext, SrcSpan)
dmap of
Just (DCFunction (F.Named Name
fvname, F.Named Name
fsname)) -> (VV, VV) -> UnitInfo
UnitParamVarAbs ((Name
fvname, Name
fsname), (Name
vname, Name
sname))
Just (DCSubroutine (F.Named Name
fvname, F.Named Name
fsname)) -> (VV, VV) -> UnitInfo
UnitParamVarAbs ((Name
fvname, Name
fsname), (Name
vname, Name
sname))
Maybe DeclContext
_ -> VV -> UnitInfo
UnitVar (Name
vname, Name
sname)
isAcceptableType :: FAS.SemType -> Bool
isAcceptableType :: SemType -> Bool
isAcceptableType = \case
FAS.TReal Int
_ -> Bool
True
FAS.TComplex Int
_ -> Bool
True
FAS.TInteger Int
_ -> Bool
True
SemType
_ -> Bool
False
transformExplicitPolymorphism :: Maybe F.ProgramUnitName -> UnitInfo -> UnitInfo
transformExplicitPolymorphism :: Maybe ProgramUnitName -> UnitInfo -> UnitInfo
transformExplicitPolymorphism (Just (F.Named Name
f)) (UnitName a :: Name
a@(Char
'\'':Name
_)) = VV -> UnitInfo
UnitParamEAPAbs (Name
a, Name
f Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"_" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
a)
transformExplicitPolymorphism Maybe ProgramUnitName
_ UnitInfo
u = UnitInfo
u
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
checkPU :: F.ProgramUnit UA -> UnitSolver ()
checkPU :: ProgramUnit UA -> UnitSolver ()
checkPU (F.PUComment UA
a SrcSpan
_ Comment UA
_)
| Just (P.UnitAssignment (Just [Name]
vars) UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec
, Just ProgramUnit UA
pu <- Maybe (ProgramUnit UA)
mPU = UnitInfo -> ProgramUnit UA -> [Name] -> UnitSolver ()
insertPUUnitAssigns (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST) ProgramUnit UA
pu [Name]
vars
| Just (P.UnitAlias Name
name UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec = (UnitAliasMap -> UnitAliasMap) -> UnitSolver ()
modifyUnitAliasMap (Name -> UnitInfo -> UnitAliasMap -> UnitAliasMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST))
| Bool
otherwise = () -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
mSpec :: Maybe UnitStatement
mSpec = UnitAnnotation A -> Maybe UnitStatement
forall a. UnitAnnotation a -> Maybe UnitStatement
UA.unitSpec (UA -> UnitAnnotation A
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
mPU :: Maybe (ProgramUnit UA)
mPU = UnitAnnotation A -> Maybe (ProgramUnit UA)
forall a.
UnitAnnotation a
-> Maybe (ProgramUnit (Analysis (UnitAnnotation a)))
UA.unitPU (UA -> UnitAnnotation A
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
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
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
_)
| Just (P.UnitAssignment (Just [Name]
vars) UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec
, Just Block UA
b <- Maybe (Block UA)
mBlock = Maybe ProgramUnitName
-> UnitInfo -> Block UA -> [Name] -> UnitSolver ()
insertBlockUnitAssigns Maybe ProgramUnitName
pname (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST) Block UA
b [Name]
vars
| Just (P.UnitAlias Name
name UnitOfMeasure
unitsAST) <- Maybe UnitStatement
mSpec = (UnitAliasMap -> UnitAliasMap) -> UnitSolver ()
modifyUnitAliasMap (Name -> UnitInfo -> UnitAliasMap -> UnitAliasMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name (UnitOfMeasure -> UnitInfo
toUnitInfo UnitOfMeasure
unitsAST))
| Bool
otherwise = () -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
mSpec :: Maybe UnitStatement
mSpec = UnitAnnotation A -> Maybe UnitStatement
forall a. UnitAnnotation a -> Maybe UnitStatement
UA.unitSpec (UA -> UnitAnnotation A
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
mBlock :: Maybe (Block UA)
mBlock = UnitAnnotation A -> Maybe (Block UA)
forall a.
UnitAnnotation a -> Maybe (Block (Analysis (UnitAnnotation a)))
UA.unitBlock (UA -> UnitAnnotation A
forall a. Analysis a -> a
FA.prevAnnotation UA
a)
checkBlockComment Maybe ProgramUnitName
_ Block UA
_ = Name -> UnitSolver ()
forall a. HasCallStack => Name -> a
error Name
"received non-comment in checkBlockComment"
insertBlockUnitAssigns :: Maybe F.ProgramUnitName -> UnitInfo -> F.Block UA -> [String] -> UnitSolver ()
insertBlockUnitAssigns :: Maybe ProgramUnitName
-> UnitInfo -> Block UA -> [Name] -> UnitSolver ()
insertBlockUnitAssigns Maybe ProgramUnitName
pname UnitInfo
info (F.BlStatement UA
_ SrcSpan
_ Maybe (Expression UA)
_ (F.StDeclaration UA
_ SrcSpan
_ TypeSpec UA
_ Maybe (AList Attribute UA)
_ AList Declarator UA
decls)) [Name]
varRealNames = do
let info' :: UnitInfo
info' = (UnitInfo -> UnitInfo) -> UnitInfo -> UnitInfo
forall on. Uniplate on => (on -> on) -> on -> on
transform (Maybe ProgramUnitName -> UnitInfo -> UnitInfo
transformExplicitPolymorphism Maybe ProgramUnitName
pname) UnitInfo
info
let m :: VarUnitMap
m = [(VV, UnitInfo)] -> VarUnitMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ ((Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
e, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
e), UnitInfo
info')
| e :: Expression UA
e@(F.ExpValue UA
_ SrcSpan
_ (F.ValVariable Name
_)) <- AList Declarator UA -> [Expression UA]
forall from to. Biplate from to => from -> [to]
universeBi AList Declarator UA
decls :: [F.Expression UA]
, Name
varRealName <- [Name]
varRealNames
, Name
varRealName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
e ]
(VarUnitMap -> VarUnitMap) -> UnitSolver ()
modifyVarUnitMap ((VarUnitMap -> VarUnitMap) -> UnitSolver ())
-> (VarUnitMap -> VarUnitMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> UnitInfo)
-> VarUnitMap -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith UnitInfo -> UnitInfo -> UnitInfo
forall a b. a -> b -> a
const VarUnitMap
m
(GivenVarSet -> GivenVarSet) -> UnitSolver ()
modifyGivenVarSet ((GivenVarSet -> GivenVarSet) -> UnitSolver ())
-> (VarUnitMap -> GivenVarSet -> GivenVarSet)
-> VarUnitMap
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GivenVarSet -> GivenVarSet -> GivenVarSet
forall a. Ord a => Set a -> Set a -> Set a
S.union (GivenVarSet -> GivenVarSet -> GivenVarSet)
-> (VarUnitMap -> GivenVarSet)
-> VarUnitMap
-> GivenVarSet
-> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> GivenVarSet
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> GivenVarSet)
-> (VarUnitMap -> [Name]) -> VarUnitMap -> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VV -> Name) -> [VV] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map VV -> Name
forall a b. (a, b) -> a
fst ([VV] -> [Name]) -> (VarUnitMap -> [VV]) -> VarUnitMap -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarUnitMap -> [VV]
forall k a. Map k a -> [k]
M.keys (VarUnitMap -> UnitSolver ()) -> VarUnitMap -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ VarUnitMap
m
insertBlockUnitAssigns Maybe ProgramUnitName
_ UnitInfo
_ Block UA
_ [Name]
_ = Name -> UnitSolver ()
forall a. HasCallStack => Name -> a
error Name
"received non-statement/declaration in insertBlockUnitAssigns"
insertPUUnitAssigns :: UnitInfo -> F.ProgramUnit UA -> [String] -> UnitSolver ()
insertPUUnitAssigns :: UnitInfo -> ProgramUnit UA -> [Name] -> UnitSolver ()
insertPUUnitAssigns UnitInfo
info pu :: ProgramUnit UA
pu@(F.PUFunction UA
_ SrcSpan
_ Maybe (TypeSpec UA)
_ PrefixSuffix UA
_ Name
_ Maybe (AList Expression UA)
_ Maybe (Expression UA)
mret [Block UA]
_ Maybe [ProgramUnit UA]
_) [Name]
varRealNames
| (Name
retUniq, Name
retSrc) <- case Maybe (Expression UA)
mret of Just Expression UA
ret -> (Expression UA -> Name
forall a. Expression (Analysis a) -> Name
FA.varName Expression UA
ret, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
FA.srcName Expression UA
ret)
Maybe (Expression UA)
Nothing -> (ProgramUnit UA -> Name
puName ProgramUnit UA
pu, ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu)
, Name
retSrc Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
varRealNames = do
let pname :: Maybe ProgramUnitName
pname = ProgramUnitName -> Maybe ProgramUnitName
forall a. a -> Maybe a
Just (ProgramUnitName -> Maybe ProgramUnitName)
-> ProgramUnitName -> Maybe ProgramUnitName
forall a b. (a -> b) -> a -> b
$ ProgramUnit UA -> ProgramUnitName
forall a. Named a => a -> ProgramUnitName
F.getName ProgramUnit UA
pu
let info' :: UnitInfo
info' = (UnitInfo -> UnitInfo) -> UnitInfo -> UnitInfo
forall on. Uniplate on => (on -> on) -> on -> on
transform (Maybe ProgramUnitName -> UnitInfo -> UnitInfo
transformExplicitPolymorphism Maybe ProgramUnitName
pname) UnitInfo
info
let m :: VarUnitMap
m = [(VV, UnitInfo)] -> VarUnitMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ ((Name
retUniq, Name
retSrc), UnitInfo
info') ]
(VarUnitMap -> VarUnitMap) -> UnitSolver ()
modifyVarUnitMap ((VarUnitMap -> VarUnitMap) -> UnitSolver ())
-> (VarUnitMap -> VarUnitMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> UnitInfo)
-> VarUnitMap -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith UnitInfo -> UnitInfo -> UnitInfo
forall a b. a -> b -> a
const VarUnitMap
m
(GivenVarSet -> GivenVarSet) -> UnitSolver ()
modifyGivenVarSet ((GivenVarSet -> GivenVarSet) -> UnitSolver ())
-> (VarUnitMap -> GivenVarSet -> GivenVarSet)
-> VarUnitMap
-> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GivenVarSet -> GivenVarSet -> GivenVarSet
forall a. Ord a => Set a -> Set a -> Set a
S.union (GivenVarSet -> GivenVarSet -> GivenVarSet)
-> (VarUnitMap -> GivenVarSet)
-> VarUnitMap
-> GivenVarSet
-> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> GivenVarSet
forall a. Ord a => [a] -> Set a
S.fromList ([Name] -> GivenVarSet)
-> (VarUnitMap -> [Name]) -> VarUnitMap -> GivenVarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VV -> Name) -> [VV] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map VV -> Name
forall a b. (a, b) -> a
fst ([VV] -> [Name]) -> (VarUnitMap -> [VV]) -> VarUnitMap -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarUnitMap -> [VV]
forall k a. Map k a -> [k]
M.keys (VarUnitMap -> UnitSolver ()) -> VarUnitMap -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ VarUnitMap
m
insertPUUnitAssigns UnitInfo
_ ProgramUnit UA
_ [Name]
_ = Name -> UnitSolver ()
forall a. HasCallStack => Name -> a
error Name
"received non-function in insertPUUnitAssigns"
annotateAllVariables :: UnitSolver ()
annotateAllVariables :: UnitSolver ()
annotateAllVariables = (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
modifyProgramFileM ((ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ())
-> (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ ProgramFile UA
pf -> do
VarUnitMap
varUnitMap <- UnitSolver VarUnitMap
getVarUnitMap
VarUnitMap
importedVariables <- UnitSolver VarUnitMap
getImportedVariables
let varUnitMap' :: VarUnitMap
varUnitMap' = (UnitInfo -> UnitInfo -> UnitInfo)
-> VarUnitMap -> VarUnitMap -> VarUnitMap
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith (((UnitInfo, UnitInfo) -> UnitInfo)
-> UnitInfo -> UnitInfo -> UnitInfo
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (UnitInfo, UnitInfo) -> UnitInfo
forall a b. (a, b) -> b
snd) VarUnitMap
varUnitMap VarUnitMap
importedVariables
let annotateExp :: Expression UA -> Expression UA
annotateExp e :: Expression UA
e@(F.ExpValue UA
_ SrcSpan
_ (F.ValVariable Name
_))
| Just UnitInfo
info <- VV -> VarUnitMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
e, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
e) VarUnitMap
varUnitMap' = UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
info Expression UA
e
annotateExp Expression UA
e = Expression UA
e
ProgramFile UA -> UnitSolver (ProgramFile UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall a b. (a -> b) -> a -> b
$ (Expression UA -> Expression UA)
-> ProgramFile UA -> ProgramFile UA
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi Expression UA -> Expression UA
annotateExp ProgramFile UA
pf
annotateLiterals :: UnitSolver ()
annotateLiterals :: UnitSolver ()
annotateLiterals = (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
modifyProgramFileM ((ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
annotateLiteralsPU)
annotateLiteralsPU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)
annotateLiteralsPU :: ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
annotateLiteralsPU ProgramUnit UA
pu = do
LiteralsOpt
mode <- (UnitEnv -> LiteralsOpt)
-> StateT UnitState UnitAnalysis LiteralsOpt
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (UnitOpts -> LiteralsOpt
uoLiterals (UnitOpts -> LiteralsOpt)
-> (UnitEnv -> UnitOpts) -> UnitEnv -> LiteralsOpt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitEnv -> UnitOpts
unitOpts)
case LiteralsOpt
mode of
LiteralsOpt
LitUnitless -> ([Block UA] -> StateT UnitState UnitAnalysis [Block UA])
-> ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> [Block UA] -> StateT UnitState UnitAnalysis [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
Expression UA -> f (Expression UA)
expUnitless) ProgramUnit UA
pu
LiteralsOpt
LitPoly -> ([Block UA] -> StateT UnitState UnitAnalysis [Block UA])
-> ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> [Block UA] -> StateT UnitState UnitAnalysis [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM (StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genParamLit)) ProgramUnit UA
pu
LiteralsOpt
LitMixed -> ([Block UA] -> StateT UnitState UnitAnalysis [Block UA])
-> ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM ((Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> [Block UA] -> StateT UnitState UnitAnalysis [Block UA]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
expMixed) ProgramUnit UA
pu
where
expMixed :: Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
expMixed Expression UA
e = case Expression UA
e of
F.ExpValue UA
_ SrcSpan
_ (F.ValInteger Name
i Maybe (KindParam UA)
_)
| Name -> Integer
forall a. Read a => Name -> a
read Name
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 -> StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genParamLit Expression UA
e
| Bool
otherwise -> StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genUnitLiteral Expression UA
e
F.ExpValue UA
_ SrcSpan
_ (F.ValReal RealLit
i Maybe (KindParam UA)
_)
| RealLit -> Double
forall a. (Fractional a, Read a) => RealLit -> a
readRealLit RealLit
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0.0 -> StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genParamLit Expression UA
e
| Bool
otherwise -> StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genUnitLiteral Expression UA
e
F.ExpBinary UA
a SrcSpan
s BinaryOp
op Expression UA
e1 Expression UA
e2
| BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
F.Multiplication, BinaryOp
F.Division] -> case () of
()
_ | Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e1)
, Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e2) -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
()
_ | Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e1)
, Just UnitLiteral{} <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1 ->
Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ UA
-> SrcSpan
-> BinaryOp
-> Expression UA
-> Expression UA
-> Expression UA
forall a.
a
-> SrcSpan
-> BinaryOp
-> Expression a
-> Expression a
-> Expression a
F.ExpBinary UA
a SrcSpan
s BinaryOp
op (UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
UnitlessLit Expression UA
e1) Expression UA
e2
| Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e2)
, Just UnitLiteral{} <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2 ->
Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ UA
-> SrcSpan
-> BinaryOp
-> Expression UA
-> Expression UA
-> Expression UA
forall a.
a
-> SrcSpan
-> BinaryOp
-> Expression a
-> Expression a
-> Expression a
F.ExpBinary UA
a SrcSpan
s BinaryOp
op Expression UA
e1 (UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
UnitlessLit Expression UA
e2)
()
_ -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
Expression UA
_ | Just Constant
_ <- UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e) -> case Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e of
Just UnitLiteral{} -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
genLit Expression UA
e
Just UnitVar{} -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
genLit Expression UA
e
Maybe UnitInfo
_ -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
| Bool
otherwise -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
expUnitless :: Expression UA -> f (Expression UA)
expUnitless Expression UA
e
| Expression UA -> Bool
isLiteral Expression UA
e = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> f (Expression UA))
-> Expression UA -> f (Expression UA)
forall a b. (a -> b) -> a -> b
$ UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
UnitlessLit Expression UA
e
| Bool
otherwise = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
withLiterals :: f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals f UnitInfo
m Expression UA
e
| Expression UA -> Bool
isLiteral Expression UA
e = (UnitInfo -> Expression UA -> Expression UA)
-> Expression UA -> UnitInfo -> Expression UA
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo Expression UA
e (UnitInfo -> Expression UA) -> f UnitInfo -> f (Expression UA)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f UnitInfo
m
| Bool
otherwise = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
genLit :: Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
genLit Expression UA
e
| Expression UA -> Bool
isLiteralZero Expression UA
e = StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genParamLit Expression UA
e
| Bool
otherwise = StateT UnitState UnitAnalysis UnitInfo
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *}.
Applicative f =>
f UnitInfo -> Expression UA -> f (Expression UA)
withLiterals StateT UnitState UnitAnalysis UnitInfo
genUnitLiteral Expression UA
e
isLiteral :: F.Expression UA -> Bool
isLiteral :: Expression UA -> Bool
isLiteral (F.ExpValue UA
_ SrcSpan
_ F.ValReal{}) = Bool
True
isLiteral (F.ExpValue UA
_ SrcSpan
_ F.ValInteger{}) = Bool
True
isLiteral Expression UA
e = Maybe Constant -> Bool
forall a. Maybe a -> Bool
isJust (UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e))
isLiteralNonZero :: F.Expression UA -> Bool
isLiteralNonZero :: Expression UA -> Bool
isLiteralNonZero (F.ExpValue UA
_ SrcSpan
_ (F.ValInteger Name
i Maybe (KindParam UA)
_)) = Name -> Integer
forall a. Read a => Name -> a
read Name
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
isLiteralNonZero (F.ExpValue UA
_ SrcSpan
_ (F.ValReal RealLit
i Maybe (KindParam UA)
_)) = RealLit -> Double
forall a. (Fractional a, Read a) => RealLit -> a
readRealLit RealLit
i Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0.0
isLiteralNonZero Expression UA
e = case UA -> Maybe Constant
forall a. Analysis a -> Maybe Constant
constExp (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
e) of
Just (FA.ConstInt Integer
i) -> Integer
i Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
Just (FA.ConstUninterpInt Name
s) -> Name -> Integer
forall a. Read a => Name -> a
read Name
s Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0
Just (FA.ConstUninterpReal Name
s) -> RealLit -> Double
forall a. (Fractional a, Read a) => RealLit -> a
readRealLit (Name -> RealLit
parseRealLit Name
s) Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0.0
Maybe Constant
_ -> Bool
False
isLiteralZero :: F.Expression UA -> Bool
isLiteralZero :: Expression UA -> Bool
isLiteralZero Expression UA
x = Expression UA -> Bool
isLiteral Expression UA
x Bool -> Bool -> Bool
&& Bool -> Bool
not (Expression UA -> Bool
isLiteralNonZero Expression UA
x)
cullRedundant :: Constraints -> Constraints
cullRedundant :: [Constraint] -> [Constraint]
cullRedundant = [Constraint] -> [Constraint]
forall a. Eq a => [a] -> [a]
nub ([Constraint] -> [Constraint])
-> ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> Maybe Constraint) -> [Constraint] -> [Constraint]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ( \ Constraint
con -> case Constraint
con of
ConEq UnitInfo
u1 UnitInfo
u2 | UnitInfo
u1 UnitInfo -> UnitInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitInfo
u2 -> Constraint -> Maybe Constraint
forall a. a -> Maybe a
Just Constraint
con
ConConj [Constraint]
cs | [Constraint]
cs' <- [Constraint] -> [Constraint]
cullRedundant [Constraint]
cs, Bool -> Bool
not ([Constraint] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Constraint]
cs) -> Constraint -> Maybe Constraint
forall a. a -> Maybe a
Just ([Constraint] -> Constraint
ConConj [Constraint]
cs')
Constraint
_ -> Maybe Constraint
forall a. Maybe a
Nothing
)
applyTemplates :: Constraints -> UnitSolver Constraints
applyTemplates :: [Constraint] -> UnitSolver [Constraint]
applyTemplates [Constraint]
cons = do
Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"applyTemplates" [Constraint]
cons
let instances :: [(Name, Int)]
instances = [(Name, Int)] -> [(Name, Int)]
forall a. Eq a => [a] -> [a]
nub [ (Name
name, Int
i) | UnitParamPosUse ((Name
name, Name
_), Int
_, Int
i) <- [Constraint] -> [UnitInfo]
forall from to. Biplate from to => from -> [to]
universeBi [Constraint]
cons ]
ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile
[(Name, Int)]
dummies <- [ProgramUnit UA]
-> (ProgramUnit UA -> StateT UnitState UnitAnalysis (Name, Int))
-> StateT UnitState UnitAnalysis [(Name, Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ProgramFile UA -> [ProgramUnit UA]
forall a. ProgramFile a -> [ProgramUnit a]
topLevelFuncsAndSubs ProgramFile UA
pf) ((ProgramUnit UA -> StateT UnitState UnitAnalysis (Name, Int))
-> StateT UnitState UnitAnalysis [(Name, Int)])
-> (ProgramUnit UA -> StateT UnitState UnitAnalysis (Name, Int))
-> StateT UnitState UnitAnalysis [(Name, Int)]
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit UA
pu -> do
Int
ident <- UnitSolver Int
freshId
(Name, Int) -> StateT UnitState UnitAnalysis (Name, Int)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProgramUnit UA -> Name
puName ProgramUnit UA
pu, Int
ident)
ProgramFile UA -> Text -> UnitSolver ()
forall a. Spanned a => a -> Text -> UnitSolver ()
forall e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' ProgramFile UA
pf (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (Text
"instances: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(Name, Int)] -> Text
forall a. Show a => a -> Text
describeShow [(Name, Int)]
instances)
ProgramFile UA -> Text -> UnitSolver ()
forall a. Spanned a => a -> Text -> UnitSolver ()
forall e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' ProgramFile UA
pf (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (Text
"dummies: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(Name, Int)] -> Text
forall a. Show a => a -> Text
describeShow [(Name, Int)]
dummies)
VarUnitMap
importedVariables <- UnitSolver VarUnitMap
getImportedVariables
let importedCons :: [Constraint]
importedCons = [ UnitInfo -> UnitInfo -> Constraint
ConEq (VV -> UnitInfo
UnitVar VV
vv) UnitInfo
units | (VV
vv, UnitInfo
units) <- VarUnitMap -> [(VV, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList VarUnitMap
importedVariables ]
[Constraint]
concreteCons <- [Constraint] -> [Constraint]
cullRedundant ([Constraint] -> [Constraint])
-> UnitSolver [Constraint] -> UnitSolver [Constraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
([Constraint] -> [Constraint] -> [Constraint])
-> UnitSolver [Constraint]
-> UnitSolver [Constraint]
-> UnitSolver [Constraint]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
(++) (([Constraint] -> (Name, Int) -> UnitSolver [Constraint])
-> [Constraint] -> [(Name, Int)] -> UnitSolver [Constraint]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> [Name] -> [Constraint] -> (Name, Int) -> UnitSolver [Constraint]
substInstance Bool
False []) [Constraint]
importedCons [(Name, Int)]
instances)
(([Constraint] -> (Name, Int) -> UnitSolver [Constraint])
-> [Constraint] -> [(Name, Int)] -> UnitSolver [Constraint]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> [Name] -> [Constraint] -> (Name, Int) -> UnitSolver [Constraint]
substInstance Bool
True []) [] [(Name, Int)]
dummies)
Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"applyTemplates: concreteCons" [Constraint]
concreteCons
UnitAliasMap
aliasMap <- UnitSolver UnitAliasMap
getUnitAliasMap
let aliases :: [Constraint]
aliases = [ UnitInfo -> UnitInfo -> Constraint
ConEq (Name -> UnitInfo
UnitAlias Name
name) UnitInfo
def | (Name
name, UnitInfo
def) <- UnitAliasMap -> [(Name, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList UnitAliasMap
aliasMap ]
let transAlias :: UnitInfo -> UnitInfo
transAlias (UnitName Name
a) | Name
a Name -> UnitAliasMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` UnitAliasMap
aliasMap = Name -> UnitInfo
UnitAlias Name
a
transAlias UnitInfo
u = UnitInfo
u
Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
"aliases" [Constraint]
aliases
[Constraint] -> UnitSolver [Constraint]
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Constraint] -> UnitSolver [Constraint])
-> ([Constraint] -> [Constraint])
-> [Constraint]
-> UnitSolver [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInfo -> UnitInfo) -> [Constraint] -> [Constraint]
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi UnitInfo -> UnitInfo
transAlias ([Constraint] -> [Constraint])
-> ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Constraint] -> [Constraint]
cullRedundant ([Constraint] -> UnitSolver [Constraint])
-> [Constraint] -> UnitSolver [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
cons [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
concreteCons [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
aliases
substInstance :: Bool -> [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints
substInstance :: Bool
-> [Name] -> [Constraint] -> (Name, Int) -> UnitSolver [Constraint]
substInstance Bool
isDummy [Name]
callStack [Constraint]
output (Name
name, Int
callId) = do
TemplateMap
tmap <- UnitSolver TemplateMap
getTemplateMap
let npc :: [a]
npc = []
[Constraint]
template <- (UnitInfo -> StateT UnitState UnitAnalysis UnitInfo)
-> [Constraint] -> UnitSolver [Constraint]
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM UnitInfo -> StateT UnitState UnitAnalysis UnitInfo
callIdRemap ([Constraint] -> UnitSolver [Constraint])
-> [Constraint] -> UnitSolver [Constraint]
forall a b. (a -> b) -> a -> b
$ [Constraint]
forall a. [a]
npc [Constraint] -> Maybe [Constraint] -> [Constraint]
forall a. a -> Maybe a -> a
`fromMaybe` Name -> TemplateMap -> Maybe [Constraint]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name TemplateMap
tmap
Name -> [Constraint] -> UnitSolver ()
dumpConsM (Name
"substInstance " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Bool -> Name
forall a. Show a => a -> Name
show Bool
isDummy Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [Name] -> Name
forall a. Show a => a -> Name
show [Name]
callStack Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ (Name, Int) -> Name
forall a. Show a => a -> Name
show (Name
name, Int
callId) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" template lookup") [Constraint]
template
(CallIdMap -> CallIdMap) -> UnitSolver ()
modifyCallIdRemap (CallIdMap -> CallIdMap -> CallIdMap
forall a b. a -> b -> a
const CallIdMap
forall a. IntMap a
IM.empty)
let instances :: [(Name, Int)]
instances = [(Name, Int)] -> [(Name, Int)]
forall a. Eq a => [a] -> [a]
nub [ (Name
name', Int
i) | UnitParamPosUse ((Name
name', Name
_), Int
_, Int
i) <- [Constraint] -> [UnitInfo]
forall from to. Biplate from to => from -> [to]
universeBi [Constraint]
template ]
[Constraint]
template' <- if Name
name Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
callStack then
[Constraint] -> UnitSolver [Constraint]
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else
([Constraint] -> (Name, Int) -> UnitSolver [Constraint])
-> [Constraint] -> [(Name, Int)] -> UnitSolver [Constraint]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Bool
-> [Name] -> [Constraint] -> (Name, Int) -> UnitSolver [Constraint]
substInstance Bool
False (Name
nameName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
callStack)) [] [(Name, Int)]
instances
Name -> [Constraint] -> UnitSolver ()
dumpConsM (Name
"instantiating " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ (Name, Int) -> Name
forall a. Show a => a -> Name
show (Name
name, Int
callId) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
": (output ++ template) is") ([Constraint]
output [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
template)
Name -> [Constraint] -> UnitSolver ()
dumpConsM (Name
"instantiating " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ (Name, Int) -> Name
forall a. Show a => a -> Name
show (Name
name, Int
callId) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
": (template') is") [Constraint]
template'
let output' :: [Constraint]
output' =
(if Bool
isDummy then [Constraint]
output [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
template
else Int -> [Constraint] -> [Constraint]
forall a. Data a => Int -> a -> a
instantiate Int
callId ([Constraint]
output [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
template)) [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++
Int -> [Constraint] -> [Constraint]
forall a. Data a => Int -> a -> a
instantiate Int
callId [Constraint]
template'
Name -> [Constraint] -> UnitSolver ()
dumpConsM (Name
"final output for " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ (Name, Int) -> Name
forall a. Show a => a -> Name
show (Name
name, Int
callId)) [Constraint]
output'
[Constraint] -> UnitSolver [Constraint]
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Constraint]
output'
callIdRemap :: UnitInfo -> UnitSolver UnitInfo
callIdRemap :: UnitInfo -> StateT UnitState UnitAnalysis UnitInfo
callIdRemap UnitInfo
info = (CallIdMap -> UnitSolver (UnitInfo, CallIdMap))
-> StateT UnitState UnitAnalysis UnitInfo
forall a. (CallIdMap -> UnitSolver (a, CallIdMap)) -> UnitSolver a
modifyCallIdRemapM ((CallIdMap -> UnitSolver (UnitInfo, CallIdMap))
-> StateT UnitState UnitAnalysis UnitInfo)
-> (CallIdMap -> UnitSolver (UnitInfo, CallIdMap))
-> StateT UnitState UnitAnalysis UnitInfo
forall a b. (a -> b) -> a -> b
$ \ CallIdMap
idMap -> case UnitInfo
info of
UnitParamPosUse (VV
n, Int
p, Int
i)
| Just Int
i' <- Int -> CallIdMap -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i CallIdMap
idMap -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
n, Int
p, Int
i'), CallIdMap
idMap)
| Bool
otherwise -> UnitSolver Int
freshId UnitSolver Int
-> (Int -> UnitSolver (UnitInfo, CallIdMap))
-> UnitSolver (UnitInfo, CallIdMap)
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
(UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
n, Int
p, Int
i'), Int -> Int -> CallIdMap -> CallIdMap
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
i' CallIdMap
idMap)
UnitParamVarUse (VV
n, VV
v, Int
i)
| Just Int
i' <- Int -> CallIdMap -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i CallIdMap
idMap -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, VV, Int) -> UnitInfo
UnitParamVarUse (VV
n, VV
v, Int
i'), CallIdMap
idMap)
| Bool
otherwise -> UnitSolver Int
freshId UnitSolver Int
-> (Int -> UnitSolver (UnitInfo, CallIdMap))
-> UnitSolver (UnitInfo, CallIdMap)
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
(UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, VV, Int) -> UnitInfo
UnitParamVarUse (VV
n, VV
v, Int
i'), Int -> Int -> CallIdMap -> CallIdMap
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
i' CallIdMap
idMap)
UnitParamLitUse (Int
l, Int
i)
| Just Int
i' <- Int -> CallIdMap -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i CallIdMap
idMap -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Int) -> UnitInfo
UnitParamLitUse (Int
l, Int
i'), CallIdMap
idMap)
| Bool
otherwise -> UnitSolver Int
freshId UnitSolver Int
-> (Int -> UnitSolver (UnitInfo, CallIdMap))
-> UnitSolver (UnitInfo, CallIdMap)
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
(UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int, Int) -> UnitInfo
UnitParamLitUse (Int
l, Int
i'), Int -> Int -> CallIdMap -> CallIdMap
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
i' CallIdMap
idMap)
UnitParamEAPUse (VV
v, Int
i)
| Just Int
i' <- Int -> CallIdMap -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i CallIdMap
idMap -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, Int) -> UnitInfo
UnitParamEAPUse (VV
v, Int
i'), CallIdMap
idMap)
| Bool
otherwise -> UnitSolver Int
freshId UnitSolver Int
-> (Int -> UnitSolver (UnitInfo, CallIdMap))
-> UnitSolver (UnitInfo, CallIdMap)
forall a b.
StateT UnitState UnitAnalysis a
-> (a -> StateT UnitState UnitAnalysis b)
-> StateT UnitState UnitAnalysis b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int
i' ->
(UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((VV, Int) -> UnitInfo
UnitParamEAPUse (VV
v, Int
i'), Int -> Int -> CallIdMap -> CallIdMap
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Int
i' CallIdMap
idMap)
UnitInfo
_ -> (UnitInfo, CallIdMap) -> UnitSolver (UnitInfo, CallIdMap)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnitInfo
info, CallIdMap
idMap)
instantiate :: Data a => Int -> a -> a
instantiate :: forall a. Data a => Int -> a -> a
instantiate Int
callId = (UnitInfo -> UnitInfo) -> a -> a
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi ((UnitInfo -> UnitInfo) -> a -> a)
-> (UnitInfo -> UnitInfo) -> a -> a
forall a b. (a -> b) -> a -> b
$ \ UnitInfo
info -> case UnitInfo
info of
UnitParamPosAbs (VV
name, Int
position) -> (VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
name, Int
position, Int
callId)
UnitParamLitAbs Int
litId -> (Int, Int) -> UnitInfo
UnitParamLitUse (Int
litId, Int
callId)
UnitParamVarAbs (VV
fname, VV
vname) -> (VV, VV, Int) -> UnitInfo
UnitParamVarUse (VV
fname, VV
vname, Int
callId)
UnitParamEAPAbs VV
vname -> (VV, Int) -> UnitInfo
UnitParamEAPUse (VV
vname, Int
callId)
UnitInfo
_ -> UnitInfo
info
topLevelFuncsAndSubs :: F.ProgramFile a -> [F.ProgramUnit a]
topLevelFuncsAndSubs :: forall a. ProgramFile a -> [ProgramUnit a]
topLevelFuncsAndSubs (F.ProgramFile MetaInfo
_ [ProgramUnit a]
pus) = ProgramUnit a -> [ProgramUnit a]
forall {a}. ProgramUnit a -> [ProgramUnit a]
topLevel (ProgramUnit a -> [ProgramUnit a])
-> [ProgramUnit a] -> [ProgramUnit a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ProgramUnit a]
pus
where
topLevel :: ProgramUnit a -> [ProgramUnit a]
topLevel (F.PUModule a
_ SrcSpan
_ Name
_ [Block a]
_ (Just [ProgramUnit a]
contains)) = ProgramUnit a -> [ProgramUnit a]
topLevel (ProgramUnit a -> [ProgramUnit a])
-> [ProgramUnit a] -> [ProgramUnit a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ProgramUnit a]
contains
topLevel (F.PUMain a
_ SrcSpan
_ Maybe Name
_ [Block a]
_ (Just [ProgramUnit a]
contains)) = ProgramUnit a -> [ProgramUnit a]
topLevel (ProgramUnit a -> [ProgramUnit a])
-> [ProgramUnit a] -> [ProgramUnit a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ProgramUnit a]
contains
topLevel f :: ProgramUnit a
f@F.PUFunction{} = ProgramUnit a -> [ProgramUnit a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramUnit a
f
topLevel s :: ProgramUnit a
s@F.PUSubroutine{} = ProgramUnit a -> [ProgramUnit a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramUnit a
s
topLevel ProgramUnit a
_ = []
extractConstraints :: UnitSolver Constraints
= do
ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile
Map Name (DeclContext, SrcSpan)
dmap <- UnitAnalysis (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall (m :: * -> *) a. Monad m => m a -> StateT UnitState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UnitAnalysis (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> (AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall (m :: * -> *) a. Monad m => m a -> ReaderT UnitEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan)))
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
-> StateT UnitState UnitAnalysis (Map Name (DeclContext, SrcSpan))
forall a b. (a -> b) -> a -> b
$ Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union (ProgramFile UA -> Map Name (DeclContext, SrcSpan)
forall a.
Data a =>
ProgramFile (Analysis a) -> Map Name (DeclContext, SrcSpan)
extractDeclMap ProgramFile UA
pf) (Map Name (DeclContext, SrcSpan)
-> Map Name (DeclContext, SrcSpan))
-> (ModFiles -> Map Name (DeclContext, SrcSpan))
-> ModFiles
-> Map Name (DeclContext, SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModFiles -> Map Name (DeclContext, SrcSpan)
combinedDeclMap (ModFiles -> Map Name (DeclContext, SrcSpan))
-> AnalysisT () () IO ModFiles
-> AnalysisT () () IO (Map Name (DeclContext, SrcSpan))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnalysisT () () IO ModFiles
forall e w (m :: * -> *). MonadAnalysis e w m => m ModFiles
analysisModFiles
VarUnitMap
varUnitMap <- UnitSolver VarUnitMap
getVarUnitMap
[Constraint] -> UnitSolver [Constraint]
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Constraint] -> UnitSolver [Constraint])
-> [Constraint] -> UnitSolver [Constraint]
forall a b. (a -> b) -> a -> b
$ [ Constraint
con | Block UA
b <- ProgramFile UA -> [Block UA]
mainBlocks ProgramFile UA
pf, con :: Constraint
con@ConEq{} <- Block UA -> [Constraint]
forall from to. Biplate from to => from -> [to]
universeBi Block UA
b ] [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++
[ UnitInfo -> UnitInfo -> Constraint
ConEq (Map Name (DeclContext, SrcSpan) -> VV -> UnitInfo
toUnitVar Map Name (DeclContext, SrcSpan)
dmap VV
v) UnitInfo
u | (VV
v, UnitInfo
u) <- VarUnitMap -> [(VV, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList VarUnitMap
varUnitMap ]
mainBlocks :: F.ProgramFile UA -> [F.Block UA]
mainBlocks :: ProgramFile UA -> [Block UA]
mainBlocks = (ProgramUnit UA -> [Block UA]) -> [ProgramUnit UA] -> [Block UA]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ProgramUnit UA -> [Block UA]
forall a. ProgramUnit a -> [Block a]
getBlocks ([ProgramUnit UA] -> [Block UA])
-> (ProgramFile UA -> [ProgramUnit UA])
-> ProgramFile UA
-> [Block UA]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi
where
getBlocks :: ProgramUnit a -> [Block a]
getBlocks (F.PUMain a
_ SrcSpan
_ Maybe Name
_ [Block a]
bs Maybe [ProgramUnit a]
_) = [Block a]
bs
getBlocks (F.PUModule a
_ SrcSpan
_ Name
_ [Block a]
bs Maybe [ProgramUnit a]
_) = [Block a]
bs
getBlocks ProgramUnit a
_ = []
propagateUnits :: UnitSolver ()
propagateUnits :: UnitSolver ()
propagateUnits = (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
modifyProgramFileM ((ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ())
-> (ProgramFile UA -> UnitSolver (ProgramFile UA)) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (Block UA -> StateT UnitState UnitAnalysis (Block UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Block UA -> StateT UnitState UnitAnalysis (Block UA)
propagateInterface (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA
-> UnitSolver (ProgramFile UA)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
(ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
propagatePU (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA
-> UnitSolver (ProgramFile UA)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
(DoSpecification UA
-> StateT UnitState UnitAnalysis (DoSpecification UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM DoSpecification UA
-> StateT UnitState UnitAnalysis (DoSpecification UA)
propagateDoSpec (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA
-> UnitSolver (ProgramFile UA)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
(Statement UA -> StateT UnitState UnitAnalysis (Statement UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
propagateStatement (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> (ProgramFile UA -> UnitSolver (ProgramFile UA))
-> ProgramFile UA
-> UnitSolver (ProgramFile UA)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
(Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> ProgramFile UA -> UnitSolver (ProgramFile UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
propagateExp
propagateExp :: F.Expression UA -> UnitSolver (F.Expression UA)
propagateExp :: Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
propagateExp Expression UA
e = case Expression UA
e of
F.ExpValue{} -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
F.ExpBinary UA
_ SrcSpan
_ BinaryOp
F.Multiplication Expression UA
e1 Expression UA
e2 -> (UnitInfo -> UnitInfo -> UnitInfo)
-> Maybe UnitInfo
-> Maybe UnitInfo
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {a} {b}.
Applicative f =>
(a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f (Expression UA)
setF2 UnitInfo -> UnitInfo -> UnitInfo
UnitMul (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)
F.ExpBinary UA
_ SrcSpan
_ BinaryOp
F.Division Expression UA
e1 Expression UA
e2 -> (UnitInfo -> UnitInfo -> UnitInfo)
-> Maybe UnitInfo
-> Maybe UnitInfo
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {a} {b}.
Applicative f =>
(a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f (Expression UA)
setF2 UnitInfo -> UnitInfo -> UnitInfo
UnitMul (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) ((UnitInfo -> Double -> UnitInfo) -> Double -> UnitInfo -> UnitInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitInfo -> Double -> UnitInfo
UnitPow (-Double
1) (UnitInfo -> UnitInfo) -> Maybe UnitInfo -> Maybe UnitInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)
F.ExpBinary UA
_ SrcSpan
_ BinaryOp
F.Exponentiation Expression UA
e1 Expression UA
e2 -> (UnitInfo -> Double -> UnitInfo)
-> Maybe UnitInfo
-> Maybe Double
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {a} {b}.
Applicative f =>
(a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f (Expression UA)
setF2 UnitInfo -> Double -> UnitInfo
UnitPow (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe Double
forall a. Expression a -> Maybe Double
constantExpression Expression UA
e2)
F.ExpBinary UA
_ SrcSpan
_ BinaryOp
o Expression UA
e1 Expression UA
e2 | BinOpKind -> BinaryOp -> Bool
isOp BinOpKind
AddOp BinaryOp
o -> (UnitInfo -> UnitInfo -> Constraint)
-> Maybe UnitInfo
-> Maybe UnitInfo
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {b}.
Applicative f =>
(UnitInfo -> b -> Constraint)
-> Maybe UnitInfo -> Maybe b -> f (Expression UA)
setF2C UnitInfo -> UnitInfo -> Constraint
ConEq (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)
| BinOpKind -> BinaryOp -> Bool
isOp BinOpKind
RelOp BinaryOp
o -> (UnitInfo -> UnitInfo -> Constraint)
-> Maybe UnitInfo
-> Maybe UnitInfo
-> StateT UnitState UnitAnalysis (Expression UA)
forall {f :: * -> *} {b}.
Applicative f =>
(UnitInfo -> b -> Constraint)
-> Maybe UnitInfo -> Maybe b -> f (Expression UA)
setF2C UnitInfo -> UnitInfo -> Constraint
ConEq (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)
F.ExpFunctionCall {} -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
propagateFunctionCall Expression UA
e
F.ExpSubscript UA
_ SrcSpan
_ Expression UA
e1 AList Index UA
_ -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ Maybe UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => Maybe UnitInfo -> f UA -> f UA
UA.maybeSetUnitInfo (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) Expression UA
e
F.ExpUnary UA
_ SrcSpan
_ UnaryOp
_ Expression UA
e1 -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ Maybe UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => Maybe UnitInfo -> f UA -> f UA
UA.maybeSetUnitInfo (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) Expression UA
e
F.ExpInitialisation{} -> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
Expression UA
_ -> do
Expression UA -> Text -> UnitSolver ()
forall a. Spanned a => a -> Text -> UnitSolver ()
forall e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' Expression UA
e (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Text
"progagateExp: unhandled " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Expression UA -> Text
forall a. Show a => a -> Text
describeShow Expression UA
e
Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression UA
e
where
setF2 :: (a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f (Expression UA)
setF2 a -> b -> UnitInfo
f Maybe a
u1 Maybe b
u2 = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> f (Expression UA))
-> Expression UA -> f (Expression UA)
forall a b. (a -> b) -> a -> b
$ (a -> b -> UnitInfo)
-> Maybe a -> Maybe b -> Expression UA -> Expression UA
forall (f :: * -> *) a b.
Annotated f =>
(a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f UA -> f UA
UA.maybeSetUnitInfoF2 a -> b -> UnitInfo
f Maybe a
u1 Maybe b
u2 Expression UA
e
setF2C :: (UnitInfo -> b -> Constraint)
-> Maybe UnitInfo -> Maybe b -> f (Expression UA)
setF2C UnitInfo -> b -> Constraint
f Maybe UnitInfo
u1 Maybe b
u2 = Expression UA -> f (Expression UA)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> f (Expression UA))
-> (Expression UA -> Expression UA)
-> Expression UA
-> f (Expression UA)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => Maybe UnitInfo -> f UA -> f UA
UA.maybeSetUnitInfo Maybe UnitInfo
u1 (Expression UA -> f (Expression UA))
-> Expression UA -> f (Expression UA)
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> b -> Constraint)
-> Maybe UnitInfo -> Maybe b -> Expression UA -> Expression UA
forall (f :: * -> *) a b.
Annotated f =>
(a -> b -> Constraint) -> Maybe a -> Maybe b -> f UA -> f UA
UA.maybeSetUnitConstraintF2 UnitInfo -> b -> Constraint
f Maybe UnitInfo
u1 Maybe b
u2 Expression UA
e
propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA)
propagateFunctionCall :: Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
propagateFunctionCall (F.ExpFunctionCall UA
a SrcSpan
s Expression UA
f (F.AList UA
a' SrcSpan
s' [Argument UA]
args)) = do
(UnitInfo
info, [Argument UA]
args') <- Expression UA
-> [Argument UA] -> UnitSolver (UnitInfo, [Argument UA])
callHelper Expression UA
f [Argument UA]
args
let cons :: [Constraint]
cons = UnitInfo -> Expression UA -> [Argument UA] -> [Constraint]
forall (t :: * -> *) a b.
Foldable t =>
UnitInfo -> Expression (Analysis a) -> t b -> [Constraint]
intrinsicHelper UnitInfo
info Expression UA
f [Argument UA]
args'
Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> (Expression UA -> Expression UA)
-> Expression UA
-> StateT UnitState UnitAnalysis (Expression UA)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint ([Constraint] -> Constraint
ConConj [Constraint]
cons) (Expression UA -> Expression UA)
-> (Expression UA -> Expression UA)
-> Expression UA
-> Expression UA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> Expression UA -> Expression UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo UnitInfo
info (Expression UA -> StateT UnitState UnitAnalysis (Expression UA))
-> Expression UA -> StateT UnitState UnitAnalysis (Expression UA)
forall a b. (a -> b) -> a -> b
$ UA
-> SrcSpan -> Expression UA -> AList Argument UA -> Expression UA
forall a.
a -> SrcSpan -> Expression a -> AList Argument a -> Expression a
F.ExpFunctionCall UA
a SrcSpan
s Expression UA
f (UA -> SrcSpan -> [Argument UA] -> AList Argument UA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList UA
a' SrcSpan
s' [Argument UA]
args')
propagateFunctionCall Expression UA
_ = Name -> StateT UnitState UnitAnalysis (Expression UA)
forall a. HasCallStack => Name -> a
error Name
"received non-function-call in propagateFunctionCall"
propagateDoSpec :: F.DoSpecification UA -> UnitSolver (F.DoSpecification UA)
propagateDoSpec :: DoSpecification UA
-> StateT UnitState UnitAnalysis (DoSpecification UA)
propagateDoSpec ast :: DoSpecification UA
ast@(F.DoSpecification UA
_ SrcSpan
_ (F.StExpressionAssign UA
_ SrcSpan
_ Expression UA
e1 Expression UA
_) Expression UA
e2 Maybe (Expression UA)
m_e3) = do
DoSpecification UA
-> StateT UnitState UnitAnalysis (DoSpecification UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DoSpecification UA
-> StateT UnitState UnitAnalysis (DoSpecification UA))
-> (Maybe Constraint -> DoSpecification UA)
-> Maybe Constraint
-> StateT UnitState UnitAnalysis (DoSpecification UA)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DoSpecification UA
-> (Constraint -> DoSpecification UA)
-> Maybe Constraint
-> DoSpecification UA
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DoSpecification UA
ast ((Constraint -> DoSpecification UA -> DoSpecification UA)
-> DoSpecification UA -> Constraint -> DoSpecification UA
forall a b c. (a -> b -> c) -> b -> a -> c
flip Constraint -> DoSpecification UA -> DoSpecification UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint DoSpecification UA
ast) (Maybe Constraint
-> StateT UnitState UnitAnalysis (DoSpecification UA))
-> Maybe Constraint
-> StateT UnitState UnitAnalysis (DoSpecification UA)
forall a b. (a -> b) -> a -> b
$ [Constraint] -> Constraint
ConConj ([Constraint] -> Constraint)
-> Maybe [Constraint] -> Maybe Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe [Constraint]] -> Maybe [Constraint]
forall a. Monoid a => [a] -> a
mconcat [
(Constraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:[]) (Constraint -> [Constraint])
-> Maybe Constraint -> Maybe [Constraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UnitInfo -> UnitInfo -> Constraint)
-> Maybe UnitInfo -> Maybe UnitInfo -> Maybe Constraint
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 UnitInfo -> UnitInfo -> Constraint
ConEq (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2)
, do UnitInfo
u1 <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1
UnitInfo
u3 <- (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo (Expression UA -> Maybe UnitInfo)
-> Maybe (Expression UA) -> Maybe UnitInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Expression UA)
m_e3) Maybe UnitInfo -> Maybe UnitInfo -> Maybe UnitInfo
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` if UnitInfo -> Bool
isMonomorphic UnitInfo
u1 then Maybe UnitInfo
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero else UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnitInfo
UnitlessVar
[Constraint] -> Maybe [Constraint]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u1 UnitInfo
u3]
, do UnitInfo
u2 <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1
UnitInfo
u3 <- (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo (Expression UA -> Maybe UnitInfo)
-> Maybe (Expression UA) -> Maybe UnitInfo
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Expression UA)
m_e3) Maybe UnitInfo -> Maybe UnitInfo -> Maybe UnitInfo
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` if UnitInfo -> Bool
isMonomorphic UnitInfo
u2 then Maybe UnitInfo
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero else UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UnitInfo
UnitlessVar
[Constraint] -> Maybe [Constraint]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u2 UnitInfo
u3]
]
propagateDoSpec DoSpecification UA
_ = Name -> StateT UnitState UnitAnalysis (DoSpecification UA)
forall a. HasCallStack => Name -> a
error Name
"propagateDoSpec: called on invalid DoSpec"
propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA)
propagateStatement :: Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
propagateStatement Statement UA
stmt = case Statement UA
stmt of
F.StExpressionAssign UA
_ SrcSpan
_ Expression UA
e1 Expression UA
e2 -> Expression UA
-> Expression UA
-> Statement UA
-> StateT UnitState UnitAnalysis (Statement UA)
forall (f :: * -> *).
Annotated f =>
Expression UA -> Expression UA -> f UA -> UnitSolver (f UA)
literalAssignmentSpecialCase Expression UA
e1 Expression UA
e2 Statement UA
stmt
F.StCall UA
a SrcSpan
s Expression UA
sub (F.AList UA
a' SrcSpan
s' [Argument UA]
args) -> do
(UnitInfo
info, [Argument UA]
args') <- Expression UA
-> [Argument UA] -> UnitSolver (UnitInfo, [Argument UA])
callHelper Expression UA
sub [Argument UA]
args
let cons :: [Constraint]
cons = UnitInfo -> Expression UA -> [Argument UA] -> [Constraint]
forall (t :: * -> *) a b.
Foldable t =>
UnitInfo -> Expression (Analysis a) -> t b -> [Constraint]
intrinsicHelper UnitInfo
info Expression UA
sub [Argument UA]
args'
Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statement UA -> StateT UnitState UnitAnalysis (Statement UA))
-> (Statement UA -> Statement UA)
-> Statement UA
-> StateT UnitState UnitAnalysis (Statement UA)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constraint -> Statement UA -> Statement UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint ([Constraint] -> Constraint
ConConj [Constraint]
cons) (Statement UA -> StateT UnitState UnitAnalysis (Statement UA))
-> Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
forall a b. (a -> b) -> a -> b
$ UA -> SrcSpan -> Expression UA -> AList Argument UA -> Statement UA
forall a.
a -> SrcSpan -> Expression a -> AList Argument a -> Statement a
F.StCall UA
a SrcSpan
s Expression UA
sub (UA -> SrcSpan -> [Argument UA] -> AList Argument UA
forall (t :: * -> *) a. a -> SrcSpan -> [t a] -> AList t a
F.AList UA
a' SrcSpan
s' [Argument UA]
args')
F.StDeclaration {} -> (Declarator UA -> StateT UnitState UnitAnalysis (Declarator UA))
-> Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM Declarator UA -> StateT UnitState UnitAnalysis (Declarator UA)
propagateDeclarator Statement UA
stmt
Statement UA
_ -> Statement UA -> StateT UnitState UnitAnalysis (Statement UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Statement UA
stmt
propagateDeclarator :: F.Declarator UA -> UnitSolver (F.Declarator UA)
propagateDeclarator :: Declarator UA -> StateT UnitState UnitAnalysis (Declarator UA)
propagateDeclarator Declarator UA
decl = case Declarator UA
decl of
F.Declarator UA
_ SrcSpan
_ Expression UA
e1 DeclaratorType UA
_ Maybe (Expression UA)
_ (Just Expression UA
e2) -> Expression UA
-> Expression UA
-> Declarator UA
-> StateT UnitState UnitAnalysis (Declarator UA)
forall (f :: * -> *).
Annotated f =>
Expression UA -> Expression UA -> f UA -> UnitSolver (f UA)
literalAssignmentSpecialCase Expression UA
e1 Expression UA
e2 Declarator UA
decl
Declarator UA
_ -> Declarator UA -> StateT UnitState UnitAnalysis (Declarator UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Declarator UA
decl
literalAssignmentSpecialCase :: (F.Annotated f)
=> F.Expression UA -> F.Expression UA
-> f UA -> UnitSolver (f UA)
literalAssignmentSpecialCase :: forall (f :: * -> *).
Annotated f =>
Expression UA -> Expression UA -> f UA -> UnitSolver (f UA)
literalAssignmentSpecialCase Expression UA
e1 Expression UA
e2 f UA
ast
| Expression UA -> Bool
isLiteralZero Expression UA
e2 = f UA -> StateT UnitState UnitAnalysis (f UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f UA
ast
| Expression UA -> Bool
isLiteral Expression UA
e2
, Just UnitInfo
u1 <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1
, Just UnitLiteral{} <- Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2
, UnitInfo -> Bool
isMonomorphic UnitInfo
u1 = f UA -> StateT UnitState UnitAnalysis (f UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f UA
ast
| Bool
otherwise = f UA -> StateT UnitState UnitAnalysis (f UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f UA -> StateT UnitState UnitAnalysis (f UA))
-> f UA -> StateT UnitState UnitAnalysis (f UA)
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> UnitInfo -> Constraint)
-> Maybe UnitInfo -> Maybe UnitInfo -> f UA -> f UA
forall (f :: * -> *) a b.
Annotated f =>
(a -> b -> Constraint) -> Maybe a -> Maybe b -> f UA -> f UA
UA.maybeSetUnitConstraintF2 UnitInfo -> UnitInfo -> Constraint
ConEq (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e1) (Expression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo Expression UA
e2) f UA
ast
propagateInterface :: F.Block UA -> UnitSolver (F.Block UA)
propagateInterface :: Block UA -> StateT UnitState UnitAnalysis (Block UA)
propagateInterface b :: Block UA
b@(F.BlInterface UA
_ SrcSpan
_ (Just Expression UA
e) Bool
_ [ProgramUnit UA]
_ [Block UA]
bs) = do
let iname :: Name
iname = Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
e
case [ Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
e1 | F.StModuleProcedure UA
_ SrcSpan
_ (F.AList UA
_ SrcSpan
_ (Expression UA
e1:[Expression UA]
_)) <- [Block UA] -> [Statement UA]
forall from to. Biplate from to => from -> [to]
universeBi [Block UA]
bs :: [F.Statement UA] ] of
Name
mpname:[Name]
_ -> do
let trans :: [Constraint] -> [Constraint]
trans = (Name -> Name) -> [Constraint] -> [Constraint]
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (\ Name
x -> if Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
mpname then Name
iname else Name
x)
(TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap ((TemplateMap -> TemplateMap) -> UnitSolver ())
-> (TemplateMap -> TemplateMap) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ TemplateMap
m -> TemplateMap -> Maybe TemplateMap -> TemplateMap
forall a. a -> Maybe a -> a
fromMaybe TemplateMap
m ((\ [Constraint]
t -> Name -> [Constraint] -> TemplateMap -> TemplateMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
iname ([Constraint] -> [Constraint]
trans [Constraint]
t) TemplateMap
m) ([Constraint] -> TemplateMap)
-> Maybe [Constraint] -> Maybe TemplateMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TemplateMap -> Maybe [Constraint]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
mpname TemplateMap
m)
[Name]
_ ->
() -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Block UA -> StateT UnitState UnitAnalysis (Block UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block UA
b
propagateInterface Block UA
b = Block UA -> StateT UnitState UnitAnalysis (Block UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Block UA
b
propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)
propagatePU :: ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
propagatePU ProgramUnit UA
pu = do
let name :: Name
name = ProgramUnit UA -> Name
puName ProgramUnit UA
pu
let sname :: Name
sname = ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu
let nn :: VV
nn = (Name
name, Name
sname)
let bodyCons :: [Constraint]
bodyCons = [ Constraint
con | con :: Constraint
con@ConEq{} <- ProgramUnit UA -> [Constraint]
forall from to. Biplate from to => from -> [to]
universeBi ProgramUnit UA
pu ]
VarUnitMap
varMap <- UnitSolver VarUnitMap
getVarUnitMap
[Constraint]
givenCons <- [(Int, VV)]
-> ((Int, VV) -> StateT UnitState UnitAnalysis Constraint)
-> UnitSolver [Constraint]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (ProgramUnit UA -> [(Int, VV)]
indexedParams ProgramUnit UA
pu) (((Int, VV) -> StateT UnitState UnitAnalysis Constraint)
-> UnitSolver [Constraint])
-> ((Int, VV) -> StateT UnitState UnitAnalysis Constraint)
-> UnitSolver [Constraint]
forall a b. (a -> b) -> a -> b
$ \ (Int
i, VV
param) ->
case VV -> VarUnitMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VV
param VarUnitMap
varMap of
Just UnitParamPosAbs{} -> Constraint -> StateT UnitState UnitAnalysis Constraint
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint -> StateT UnitState UnitAnalysis Constraint)
-> (UnitInfo -> Constraint)
-> UnitInfo
-> StateT UnitState UnitAnalysis Constraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitInfo -> Constraint
ConEq ((VV, VV) -> UnitInfo
UnitParamVarAbs (VV
nn, VV
param)) (UnitInfo -> StateT UnitState UnitAnalysis Constraint)
-> UnitInfo -> StateT UnitState UnitAnalysis Constraint
forall a b. (a -> b) -> a -> b
$ (VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
i)
Just UnitInfo
u -> Constraint -> StateT UnitState UnitAnalysis Constraint
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint -> StateT UnitState UnitAnalysis Constraint)
-> (UnitInfo -> Constraint)
-> UnitInfo
-> StateT UnitState UnitAnalysis Constraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u (UnitInfo -> StateT UnitState UnitAnalysis Constraint)
-> UnitInfo -> StateT UnitState UnitAnalysis Constraint
forall a b. (a -> b) -> a -> b
$ (VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
i)
Maybe UnitInfo
_ -> Constraint -> StateT UnitState UnitAnalysis Constraint
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint -> StateT UnitState UnitAnalysis Constraint)
-> (UnitInfo -> Constraint)
-> UnitInfo
-> StateT UnitState UnitAnalysis Constraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitInfo -> Constraint
ConEq ((VV, VV) -> UnitInfo
UnitParamVarAbs (VV
nn, VV
param)) (UnitInfo -> StateT UnitState UnitAnalysis Constraint)
-> UnitInfo -> StateT UnitState UnitAnalysis Constraint
forall a b. (a -> b) -> a -> b
$ (VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
i)
let cons :: [Constraint]
cons = [Constraint]
givenCons [Constraint] -> [Constraint] -> [Constraint]
forall a. [a] -> [a] -> [a]
++ [Constraint]
bodyCons
case ProgramUnit UA
pu of F.PUFunction {} -> (TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap (Name -> [Constraint] -> TemplateMap -> TemplateMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name [Constraint]
cons)
F.PUSubroutine {} -> (TemplateMap -> TemplateMap) -> UnitSolver ()
modifyTemplateMap (Name -> [Constraint] -> TemplateMap -> TemplateMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name [Constraint]
cons)
ProgramUnit UA
_ -> () -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let pu' :: ProgramUnit UA
pu' = case (ProgramUnit UA
pu, ProgramUnit UA -> [(Int, VV)]
indexedParams ProgramUnit UA
pu) of
(F.PUFunction {}, (Int
0, VV
res):[(Int, VV)]
_) -> UnitInfo -> ProgramUnit UA -> ProgramUnit UA
forall (f :: * -> *). Annotated f => UnitInfo -> f UA -> f UA
UA.setUnitInfo ((VV, Int) -> UnitInfo
UnitParamPosAbs (VV
nn, Int
0) UnitInfo -> Maybe UnitInfo -> UnitInfo
forall a. a -> Maybe a -> a
`fromMaybe` VV -> VarUnitMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VV
res VarUnitMap
varMap) ProgramUnit UA
pu
(ProgramUnit UA, [(Int, VV)])
_ -> ProgramUnit UA
pu
ProgramUnit UA -> StateT UnitState UnitAnalysis (ProgramUnit UA)
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Constraint -> ProgramUnit UA -> ProgramUnit UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint ([Constraint] -> Constraint
ConConj [Constraint]
cons) ProgramUnit UA
pu')
callHelper :: F.Expression UA -> [F.Argument UA] -> UnitSolver (UnitInfo, [F.Argument UA])
callHelper :: Expression UA
-> [Argument UA] -> UnitSolver (UnitInfo, [Argument UA])
callHelper Expression UA
nexp [Argument UA]
args = do
let name :: VV
name = (Expression UA -> Name
forall a. Expression (Analysis a) -> Name
varName Expression UA
nexp, Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
nexp)
let ctyp :: Maybe ConstructType
ctyp = IDType -> Maybe ConstructType
FA.idCType (IDType -> Maybe ConstructType)
-> Maybe IDType -> Maybe ConstructType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UA -> Maybe IDType
forall a. Analysis a -> Maybe IDType
FA.idType (Expression UA -> UA
forall a. Expression a -> a
forall (f :: * -> *) a. Annotated f => f a -> a
F.getAnnotation Expression UA
nexp)
Int
callId <- case Maybe ConstructType
ctyp of
Just ConstructType
FA.CTExternal -> Int -> UnitSolver Int
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
Maybe ConstructType
_ -> UnitSolver Int
freshId
let eachArg :: Int -> Argument UA -> Argument UA
eachArg Int
i arg :: Argument UA
arg@(F.Argument UA
_ SrcSpan
_ Maybe Name
_ ArgumentExpression UA
e)
| Just UnitInfo
u <- ArgumentExpression UA -> Maybe UnitInfo
forall (f :: * -> *). Annotated f => f UA -> Maybe UnitInfo
UA.getUnitInfo ArgumentExpression UA
e = Constraint -> Argument UA -> Argument UA
forall (f :: * -> *). Annotated f => Constraint -> f UA -> f UA
UA.setConstraint (UnitInfo -> UnitInfo -> Constraint
ConEq UnitInfo
u ((VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
name, Int
i, Int
callId))) Argument UA
arg
| Bool
otherwise = Argument UA
arg
let args' :: [Argument UA]
args' = (Int -> Argument UA -> Argument UA)
-> [Int] -> [Argument UA] -> [Argument UA]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Argument UA -> Argument UA
eachArg [Int
1..] [Argument UA]
args
let info :: UnitInfo
info = (VV, Int, Int) -> UnitInfo
UnitParamPosUse (VV
name, Int
0, Int
callId)
(UnitInfo, [Argument UA]) -> UnitSolver (UnitInfo, [Argument UA])
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnitInfo
info, [Argument UA]
args')
intrinsicHelper :: Foldable t => UnitInfo -> F.Expression (FA.Analysis a) -> t b -> [Constraint]
intrinsicHelper :: forall (t :: * -> *) a b.
Foldable t =>
UnitInfo -> Expression (Analysis a) -> t b -> [Constraint]
intrinsicHelper (UnitParamPosUse (VV
_, Int
_, Int
callId)) f :: Expression (Analysis a)
f@(F.ExpValue Analysis a
_ SrcSpan
_ (F.ValIntrinsic Name
_)) t b
args
| Just (UnitInfo
retU, [UnitInfo]
argUs) <- Name -> Maybe (UnitInfo, [UnitInfo])
intrinsicLookup Name
sname = (Int -> UnitInfo -> Constraint)
-> [Int] -> [UnitInfo] -> [Constraint]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> UnitInfo -> Constraint
eachArg [Int
0..Int
numArgs] (UnitInfo
retUUnitInfo -> [UnitInfo] -> [UnitInfo]
forall a. a -> [a] -> [a]
:[UnitInfo]
argUs)
where
numArgs :: Int
numArgs = t b -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t b
args
sname :: Name
sname = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
f
vname :: Name
vname = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
f
eachArg :: Int -> UnitInfo -> Constraint
eachArg Int
i UnitInfo
u = UnitInfo -> UnitInfo -> Constraint
ConEq ((VV, Int, Int) -> UnitInfo
UnitParamPosUse ((Name
vname, Name
sname), Int
i, Int
callId)) (Int -> UnitInfo -> UnitInfo
forall a. Data a => Int -> a -> a
instantiate Int
callId UnitInfo
u)
intrinsicHelper UnitInfo
_ Expression (Analysis a)
_ t b
_ = []
intrinsicLookup :: F.Name -> Maybe (UnitInfo, [UnitInfo])
intrinsicLookup :: Name -> Maybe (UnitInfo, [UnitInfo])
intrinsicLookup Name
sname = do
(UnitInfo
retU, [UnitInfo]
argUs) <- Name
-> Map Name (UnitInfo, [UnitInfo]) -> Maybe (UnitInfo, [UnitInfo])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
sname Map Name (UnitInfo, [UnitInfo])
intrinsicUnits
(UnitInfo, [UnitInfo]) -> Maybe (UnitInfo, [UnitInfo])
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfo
retU, if Name
sname Name -> GivenVarSet -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` GivenVarSet
specialCaseArbitraryArgs then [UnitInfo] -> [UnitInfo]
forall a. HasCallStack => [a] -> [a]
cycle [UnitInfo]
argUs else [UnitInfo]
argUs)
genUnitLiteral :: UnitSolver UnitInfo
genUnitLiteral :: StateT UnitState UnitAnalysis UnitInfo
genUnitLiteral = Int -> UnitInfo
UnitLiteral (Int -> UnitInfo)
-> UnitSolver Int -> StateT UnitState UnitAnalysis UnitInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitSolver Int
freshId
genParamLit :: UnitSolver UnitInfo
genParamLit :: StateT UnitState UnitAnalysis UnitInfo
genParamLit = Int -> UnitInfo
UnitParamLitAbs (Int -> UnitInfo)
-> UnitSolver Int -> StateT UnitState UnitAnalysis UnitInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitSolver Int
freshId
modifyPUBlocksM :: Monad m => ([F.Block a] -> m [F.Block a]) -> F.ProgramUnit a -> m (F.ProgramUnit a)
modifyPUBlocksM :: forall (m :: * -> *) a.
Monad m =>
([Block a] -> m [Block a]) -> ProgramUnit a -> m (ProgramUnit a)
modifyPUBlocksM [Block a] -> m [Block a]
f ProgramUnit a
pu = case ProgramUnit a
pu of
F.PUMain a
a SrcSpan
s Maybe Name
n [Block a]
b Maybe [ProgramUnit a]
pus -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a
-> SrcSpan
-> Maybe Name
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> Maybe Name
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUMain a
a SrcSpan
s Maybe Name
n [Block a]
b' Maybe [ProgramUnit a]
pus
F.PUModule a
a SrcSpan
s Name
n [Block a]
b Maybe [ProgramUnit a]
pus -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a
-> SrcSpan
-> Name
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> Name
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUModule a
a SrcSpan
s Name
n [Block a]
b' Maybe [ProgramUnit a]
pus
F.PUSubroutine a
a SrcSpan
s PrefixSuffix a
r Name
n Maybe (AList Expression a)
p [Block a]
b Maybe [ProgramUnit a]
subs -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a
-> SrcSpan
-> PrefixSuffix a
-> Name
-> Maybe (AList Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> PrefixSuffix a
-> Name
-> Maybe (AList Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUSubroutine a
a SrcSpan
s PrefixSuffix a
r Name
n Maybe (AList Expression a)
p [Block a]
b' Maybe [ProgramUnit a]
subs
F.PUFunction a
a SrcSpan
s Maybe (TypeSpec a)
r PrefixSuffix a
rec Name
n Maybe (AList Expression a)
p Maybe (Expression a)
res [Block a]
b Maybe [ProgramUnit a]
subs -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a
-> SrcSpan
-> Maybe (TypeSpec a)
-> PrefixSuffix a
-> Name
-> Maybe (AList Expression a)
-> Maybe (Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
forall a.
a
-> SrcSpan
-> Maybe (TypeSpec a)
-> PrefixSuffix a
-> Name
-> Maybe (AList Expression a)
-> Maybe (Expression a)
-> [Block a]
-> Maybe [ProgramUnit a]
-> ProgramUnit a
F.PUFunction a
a SrcSpan
s Maybe (TypeSpec a)
r PrefixSuffix a
rec Name
n Maybe (AList Expression a)
p Maybe (Expression a)
res [Block a]
b' Maybe [ProgramUnit a]
subs
F.PUBlockData a
a SrcSpan
s Maybe Name
n [Block a]
b -> (([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a))
-> m [Block a] -> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Block a] -> ProgramUnit a) -> m [Block a] -> m (ProgramUnit a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Block a] -> m [Block a]
f [Block a]
b) (([Block a] -> ProgramUnit a) -> m (ProgramUnit a))
-> ([Block a] -> ProgramUnit a) -> m (ProgramUnit a)
forall a b. (a -> b) -> a -> b
$ \ [Block a]
b' -> a -> SrcSpan -> Maybe Name -> [Block a] -> ProgramUnit a
forall a. a -> SrcSpan -> Maybe Name -> [Block a] -> ProgramUnit a
F.PUBlockData a
a SrcSpan
s Maybe Name
n [Block a]
b'
F.PUComment {} -> ProgramUnit a -> m (ProgramUnit a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgramUnit a
pu
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
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
constantExpression :: F.Expression a -> Maybe Double
constantExpression :: forall a. Expression a -> Maybe Double
constantExpression Expression a
expr = FNum -> Double
fnumToDouble (FNum -> Double) -> Maybe FNum -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression a -> Maybe FNum
forall {a}. Expression a -> Maybe FNum
ce Expression a
expr
where
ce :: Expression a -> Maybe FNum
ce Expression a
e = case Expression a
e of
(F.ExpValue a
_ SrcSpan
_ (F.ValInteger Name
i Maybe (KindParam a)
_)) -> FNum -> Maybe FNum
forall a. a -> Maybe a
Just (FNum -> Maybe FNum) -> FNum -> Maybe FNum
forall a b. (a -> b) -> a -> b
$ Integer -> FNum
FInt (Integer -> FNum) -> Integer -> FNum
forall a b. (a -> b) -> a -> b
$ Name -> Integer
forall a. Read a => Name -> a
read Name
i
(F.ExpValue a
_ SrcSpan
_ (F.ValReal RealLit
r Maybe (KindParam a)
_)) -> FNum -> Maybe FNum
forall a. a -> Maybe a
Just (FNum -> Maybe FNum) -> FNum -> Maybe FNum
forall a b. (a -> b) -> a -> b
$ Double -> FNum
FReal (Double -> FNum) -> Double -> FNum
forall a b. (a -> b) -> a -> b
$ RealLit -> Double
forall a. (Fractional a, Read a) => RealLit -> a
readRealLit RealLit
r
(F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Addition Expression a
e1 Expression a
e2) -> (FNum -> FNum -> FNum) -> Maybe FNum -> Maybe FNum -> Maybe FNum
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 FNum -> FNum -> FNum
fAdd (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
(F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Subtraction Expression a
e1 Expression a
e2) -> (FNum -> FNum -> FNum) -> Maybe FNum -> Maybe FNum -> Maybe FNum
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 FNum -> FNum -> FNum
fSub (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
(F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Multiplication Expression a
e1 Expression a
e2) -> (FNum -> FNum -> FNum) -> Maybe FNum -> Maybe FNum -> Maybe FNum
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 FNum -> FNum -> FNum
fMul (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
(F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Division Expression a
e1 Expression a
e2) -> Maybe FNum -> Maybe FNum -> Maybe FNum
fDivMaybe (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
(F.ExpBinary a
_ SrcSpan
_ BinaryOp
F.Exponentiation Expression a
e1 Expression a
e2) -> (FNum -> FNum -> FNum) -> Maybe FNum -> Maybe FNum -> Maybe FNum
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 FNum -> FNum -> FNum
fPow (Expression a -> Maybe FNum
ce Expression a
e1) (Expression a -> Maybe FNum
ce Expression a
e2)
Expression a
_ -> Maybe FNum
forall a. Maybe a
Nothing
isOp :: BinOpKind -> F.BinaryOp -> Bool
isOp :: BinOpKind -> BinaryOp -> Bool
isOp BinOpKind
cat = (BinOpKind -> BinOpKind -> Bool
forall a. Eq a => a -> a -> Bool
== BinOpKind
cat) (BinOpKind -> Bool) -> (BinaryOp -> BinOpKind) -> BinaryOp -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinaryOp -> BinOpKind
binOpKind
data BinOpKind = AddOp | MulOp | DivOp | PowerOp | LogicOp | RelOp deriving BinOpKind -> BinOpKind -> Bool
(BinOpKind -> BinOpKind -> Bool)
-> (BinOpKind -> BinOpKind -> Bool) -> Eq BinOpKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BinOpKind -> BinOpKind -> Bool
== :: BinOpKind -> BinOpKind -> Bool
$c/= :: BinOpKind -> BinOpKind -> Bool
/= :: BinOpKind -> BinOpKind -> Bool
Eq
binOpKind :: F.BinaryOp -> BinOpKind
binOpKind :: BinaryOp -> BinOpKind
binOpKind BinaryOp
F.Addition = BinOpKind
AddOp
binOpKind BinaryOp
F.Subtraction = BinOpKind
AddOp
binOpKind BinaryOp
F.Multiplication = BinOpKind
MulOp
binOpKind BinaryOp
F.Division = BinOpKind
DivOp
binOpKind BinaryOp
F.Exponentiation = BinOpKind
PowerOp
binOpKind BinaryOp
F.Concatenation = BinOpKind
AddOp
binOpKind BinaryOp
F.GT = BinOpKind
RelOp
binOpKind BinaryOp
F.GTE = BinOpKind
RelOp
binOpKind BinaryOp
F.LT = BinOpKind
RelOp
binOpKind BinaryOp
F.LTE = BinOpKind
RelOp
binOpKind BinaryOp
F.EQ = BinOpKind
RelOp
binOpKind BinaryOp
F.NE = BinOpKind
RelOp
binOpKind BinaryOp
F.Or = BinOpKind
LogicOp
binOpKind BinaryOp
F.And = BinOpKind
LogicOp
binOpKind BinaryOp
F.XOr = BinOpKind
LogicOp
binOpKind BinaryOp
F.Equivalent = BinOpKind
RelOp
binOpKind BinaryOp
F.NotEquivalent = BinOpKind
RelOp
binOpKind (F.BinCustom Name
_) = BinOpKind
RelOp
getImportedVariables :: UnitSolver (M.Map VV UnitInfo)
getImportedVariables :: UnitSolver VarUnitMap
getImportedVariables = do
ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile
NameParamMap
nmap <- UnitSolver NameParamMap
getNameParamMap
let useToPair :: Use (Analysis a) -> VV
useToPair (F.UseID Analysis a
_ SrcSpan
_ Expression (Analysis a)
e) = (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e, Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e)
useToPair (F.UseRename Analysis a
_ SrcSpan
_ Expression (Analysis a)
e1 Expression (Analysis a)
_) = (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e1, Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
e1)
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))
| F.StUse UA
_ SrcSpan
_ Expression UA
e Maybe ModuleNature
_ Only
only Maybe (AList Use UA)
alist <- ProgramFile UA -> [Statement UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf :: [ F.Statement UA ]
, let mod :: Name
mod = Expression UA -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression UA
e
, let uses :: [VV]
uses = (Use UA -> VV) -> [Use UA] -> [VV]
forall a b. (a -> b) -> [a] -> [b]
map Use UA -> VV
forall {a}. Use (Analysis a) -> VV
useToPair ([Use UA] -> Maybe [Use UA] -> [Use UA]
forall a. a -> Maybe a -> a
fromMaybe [] (AList Use UA -> [Use UA]
forall (t :: * -> *) a. AList t a -> [t a]
F.aStrip (AList Use UA -> [Use UA])
-> Maybe (AList Use UA) -> Maybe [Use UA]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (AList Use UA)
alist))
, Just Map NameParamKey [UnitInfo]
npkmap <- [ProgramUnitName
-> NameParamMap -> Maybe (Map NameParamKey [UnitInfo])
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Name -> ProgramUnitName
F.Named Name
mod) NameParamMap
nmap]
, let f :: (NameParamKey, b) -> Maybe (NameParamKey, b)
f (NameParamKey
npk, b
ui) = case NameParamKey
npk of
(NPKVariable (Name
var, Name
src))
| Only
only Only -> Only -> Bool
forall a. Eq a => a -> a -> Bool
== Only
F.Permissive -> (NameParamKey, b) -> Maybe (NameParamKey, b)
forall a. a -> Maybe a
Just (VV -> NameParamKey
NPKVariable (Name
var, Name
src Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
`fromMaybe` Name -> [VV] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
var [VV]
uses), b
ui)
| Just Name
src' <- Name -> [VV] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
var [VV]
uses -> (NameParamKey, b) -> Maybe (NameParamKey, b)
forall a. a -> Maybe a
Just (VV -> NameParamKey
NPKVariable (Name
var, Name
src'), b
ui)
NameParamKey
_ -> Maybe (NameParamKey, b)
forall a. Maybe a
Nothing
]
VarUnitMap -> UnitSolver VarUnitMap
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarUnitMap -> UnitSolver VarUnitMap)
-> VarUnitMap -> UnitSolver VarUnitMap
forall a b. (a -> b) -> a -> b
$ [(VV, UnitInfo)] -> VarUnitMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (VV
vv, [UnitInfo] -> UnitInfo
forall (t :: * -> *). Foldable t => t UnitInfo -> UnitInfo
foldUnits [UnitInfo]
units) | (NPKVariable VV
vv, [UnitInfo]
units) <- Map NameParamKey [UnitInfo] -> [(NameParamKey, [UnitInfo])]
forall k a. Map k a -> [(k, a)]
M.toList ([Map NameParamKey [UnitInfo]] -> Map NameParamKey [UnitInfo]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions [Map NameParamKey [UnitInfo]]
modnmaps) ]
logDebugNoOrigin :: Text -> UnitSolver ()
logDebugNoOrigin :: Text -> UnitSolver ()
logDebugNoOrigin Text
msg = do
ProgramFile UA
pf <- (UnitState -> ProgramFile UA) -> UnitSolver (ProgramFile UA)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets UnitState -> ProgramFile UA
usProgramFile
ProgramFile UA -> Text -> UnitSolver ()
forall a. Spanned a => a -> Text -> UnitSolver ()
forall e w (m :: * -> *) a.
(MonadLogger e w m, Spanned a) =>
a -> Text -> m ()
logDebug' ProgramFile UA
pf Text
msg
dumpConsM :: String -> Constraints -> UnitSolver ()
dumpConsM :: Name -> [Constraint] -> UnitSolver ()
dumpConsM Name
str = Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Constraint] -> Text) -> [Constraint] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Constraint] -> Name) -> [Constraint] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> Name)
-> ([Constraint] -> [Name]) -> [Constraint] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int -> Char -> Name
forall a. Int -> a -> [a]
replicate Int
50 Char
'-', Name
str Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
":"][Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++) ([Name] -> [Name])
-> ([Constraint] -> [Name]) -> [Constraint] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++[Int -> Char -> Name
forall a. Int -> a -> [a]
replicate Int
50 Char
'^']) ([Name] -> [Name])
-> ([Constraint] -> [Name]) -> [Constraint] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Constraint -> Name
f
where
f :: Constraint -> Name
f (ConEq UnitInfo
u1 UnitInfo
u2) = [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)
f (ConConj [Constraint]
cons) = Name -> [Name] -> Name
forall a. [a] -> [[a]] -> [a]
intercalate Name
" && " ((Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Constraint -> Name
f [Constraint]
cons)
debugLogging :: UnitSolver ()
debugLogging :: UnitSolver ()
debugLogging = do
(Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Constraint] -> Text) -> [Constraint] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Constraint] -> Name) -> [Constraint] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> Name)
-> ([Constraint] -> [Name]) -> [Constraint] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> Name
" ***AbsConstraint: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2))) ([Constraint] -> UnitSolver ())
-> UnitSolver [Constraint] -> UnitSolver ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UnitSolver [Constraint]
extractConstraints
ProgramFile UA
pf <- UnitSolver (ProgramFile UA)
getProgramFile
[Constraint]
cons <- UnitSolver [Constraint]
getConstraints
VarUnitMap
vum <- UnitSolver VarUnitMap
getVarUnitMap
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ [ Name
" " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ UnitInfo -> Name
forall a. Show a => a -> Name
show UnitInfo
info Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" :: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
n | ((Name
n, Name
_), UnitInfo
info) <- VarUnitMap -> [(VV, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList VarUnitMap
vum ]
Text -> UnitSolver ()
logDebugNoOrigin Text
""
UnitAliasMap
uam <- UnitSolver UnitAliasMap
getUnitAliasMap
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ [ Name
" " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
n Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" = " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ UnitInfo -> Name
forall a. Show a => a -> Name
show UnitInfo
info | (Name
n, UnitInfo
info) <- UnitAliasMap -> [(Name, UnitInfo)]
forall k a. Map k a -> [(k, a)]
M.toList UnitAliasMap
uam ]
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> Name
" ***Constraint: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) [Constraint]
cons
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ [Constraint] -> Text
forall a. Show a => a -> Text
describeShow [Constraint]
cons Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
[ProgramUnit UA]
-> (ProgramUnit UA -> UnitSolver ()) -> UnitSolver ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (ProgramFile UA -> [ProgramUnit UA]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile UA
pf) ((ProgramUnit UA -> UnitSolver ()) -> UnitSolver ())
-> (ProgramUnit UA -> UnitSolver ()) -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ \ ProgramUnit UA
pu -> case ProgramUnit UA
pu of
F.PUFunction {}
| Just (ConConj [Constraint]
con) <- ProgramUnit UA -> Maybe Constraint
forall (f :: * -> *). Annotated f => f UA -> Maybe Constraint
UA.getConstraint ProgramUnit UA
pu ->
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (ProgramUnit UA -> Name
puName ProgramUnit UA
pu Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
":")Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:(Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> Name
" constraint: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) [Constraint]
con
F.PUSubroutine {}
| Just (ConConj [Constraint]
con) <- ProgramUnit UA -> Maybe Constraint
forall (f :: * -> *). Annotated f => f UA -> Maybe Constraint
UA.getConstraint ProgramUnit UA
pu ->
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (ProgramUnit UA -> Name
puName ProgramUnit UA
pu Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
":")Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:(Constraint -> Name) -> [Constraint] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (ConEq UnitInfo
u1 UnitInfo
u2) -> Name
" constraint: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u1) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) [Constraint]
con
ProgramUnit UA
_ -> () -> UnitSolver ()
forall a. a -> StateT UnitState UnitAnalysis a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let (Matrix Double
lhsM, Matrix Double
rhsM, [Int]
_, Array Int UnitInfo
lhsColA, Array Int UnitInfo
rhsColA) = [Constraint]
-> (Matrix Double, Matrix Double, [Int], Array Int UnitInfo,
Array Int UnitInfo)
constraintsToMatrices [Constraint]
cons
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nLHS Cols:"
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Array Int UnitInfo -> Text
forall a. Show a => a -> Text
describeShow Array Int UnitInfo
lhsColA
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nRHS Cols:"
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Array Int UnitInfo -> Text
forall a. Show a => a -> Text
describeShow Array Int UnitInfo
rhsColA
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nLHS M:"
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double -> Text
forall a. Show a => a -> Text
describeShow Matrix Double
lhsM
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nRHS M:"
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double -> Text
forall a. Show a => a -> Text
describeShow Matrix Double
rhsM
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nAUG M:"
let augM :: Matrix Double
augM = if Matrix Double -> Int
forall t. Matrix t -> Int
H.rows Matrix Double
rhsM Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Matrix Double -> Int
forall t. Matrix t -> Int
H.cols Matrix Double
rhsM Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Matrix Double
lhsM else [[Matrix Double]] -> Matrix Double
forall t. Element t => [[Matrix t]] -> Matrix t
H.fromBlocks [[Matrix Double
lhsM, Matrix Double
rhsM]]
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double -> Text
forall a. Show a => a -> Text
describeShow Matrix Double
augM
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nSolved (hnf) M:"
let hnfM :: Matrix Double
hnfM = Matrix Double -> Matrix Double
Flint.hnf Matrix Double
augM
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double -> Text
forall a. Show a => a -> Text
describeShow Matrix Double
hnfM
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nSolved (normHNF) M:"
let (Matrix Double
solvedM, [Int]
newColIndices) = Matrix Double -> (Matrix Double, [Int])
Flint.normHNF Matrix Double
augM
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> (Matrix Double -> Text) -> Matrix Double -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matrix Double -> Text
forall a. Show a => a -> Text
describeShow (Matrix Double -> UnitSolver ()) -> Matrix Double -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double
solvedM
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Text
"newColIndices = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Int] -> Text
forall a. Show a => a -> Text
describeShow [Int]
newColIndices
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nLHS Cols with newColIndices:"
let lhsCols :: [UnitInfo]
lhsCols = Array Int UnitInfo -> [UnitInfo]
forall i e. Array i e -> [e]
A.elems Array Int UnitInfo
lhsColA [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ (Int -> UnitInfo) -> [Int] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Array Int UnitInfo
lhsColA Array Int UnitInfo -> Int -> UnitInfo
forall i e. Ix i => Array i e -> i -> e
A.!) [Int]
newColIndices
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text)
-> ([(Int, UnitInfo)] -> Name) -> [(Int, UnitInfo)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> Name)
-> ([(Int, UnitInfo)] -> [Name]) -> [(Int, UnitInfo)] -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, UnitInfo) -> Name) -> [(Int, UnitInfo)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Int, UnitInfo) -> Name
forall a. Show a => a -> Name
show ([(Int, UnitInfo)] -> Text) -> [(Int, UnitInfo)] -> Text
forall a b. (a -> b) -> a -> b
$ [Int] -> [UnitInfo] -> [(Int, UnitInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0::Int)..] [UnitInfo]
lhsCols
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------"
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Text
"Rank LHS: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
describeShow (Matrix Double -> Int
forall t. Field t => Matrix t -> Int
H.rank Matrix Double
lhsM)
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------"
let augA :: Matrix Double
augA = if Matrix Double -> Int
forall t. Matrix t -> Int
H.rows Matrix Double
rhsM Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Matrix Double -> Int
forall t. Matrix t -> Int
H.cols Matrix Double
rhsM Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Matrix Double
lhsM else [[Matrix Double]] -> Matrix Double
forall t. Element t => [[Matrix t]] -> Matrix t
H.fromBlocks [[Matrix Double
lhsM, Matrix Double
rhsM]]
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ()) -> Text -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Text
"Rank Augmented: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
describeShow (Matrix Double -> Int
forall t. Field t => Matrix t -> Int
H.rank Matrix Double
augA)
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nGenUnitAssignments:"
let unitAssignments :: [([UnitInfo], UnitInfo)]
unitAssignments = [Constraint] -> [([UnitInfo], UnitInfo)]
genUnitAssignments [Constraint]
cons
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ (([UnitInfo], UnitInfo) -> Name)
-> [([UnitInfo], UnitInfo)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ ([UnitInfo]
u1s, UnitInfo
u2) -> Name
" ***UnitAssignment: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show [UnitInfo]
u1s Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2) Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
"\n") [([UnitInfo], UnitInfo)]
unitAssignments
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------"
let unitAssignmentsSBV :: [(UnitInfo, UnitInfo)]
unitAssignmentsSBV = [Constraint] -> [(UnitInfo, UnitInfo)]
BackendSBV.genUnitAssignments [Constraint]
cons
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> ([Name] -> Text) -> [Name] -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a. Describe a => a -> Text
describe (Name -> Text) -> ([Name] -> Name) -> [Name] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Name
unlines ([Name] -> UnitSolver ()) -> [Name] -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ ((UnitInfo, UnitInfo) -> Name) -> [(UnitInfo, UnitInfo)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (\ (UnitInfo
u1s, UnitInfo
u2) -> Name
" ***UnitAssignmentSBV: " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ UnitInfo -> Name
forall a. Show a => a -> Name
show UnitInfo
u1s Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" === " Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ [UnitInfo] -> Name
forall a. Show a => a -> Name
show (UnitInfo -> [UnitInfo]
flattenUnits UnitInfo
u2)) [(UnitInfo, UnitInfo)]
unitAssignmentsSBV
Text -> UnitSolver ()
logDebugNoOrigin Text
"--------------------------------------------------\nProvenance:"
let (Matrix Double
augM', Provenance
p) = Matrix Double -> (Matrix Double, Provenance)
provenance Matrix Double
augM
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> (Matrix Double -> Text) -> Matrix Double -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matrix Double -> Text
forall a. Show a => a -> Text
describeShow (Matrix Double -> UnitSolver ()) -> Matrix Double -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Matrix Double
augM'
Text -> UnitSolver ()
logDebugNoOrigin (Text -> UnitSolver ())
-> (Provenance -> Text) -> Provenance -> UnitSolver ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Provenance -> Text
forall a. Show a => a -> Text
describeShow (Provenance -> UnitSolver ()) -> Provenance -> UnitSolver ()
forall a b. (a -> b) -> a -> b
$ Provenance
p
puName :: F.ProgramUnit UA -> F.Name
puName :: ProgramUnit UA -> Name
puName ProgramUnit UA
pu
| F.Named Name
n <- ProgramUnit UA -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
FA.puName ProgramUnit UA
pu = Name
n
| Bool
otherwise = Name
"_nameless"
puSrcName :: F.ProgramUnit UA -> F.Name
puSrcName :: ProgramUnit UA -> Name
puSrcName ProgramUnit UA
pu
| F.Named Name
n <- ProgramUnit UA -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
FA.puSrcName ProgramUnit UA
pu = Name
n
| Bool
otherwise = Name
"_nameless"
specialCaseArbitraryArgs :: S.Set F.Name
specialCaseArbitraryArgs :: GivenVarSet
specialCaseArbitraryArgs = [Name] -> GivenVarSet
forall a. Ord a => [a] -> Set a
S.fromList [ Name
"max", Name
"max0", Name
"amax1", Name
"dmax1", Name
"amax0", Name
"max1"
, Name
"min", Name
"min0", Name
"amin1", Name
"dmin1", Name
"amin0", Name
"min1" ]
intrinsicUnits :: M.Map F.Name (UnitInfo, [UnitInfo])
intrinsicUnits :: Map Name (UnitInfo, [UnitInfo])
intrinsicUnits =
[(Name, (UnitInfo, [UnitInfo]))] -> Map Name (UnitInfo, [UnitInfo])
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ (Name
"transfer", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
, (Name
"abs", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"iabs", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"dabs", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"cabs", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"aimag", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"aint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"dint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"anint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"dnint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"cmplx", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"conjg", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"dble", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"dim", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"idim", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"ddim", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"dprod", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"ceiling", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"floor", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"int", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"ifix", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"idint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"maxval", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"minval", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"max", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"min", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"min0", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"amin1", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"dmin1", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"amin0", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"min1", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"mod", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
, (Name
"modulo", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
, (Name
"amod", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
, (Name
"dmod", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
, (Name
"nint", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"real", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"float", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"sngl", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"sign", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
, (Name
"isign", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
, (Name
"dsign", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'b", Name
"'b")]))
, (Name
"present", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [UnitInfo
UnitlessVar]))
, (Name
"sqrt", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [UnitInfo -> Double -> UnitInfo
UnitPow (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")) Double
2]))
, (Name
"dsqrt", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [UnitInfo -> Double -> UnitInfo
UnitPow (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")) Double
2]))
, (Name
"csqrt", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [UnitInfo -> Double -> UnitInfo
UnitPow (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")) Double
2]))
, (Name
"exp", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dexp", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"cexp", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"alog", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dlog", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"clog", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"alog10", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dlog10", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"sin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dsin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"csin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"cos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dcos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"ccos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"tan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dtan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"asin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dasin", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"acos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dacos", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"atan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"datan", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"atan2", (UnitInfo
UnitlessVar, [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"datan2", (UnitInfo
UnitlessVar, [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
, (Name
"sinh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dsinh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"cosh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dcosh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"tanh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"dtanh", (UnitInfo
UnitlessVar, [UnitInfo
UnitlessVar]))
, (Name
"iand", (VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), [VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a"), VV -> UnitInfo
UnitParamEAPAbs (Name
"'a", Name
"'a")]))
]
compileUnits :: UnitOpts -> ModFiles -> F.ProgramFile Annotation -> IO ModFile
compileUnits :: UnitOpts -> ModFiles -> ProgramFile A -> IO ModFile
compileUnits UnitOpts
uo ModFiles
mfs ProgramFile A
pf = do
let (ProgramFile UA
pf', ModuleMap
_, TypeEnv
_) = ModFiles
-> ProgramFile (UnitAnnotation A)
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall a.
Data a =>
ModFiles
-> ProgramFile a -> (ProgramFile (Analysis a), ModuleMap, TypeEnv)
withCombinedEnvironment ModFiles
mfs (ProgramFile (UnitAnnotation A)
-> (ProgramFile UA, ModuleMap, TypeEnv))
-> (ProgramFile A -> ProgramFile (UnitAnnotation A))
-> ProgramFile A
-> (ProgramFile UA, ModuleMap, TypeEnv)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (A -> UnitAnnotation A)
-> ProgramFile A -> ProgramFile (UnitAnnotation A)
forall a b. (a -> b) -> ProgramFile a -> ProgramFile b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap A -> UnitAnnotation A
forall a. a -> UnitAnnotation a
UA.mkUnitAnnotation (ProgramFile A -> (ProgramFile UA, ModuleMap, TypeEnv))
-> ProgramFile A -> (ProgramFile UA, ModuleMap, TypeEnv)
forall a b. (a -> b) -> a -> b
$ ProgramFile A
pf
let analysis :: AnalysisT () () IO (CompiledUnits, UnitState)
analysis = ReaderT UnitEnv (AnalysisT () () IO) (CompiledUnits, UnitState)
-> UnitEnv -> AnalysisT () () IO (CompiledUnits, UnitState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (UnitSolver CompiledUnits
-> ReaderT UnitEnv (AnalysisT () () IO) (CompiledUnits, UnitState)
forall a. UnitSolver a -> UnitAnalysis (a, UnitState)
runInference UnitSolver CompiledUnits
runCompileUnits) (UnitEnv -> AnalysisT () () IO (CompiledUnits, UnitState))
-> UnitEnv -> AnalysisT () () IO (CompiledUnits, UnitState)
forall a b. (a -> b) -> a -> b
$
UnitEnv
{ unitOpts :: UnitOpts
unitOpts = UnitOpts
uo
, unitProgramFile :: ProgramFile A
unitProgramFile = ProgramFile A
pf
}
AnalysisReport () () (CompiledUnits, UnitState)
report <- Name
-> LogOutput IO
-> LogLevel
-> ModFiles
-> AnalysisT () () IO (CompiledUnits, UnitState)
-> IO (AnalysisReport () () (CompiledUnits, UnitState))
forall (m :: * -> *) e w a.
(Monad m, Describe e, Describe w) =>
Name
-> LogOutput m
-> LogLevel
-> ModFiles
-> AnalysisT e w m a
-> m (AnalysisReport e w a)
runAnalysisT (ProgramFile A -> Name
forall a. ProgramFile a -> Name
F.pfGetFilename ProgramFile A
pf) (Bool -> LogOutput IO
forall (m :: * -> *). Monad m => Bool -> LogOutput m
logOutputNone Bool
True) LogLevel
LogError ModFiles
mfs AnalysisT () () IO (CompiledUnits, UnitState)
analysis
case AnalysisReport () () (CompiledUnits, UnitState)
report AnalysisReport () () (CompiledUnits, UnitState)
-> Getting
(First CompiledUnits)
(AnalysisReport () () (CompiledUnits, UnitState))
CompiledUnits
-> Maybe CompiledUnits
forall s a. s -> Getting (First a) s a -> Maybe a
^? (AnalysisResult () (CompiledUnits, UnitState)
-> Const
(First CompiledUnits)
(AnalysisResult () (CompiledUnits, UnitState)))
-> AnalysisReport () () (CompiledUnits, UnitState)
-> Const
(First CompiledUnits)
(AnalysisReport () () (CompiledUnits, UnitState))
forall e w r1 r2 (f :: * -> *).
Functor f =>
(AnalysisResult e r1 -> f (AnalysisResult e r2))
-> AnalysisReport e w r1 -> f (AnalysisReport e w r2)
arResult ((AnalysisResult () (CompiledUnits, UnitState)
-> Const
(First CompiledUnits)
(AnalysisResult () (CompiledUnits, UnitState)))
-> AnalysisReport () () (CompiledUnits, UnitState)
-> Const
(First CompiledUnits)
(AnalysisReport () () (CompiledUnits, UnitState)))
-> ((CompiledUnits -> Const (First CompiledUnits) CompiledUnits)
-> AnalysisResult () (CompiledUnits, UnitState)
-> Const
(First CompiledUnits)
(AnalysisResult () (CompiledUnits, UnitState)))
-> Getting
(First CompiledUnits)
(AnalysisReport () () (CompiledUnits, UnitState))
CompiledUnits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CompiledUnits, UnitState)
-> Const (First CompiledUnits) (CompiledUnits, UnitState))
-> AnalysisResult () (CompiledUnits, UnitState)
-> Const
(First CompiledUnits)
(AnalysisResult () (CompiledUnits, UnitState))
forall e r1 r2 (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p r1 (f r2) -> p (AnalysisResult e r1) (f (AnalysisResult e r2))
_ARSuccess (((CompiledUnits, UnitState)
-> Const (First CompiledUnits) (CompiledUnits, UnitState))
-> AnalysisResult () (CompiledUnits, UnitState)
-> Const
(First CompiledUnits)
(AnalysisResult () (CompiledUnits, UnitState)))
-> ((CompiledUnits -> Const (First CompiledUnits) CompiledUnits)
-> (CompiledUnits, UnitState)
-> Const (First CompiledUnits) (CompiledUnits, UnitState))
-> (CompiledUnits -> Const (First CompiledUnits) CompiledUnits)
-> AnalysisResult () (CompiledUnits, UnitState)
-> Const
(First CompiledUnits)
(AnalysisResult () (CompiledUnits, UnitState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompiledUnits -> Const (First CompiledUnits) CompiledUnits)
-> (CompiledUnits, UnitState)
-> Const (First CompiledUnits) (CompiledUnits, UnitState)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
(CompiledUnits, UnitState)
(CompiledUnits, UnitState)
CompiledUnits
CompiledUnits
_1 of
Just CompiledUnits
cu -> ModFile -> IO ModFile
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgramFile UA -> CompiledUnits -> ModFile
genUnitsModFile ProgramFile UA
pf' CompiledUnits
cu)
Maybe CompiledUnits
Nothing -> Name -> IO ModFile
forall a. Name -> IO a
forall (m :: * -> *) a. MonadFail m => Name -> m a
fail Name
"compileUnits: units analysis failed"