packages feed

camfort 0.904 → 0.905

raw patch · 110 files changed

+12649/−3234 lines, 110 filesdep +lensdep +mmorphdep +silentlydep ~GenericPrettydep ~directorydep ~fgl

Dependencies added: lens, mmorph, silently, singletons, template-haskell, temporary, time, verifiable-expressions, vinyl

Dependency ranges changed: GenericPretty, directory, fgl, fortran-src, lattices, optparse-applicative, syb, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,7 @@+## 0.905 (18 May, 2018)++* Greatly improved units-of-measure support+* Separate verification of modules+* Prototype invariants checking feature+* Implicit-none check on program units+* Fortran 95 support
camfort.cabal view
@@ -1,11 +1,11 @@ name:                   camfort-version:                0.904+version:                0.905 synopsis:               CamFort - Cambridge Fortran infrastructure description:            CamFort is a tool for the analysis, transformation, verification of Fortran code. homepage:               https://camfort.github.io bug-reports:            https://github.com/camfort/camfort/issues -copyright:              2012-2016 University of Cambridge+copyright:              2012-2018 University of Cambridge author:                 Dominic Orchard, Matthew Danish, Mistral Contrastin, Andrew Rice, Oleg Oshmyan maintainer:             dom.orchard@gmail.com @@ -16,12 +16,13 @@ build-type:             Simple category:               Language -cabal-version:          >= 1.18-tested-with:            GHC >= 7.8+cabal-version:          1.18+tested-with:            GHC >= 8.2  extra-source-files:     tests/fixtures/Specification/Stencils/*.f                         tests/fixtures/Specification/Units/*.f90-			tests/fixtures/Transformation/*.f90+                        tests/fixtures/Transformation/*.f90+                        CHANGELOG.md  source-repository head   type: git@@ -30,17 +31,24 @@ executable camfort   main-is: src/Main.hs   build-depends:        base >= 4.6 && < 5,-                        optparse-applicative >= 0.13.2.0 && < 0.14,+                        directory >= 1.2 && < 2,+                        optparse-applicative >= 0.14 && < 0.15,                         camfort   default-language: Haskell2010  library   hs-source-dirs:       src-  build-tools:          alex, happy-  exposed-modules:      Camfort.Analysis.Annotations+  build-tools:          alex >= 3.1, happy >= 1.19+  extra-libraries:      flint+  exposed-modules:      Camfort.Analysis+                        Camfort.Analysis.Logger+                        Camfort.Analysis.Annotations                         Camfort.Analysis.CommentAnnotator+                        Camfort.Analysis.ModFile                         Camfort.Analysis.Simple                         Camfort.Specification.Parser++                        Camfort.Specification.Stencils.Analysis                         Camfort.Specification.Stencils.Annotation                         Camfort.Specification.Stencils.CheckBackend                         Camfort.Specification.Stencils.CheckFrontend@@ -55,31 +63,72 @@                         Camfort.Specification.Stencils.Parser.Types                         Camfort.Specification.Stencils.Synthesis                         Camfort.Specification.Stencils+                         Camfort.Specification.Units-                        Camfort.Specification.Units.InferenceFrontend+                        Camfort.Specification.Units.Analysis+                        Camfort.Specification.Units.Analysis.Consistent+                        Camfort.Specification.Units.Analysis.Criticals+                        Camfort.Specification.Units.Analysis.Infer+                        Camfort.Specification.Units.Annotation                         Camfort.Specification.Units.InferenceBackend+                        Camfort.Specification.Units.InferenceBackendFlint+                        Camfort.Specification.Units.InferenceBackendSBV+                        Camfort.Specification.Units.BackendTypes                         Camfort.Specification.Units.Environment+                        Camfort.Specification.Units.ModFile                         Camfort.Specification.Units.Monad+                        Camfort.Specification.Units.MonadTypes                         Camfort.Specification.Units.Parser                         Camfort.Specification.Units.Parser.Types                         Camfort.Specification.Units.Synthesis++                        Camfort.Specification.Hoare+                        Camfort.Specification.Hoare.Annotation+                        Camfort.Specification.Hoare.Parser+                        Camfort.Specification.Hoare.Parser.Types+                        Camfort.Specification.Hoare.Lexer+                        Camfort.Specification.Hoare.Syntax+                        Camfort.Specification.Hoare.Translate+                        Camfort.Specification.Hoare.CheckFrontend+                        Camfort.Specification.Hoare.CheckBackend+                         Camfort.Transformation.CommonBlockElim                         Camfort.Transformation.DeadCode                         Camfort.Transformation.EquivalenceElim+                         Camfort.Helpers                         Camfort.Helpers.Syntax                         Camfort.Helpers.Vec+                        Camfort.Helpers.TypeLevel                         Camfort.Functionality                         Camfort.Input                         Camfort.Output                         Camfort.Reprint +                        Language.Fortran.Model+                        Language.Fortran.Model.Singletons+                        Language.Fortran.Model.Types+                        Language.Fortran.Model.Types.Match+                        Language.Fortran.Model.Translate+                        Language.Fortran.Model.Repr+                        Language.Fortran.Model.Repr.Prim+                        Language.Fortran.Model.Vars+                        Language.Fortran.Model.Op+                        Language.Fortran.Model.Op.Eval+                        Language.Fortran.Model.Op.Core+                        Language.Fortran.Model.Op.Core.Match+                        Language.Fortran.Model.Op.Core.Core+                        Language.Fortran.Model.Op.Core.Eval+                        Language.Fortran.Model.Op.Meta+                        Language.Fortran.Model.Op.High+                        Language.Fortran.Model.Util+   build-depends:        base >= 4.6 && < 5,                         ghc-prim >= 0.3.1.0 && < 0.6,                         containers >= 0.5.0.0 && < 0.6,                         uniplate >= 1.6.10 && < 1.7,                         syz >= 0.2 && < 0.3,-                        syb >= 0.4 && < 0.7,+                        syb >= 0.4 && < 0.8,                         matrix >= 0.2.2 && < 0.4,                         hmatrix >= 0.15 && < 0.19,                         mtl >= 2.1 && < 2.3,@@ -87,23 +136,34 @@                         array >= 0.4 && < 0.6,                         directory >= 1.2 && < 1.4,                         transformers >= 0.4 && < 0.6,-                        vector >= 0.1 && < 0.12,-                        GenericPretty >= 1.2 && < 1.3,-                        fortran-src >= 0.2.0.0 && < 0.3,+                        vector >= 0.1 && < 0.13,+                        GenericPretty >= 1.2.2 && < 1.3,+                        fortran-src >= 0.2.1.1 && < 0.3,                         filepath >= 1.4 && < 1.5,                         bytestring >= 0.10 && < 0.11,-                        fgl >= 5.5 && < 5.6,+                        fgl >= 5.6 && < 5.7,                         binary >= 0.8.3.0 && < 0.9,-                        lattices == 1.5.*,+                        lattices >= 1.7.1 && < 1.8,                         sbv >= 7.0 && < 8,-                        partial-order >= 0.1.2.1 && < 0.1.3+                        partial-order >= 0.1.2.1 && < 0.1.3,+                        lens >= 4.15.1 && < 5,+                        mmorph >= 1.0.9 && < 2,+                        singletons >= 2.2 && < 3,+                        template-haskell >= 2.11 && < 3,+                        vinyl >= 0.6 && < 1.0,+                        verifiable-expressions >= 0.4+   default-language: Haskell2010  test-suite spec   type:                 exitcode-stdio-1.0   main-is:              Spec.hs   hs-source-dirs:       tests-  other-modules:        Camfort.Analysis.CommentAnnotatorSpec+  other-modules:        Camfort.Analysis.TestUtils+                        Camfort.Analysis.CommentAnnotatorSpec+                        Camfort.Analysis.ModFileSpec+                        Camfort.Analysis.ImplicitNoneSpec+                        Camfort.FunctionalitySpec                         Camfort.ReprintSpec                         Camfort.Specification.ParserSpec                         Camfort.Specification.Stencils.CheckSpec@@ -113,19 +173,23 @@                         Camfort.Specification.Stencils.InferenceBackendSpec                         Camfort.Specification.Stencils.ModelSpec                         Camfort.Specification.StencilsSpec+                        Camfort.Specification.Units.Analysis.ConsistentSpec+                        Camfort.Specification.Units.Analysis.CriticalsSpec+                        Camfort.Specification.Units.Analysis.InferSpec                         Camfort.Specification.Units.InferenceBackendSpec-                        Camfort.Specification.Units.InferenceFrontendSpec                         Camfort.Specification.Units.ParserSpec-                        Camfort.Specification.UnitsSpec+                        Camfort.Specification.Hoare.ParserSpec                         Camfort.Transformation.CommonSpec                         Camfort.Transformation.EquivalenceElimSpec+   build-depends:        base >= 4.6 && < 5,                         containers >= 0.5.0.0 && < 0.6,                         filepath >= 1.4 && < 1.5,                         directory >= 1.2 && < 2,                         hspec >= 2.2 && < 3,                         QuickCheck >= 2.8 && < 3,-                        fortran-src >= 0.2.0.0 && < 0.3,+                        fgl >= 5.6 && < 5.7,+                        fortran-src >= 0.2.1.1 && < 0.3,                         uniplate >= 1.6.10 && < 1.7,                         mtl >= 2.1 && < 2.3,                         bytestring >= 0.10 && < 0.11,@@ -133,8 +197,13 @@                         hmatrix >= 0.15 && < 0.19,                         text >= 0.11.2.3 && < 1.3,                         binary >= 0.8.3.0 && < 0.9,-                        lattices == 1.5.*,+                        lattices >= 1.7.1 && < 1.8,                         sbv >= 7.0 && < 8,                         partial-order >= 0.1.2.1 && < 0.1.3,+                        silently == 1.2.*,+                        temporary >= 1.2.0.4 && < 1.3,+                        lens >= 4.15.1 && < 5,+                        time,+                        verifiable-expressions >= 0.4,                         camfort   default-language: Haskell2010
+ src/Camfort/Analysis.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++{-# OPTIONS_GHC -Wall            #-}++{- |+Module      :  Camfort.Analysis+Description :  Analysis on fortran files.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental++This module defines the 'AnalysisT' monad transformer, which encapsulates common+functionality for analyses:++- Logging via the 'MonadLogger' class+- Early exit via 'failAnalysis' or 'failAnalysis\''+- Error recovery via 'catchAnalysisT' or 'loggingAnalysisError'+- Providing access to the analysis environment via 'analysisModFiles'++-}++module Camfort.Analysis+  (+  -- * Analysis monad+    AnalysisT+  , PureAnalysis+  -- * Combinators+  , mapAnalysisT+  , generalizePureAnalysis+  , MonadAnalysis(..)+  , failAnalysis'+  , catchAnalysisT+  , loggingAnalysisError+  , analysisLiftLogger+  -- * Analysis results+  , AnalysisResult(..)+  , _ARFailure+  , _ARSuccess+  , AnalysisReport(..)+  , arMessages+  , arResult+  , describeReport+  , putDescribeReport+  -- * Running analyses+  , runAnalysisT+  -- * Logging+  -- | See "Camfort.Analysis.Logger" for more detailed documentation.++  , MonadLogger+    ( logError+    , logError'+    , logWarn+    , logWarn'+    , logInfo+    , logInfo'+    , logInfoNoOrigin+    , logDebug+    , logDebug'+    )+  -- ** Message origins+  , Origin(..)+  , atSpanned+  , atSpannedInFile+  -- ** Log outputs+  , LogOutput+  , logOutputStd+  , logOutputNone+  -- ** Log levels+  , LogLevel(..)+  -- ** 'Describe' class+  , Describe(..)+  , describeShow+  , (<>)++  -- ** Exit Code of reports+  , ExitCodeOfReport(..)+  ) where++import           Control.Monad.Except+import           Control.Monad.Morph+import           Control.Monad.Reader+import qualified Control.Monad.RWS              as Lazy+import           Control.Monad.RWS.Strict+import qualified Control.Monad.State            as Lazy+import           Control.Monad.State.Strict+import qualified Control.Monad.Writer           as Lazy+import           Control.Monad.Writer.Strict++import           Control.Lens++import qualified Data.Text.Lazy                 as Lazy+import qualified Data.Text.Lazy.Builder         as Builder+import qualified Data.Text.Lazy.IO              as Lazy+import           Data.List (maximumBy)+import           Data.Ord (comparing)++import qualified Language.Fortran.Util.ModFile  as F+import qualified Language.Fortran.Util.Position as F++import           Camfort.Analysis.Logger++--------------------------------------------------------------------------------+--  Analysis Monad+--------------------------------------------------------------------------------++-- | The analysis monad transformer. Will usually be based on 'Identity' (see+-- 'PureAnalysis') or 'IO'.+--+-- Has error messages of type @e@ and warnings of type @w@.+newtype AnalysisT e w m a =+  AnalysisT+  { getAnalysisT ::+      ExceptT (LogMessage e) (ReaderT F.ModFiles (LoggerT e w m)) a+  }+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadState s+    , MonadWriter w'+    , MonadLogger e w+    )++-- | A pure analysis computation which cannot do any 'IO'.+type PureAnalysis e w = AnalysisT e w Identity++instance MonadTrans (AnalysisT e w) where+  lift = AnalysisT . lift . lift . lift++-- | As per the 'MFunctor' instance for 'LoggerT', a hoisted analysis cannot+-- output logs on the fly.+instance MFunctor (AnalysisT e w) where+  hoist f (AnalysisT x) = AnalysisT (hoist (hoist (hoist f)) x)++instance MonadError e' m => MonadError e' (AnalysisT e w m) where+  throwError = lift . throwError+  catchError action handle = AnalysisT . ExceptT $+    let run = runExceptT . getAnalysisT+    in catchError (run action) (run . handle)++instance MonadReader r m => MonadReader r (AnalysisT e w m) where+  ask = lift ask++  local f (AnalysisT (ExceptT (ReaderT k))) =+    AnalysisT . ExceptT . ReaderT $ local f . k++--------------------------------------------------------------------------------+--  Liftable functions+--------------------------------------------------------------------------------++class (MonadLogger e w m) => MonadAnalysis e w m where+  -- | Report a critical error in the analysis at a particular source location+  -- and exit early.+  failAnalysis :: Origin -> e -> m a++  -- | Get the 'F.ModFiles' from the analysis environment.+  analysisModFiles :: m F.ModFiles++  default failAnalysis+    :: (MonadTrans t, MonadAnalysis e w m', m ~ t m') => Origin -> e -> m a++  default analysisModFiles+    :: (MonadTrans t, MonadAnalysis e w m', m ~ t m') => m F.ModFiles++  failAnalysis o = lift . failAnalysis o+  analysisModFiles = lift analysisModFiles++instance (Describe e, Describe w, Monad m) => MonadAnalysis e w (AnalysisT e w m) where+  analysisModFiles = AnalysisT ask++  failAnalysis origin e = do+    let msg = LogMessage (Just origin) e+    AnalysisT (throwError msg)++instance MonadAnalysis e w m => MonadAnalysis e w (ReaderT r m)+instance MonadAnalysis e w m => MonadAnalysis e w (ExceptT e' m)+instance MonadAnalysis e w m => MonadAnalysis e w (StateT s m)+instance (MonadAnalysis e w m, Monoid w') => MonadAnalysis e w (WriterT w' m)+instance MonadAnalysis e w m => MonadAnalysis e w (Lazy.StateT s m)+instance (MonadAnalysis e w m, Monoid w') => MonadAnalysis e w (Lazy.WriterT w' m)+instance (MonadAnalysis e w m, Monoid w') => MonadAnalysis e w (RWST r w' s m)+instance (MonadAnalysis e w m, Monoid w') => MonadAnalysis e w (Lazy.RWST r w' s m)++--------------------------------------------------------------------------------+--  Combinators+--------------------------------------------------------------------------------++-- | Change the error and warning types in an analysis. To change the+-- underlying monad use 'hoist'.+mapAnalysisT :: (Monad m) => (e -> e') -> (w -> w') -> AnalysisT e w m a -> AnalysisT e' w' m a+mapAnalysisT mapError mapWarn =+  AnalysisT .+  (hoist (hoist (mapLoggerT mapError mapWarn)) . withExceptT (over lmMsg mapError)) .+  getAnalysisT++-- | Given a pure analysis action, it can be generalized to run in any 'Monad'.+-- Since the original analysis was pure, it could not have logged anything as it+-- ran. The new analysis cannot log anything as it runs either, even it is based+-- on 'IO'.+generalizePureAnalysis :: (Monad m) => PureAnalysis e w a -> AnalysisT e w m a+generalizePureAnalysis = hoist generalize++-- | Report a critical failure in the analysis at no particular source location+-- and exit early.+failAnalysis'+  :: (MonadAnalysis e w m, F.Spanned o)+  => o -> e -> m a+failAnalysis' originElem e = do+  origin <- atSpanned originElem+  failAnalysis origin e++-- | Run the given analysis and recover with the given handler function if it+-- fails.+catchAnalysisT+  :: (Monad m)+  => (LogMessage e -> AnalysisT e w m a) -> AnalysisT e w m a -> AnalysisT e w m a+catchAnalysisT handle action =+  AnalysisT (catchError (getAnalysisT action) (getAnalysisT . handle))++-- | Run the given analysis. If it succeeds, return its result value. Otherwise,+-- log the error it creates and return 'Nothing'.+--+-- This allows errors in analysis sub-programs to be collected rather than+-- halting the entire analysis.+loggingAnalysisError+  :: (Monad m, Describe w, Describe e)+  => AnalysisT e w m a -> AnalysisT e w m (Maybe a)+loggingAnalysisError =+  catchAnalysisT ( fmap (const Nothing)+                 . recordLogMessage+                 . MsgError)+  . fmap Just++-- | Given a logging computation, lift it into an analysis monad.+analysisLiftLogger+  :: (Monad m, Describe w, Describe e)+  => LoggerT e w m a -> AnalysisT e w m a+analysisLiftLogger = AnalysisT . lift . lift++--------------------------------------------------------------------------------+--  Analysis Results+--------------------------------------------------------------------------------++data AnalysisResult e r+  = ARFailure Origin e+  | ARSuccess r+  deriving (Show, Eq, Functor)++makePrisms ''AnalysisResult++-- | When an analysis is run, it produces a report consisting of the logs it+-- collect as it ran. In addition, it either fails at a certain location or+-- succeeds with a result value.+data AnalysisReport e w r =+  AnalysisReport+  { _arSourceFile :: !FilePath+  , _arMessages   :: ![SomeMessage e w]+  , _arResult     :: !(AnalysisResult e r)+  }+  deriving (Show, Eq, Functor)++makeLenses ''AnalysisReport++-- | Produce a human-readable version of an 'AnalysisReport', at the given+-- verbosity level. Giving 'Nothing' for the log level hides all logs.+describeReport+  :: (Describe e, Describe w, Describe r)+  => Text -> Maybe LogLevel -> AnalysisReport e w r -> Lazy.Text+describeReport analysisName level report = Builder.toLazyText . execWriter $ do+  let describeMessage lvl msg = do+        let tell' x = do+              tell " -"+              tellDescribe x+              tell "\n"+        case msg of+          m@(MsgError _) -> tell' m+          m@(MsgWarn  _) | lvl >= LogWarn -> tell' m+          m@(MsgInfo  _) | lvl >= LogInfo -> tell' m+          m@(MsgDebug _) | lvl >= LogDebug -> tell' m+          _              -> return ()++  -- Output file name+  tell "Finished running "+  tellDescribe analysisName+  tell " on input '"+  tellDescribe (report ^. arSourceFile)+  tell "' ...\n"++  -- Output logs if requested+  case level of+    Just lvl | not (null (report ^. arMessages)) -> do+      tell $ "Logs:\n"+      forM_ (report ^. arMessages) (describeMessage lvl)+      tell "\n"+      tell "Result... "+    _ -> return ()++  let loggedWarnings = arMessages . traverse . _MsgWarn+      loggedErrors = arMessages . traverse . _MsgError++      hadErrors = notNullOf loggedErrors report+      hadWarnings = notNullOf loggedWarnings report++  case report ^. arResult of+    ARFailure origin e -> do+      tell $ "CRITICAL ERROR:\n"+      tell $ describeBuilder origin+      tell ": "+      tell $ describeBuilder e+    ARSuccess r -> do+      tell $ case (hadErrors, hadWarnings) of+        (True, _) -> "OK, but with errors:"+        (False, True) -> "OK, but with warnings:"+        (False, False) -> "OK:"+      tell "\n"+      tell $ describeBuilder r+++putDescribeReport+  :: (Describe e, Describe w, Describe r, MonadIO m)+  => Text -> Maybe LogLevel -> AnalysisReport e w r -> m ()+putDescribeReport analysisName level = liftIO . Lazy.putStrLn . describeReport analysisName level+++--------------------------------------------------------------------------------+--  Running Analyses+--------------------------------------------------------------------------------++-- | Run an analysis computation and collect the report.+runAnalysisT+  :: (Monad m, Describe e, Describe w)+  => FilePath+  -- ^ The name of the file the analysis is being run on. This is only used for+  -- logging.+  -> LogOutput m+  -- ^ The logging output function, e.g. 'logOutputStd' for standard output or+  -- 'logOutputNone' for no output.+  -> LogLevel+  -- ^ The logging verbosity level.+  -> F.ModFiles+  -- ^ The list of analysis modfiles.+  -> AnalysisT e w m a+  -- ^ The analysis transformer to run.+  -> m (AnalysisReport e w a)+runAnalysisT fileName output logLevel mfs analysis = do++  (res1, messages) <-+    runLoggerT fileName output logLevel .+    flip runReaderT mfs .+    runExceptT .+    getAnalysisT $+    analysis++  let result = case res1 of+        Right x -> ARSuccess x+        Left (LogMessage (Just origin) e) -> ARFailure origin e+        Left _ -> error "impossible: failure without origin"++  return $ AnalysisReport+    { _arSourceFile = fileName+    , _arMessages = messages+    , _arResult = result+    }++++--------------------------------------------------------------------------------+--  Exit codes+--------------------------------------------------------------------------------++class ExitCodeOfReport a where+  -- | Interpret an exit code from report (default 0)+  exitCodeOf :: a -> Int+  exitCodeOf _ = 0+  -- | Interpret an exit code from a set of reports (default: maximises absolute value)+  exitCodeOfSet :: [a] -> Int+  exitCodeOfSet [] = 0+  exitCodeOfSet s = maximumBy (comparing abs) . map exitCodeOf $ s++instance ExitCodeOfReport r => ExitCodeOfReport (AnalysisReport e w r) where+  exitCodeOf report = case report ^. arResult of+    ARFailure _ _ -> 1+    ARSuccess r -> exitCodeOf r++instance ExitCodeOfReport () where+  exitCodeOf () = 0++instance ExitCodeOfReport Text where+  exitCodeOf _ = 0
src/Camfort/Analysis/Annotations.hs view
@@ -14,6 +14,7 @@    limitations under the License. -} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}@@ -23,40 +24,24 @@   -- * Annotation Datatype     Annotation(..)   , A-  , UA   , unitAnnotation   -- ** Predicates   , pRefactored   -- ** Transformation Helpers   , onPrev   -- ** Specification Annotation Helpers-  , getAstSpec-  , getParseSpec-  , getRegionSpec-  , giveAstSpec-  , giveParseSpec-  , giveRegionSpec   -- * Other Helpers-  , Report   , buildCommentText   ) where  import Data.Data import Data.Maybe (isJust) -import Camfort.Specification.Units.Environment-import qualified Camfort.Specification.Units.Parser.Types as P-import Camfort.Analysis.CommentAnnotator-import qualified Camfort.Specification.Stencils.Syntax as StencilSpec-import qualified Camfort.Specification.Stencils.Parser.Types as StencilComment- import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA import Language.Fortran.ParserMonad (FortranVersion(Fortran90)) import qualified Language.Fortran.Util.Position as FU -type Report = String- type A = Annotation data Annotation =   A { unitVar        :: Int@@ -66,86 +51,22 @@     , newNode        :: Bool     -- indicates a node which is being deleted     , deleteNode    :: Bool-    -- Stencil specification annotations-    -- TODO: move these into their own annotation-    , stencilSpec    :: Maybe SpecAnnotation-    , stencilBlock   :: Maybe (F.Block (FA.Analysis Annotation))     } deriving (Eq, Show, Typeable, Data) --- | Specification annotation.-data SpecAnnotation-  -- | Unprocessed syntax tree.-  = ParserSpec StencilComment.Specification-  -- | Region definition.-  | RegionDecl StencilSpec.RegionDecl-  -- | Normalised AST specification.-  | ASTSpec StencilSpec.SpecDecls-  deriving (Eq, Show, Data)---- | Set the annotation's stencil specification to a parsed specification.-giveParseSpec :: StencilComment.Specification -> Annotation -> Annotation-giveParseSpec spec ann = ann { stencilSpec = Just $ ParserSpec spec }---- | Set the annotation's stencil specification to a region alias.-giveRegionSpec :: StencilSpec.RegionDecl -> Annotation -> Annotation-giveRegionSpec spec ann = ann { stencilSpec = Just $ RegionDecl spec }---- | Set the annotation's stencil specification to a normalized specification.-giveAstSpec :: StencilSpec.SpecDecls -> Annotation -> Annotation-giveAstSpec spec ann = ann { stencilSpec = Just $ ASTSpec spec }---- | Retrieve a parsed specification from an annotation.-getParseSpec :: Annotation -> Maybe StencilComment.Specification-getParseSpec s = case stencilSpec s of-  (Just (ParserSpec spec)) -> Just spec-  _                        -> Nothing---- | Retrieve a region environment from an annotation.-getRegionSpec :: Annotation -> Maybe StencilSpec.RegionDecl-getRegionSpec s = case stencilSpec s of-  (Just (RegionDecl renv)) -> Just renv-  _                        -> Nothing---- | Retrieve a normalized specification from an annotation.-getAstSpec :: Annotation -> Maybe StencilSpec.SpecDecls-getAstSpec s = case stencilSpec s of-  (Just (ASTSpec ast)) -> Just ast-  _                    -> Nothing- -- Predicate on whether an AST has been refactored pRefactored :: Annotation -> Bool pRefactored = isJust . refactored +unitAnnotation :: Annotation unitAnnotation = A   { unitVar      = 0    , number       = 0    , refactored   = Nothing    , newNode      = False    , deleteNode   = False-   , stencilSpec  = Nothing-   , stencilBlock = Nothing  }  ----------------------------------------------------- Convenience name for a common annotation type.-type UA = FA.Analysis (UnitAnnotation A)---- Instances for embedding parsed specifications into the AST-instance ASTEmbeddable UA P.UnitStatement where-  annotateWithAST ann ast =-    onPrev (\ ann -> ann { unitSpec = Just ast }) ann---- Link annotation comments to declaration statements-instance Linkable UA where-  link ann (b@(F.BlStatement _ _ _ F.StDeclaration {})) =-      onPrev (\ ann -> ann { unitBlock = Just b }) ann-  link ann b = ann-  linkPU ann (pu@(F.PUFunction {})) =-      onPrev (\ ann -> ann { unitPU = Just pu }) ann-  linkPU ann (pu@(F.PUSubroutine {})) =-      onPrev (\ ann -> ann { unitPU = Just pu }) ann-  linkPU ann b = ann- -- Helpers for transforming the 'previous' annotation onPrev :: (a -> a) -> FA.Analysis a -> FA.Analysis a onPrev f ann = ann { FA.prevAnnotation = f (FA.prevAnnotation ann) }
+ src/Camfort/Analysis/Logger.hs view
@@ -0,0 +1,554 @@+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++{-# OPTIONS_GHC -Wall            #-}++{-|++Provides logging for analyses. 'MonadLogger' is a type class for monads which+support logging. 'LoggerT' is a concrete monad transformer instantiating the+class.++As a logger runs, it may print out log messages on the fly (depending on the+provided 'LogOutput' function). It also collects logs to be inspected at the end+of the computation.++A log message must usually include an 'Origin', which describes where in a+Fortran source file the message originated. This is made more convenient via+functions such as 'logWarn\'', which produces an 'Origin' based on a piece of+Fortran syntax, along with a default source file stored in the environment.++Log messages each come with an associated 'LogLevel':++- 'LogError' is for hard errors which will often cause the computation to fail.+- 'LogWarn' is for messages about things that are likely to cause problems.+- 'LogInfo' is for general information about what the computation is doing.+- 'LogDebug' is for extra-verbose output that helps with debugging, but which+  will be uninteresting to most users.++-}+module Camfort.Analysis.Logger+  (+  -- * Conversion to text description+    Describe(..)+  , tellDescribe+  , describeShow+  , builderToStrict+  , Builder+  , Text+  , (<>)+  -- * Messages+  , Origin(..)+  , oFile+  , oSpan+  , LogLevel(..)+  , LogMessage(..)+  , lmOrigin+  , lmMsg+  , SomeMessage(..)+  , _MsgError+  , _MsgWarn+  , _MsgInfo+  , _MsgDebug+  -- * Logging monad+  , MonadLogger(..)+  , atSpanned+  , atSpannedInFile+  , LoggerT+  , mapLoggerT+  -- * Running a logger+  , LogOutput+  , logOutputStd+  , logOutputNone+  , runLoggerT+  ) where++import qualified Data.Semigroup                 as SG+import           Data.Void                      (Void)++import           Control.Lens++import           Control.Monad.Except+import           Control.Monad.Morph+import           Control.Monad.Reader+import qualified Control.Monad.RWS              as Lazy+import           Control.Monad.RWS.Strict+import qualified Control.Monad.State            as Lazy+import           Control.Monad.State.Strict+import qualified Control.Monad.Writer           as Lazy+import           Control.Monad.Writer.Strict++import           Data.Text                      (Text)+import qualified Data.Text.IO                   as Text+import qualified Data.Text.Lazy                 as Lazy+import           Data.Text.Lazy.Builder         (Builder)+import qualified Data.Text.Lazy.Builder         as Builder++import qualified Language.Fortran.Util.Position as F++--------------------------------------------------------------------------------+--  'Describe' class+--------------------------------------------------------------------------------++-- TODO: More 'Describe' instances for built-in types.++-- | A type class for efficiently converting values to human-readable output.+-- Can be automatically instantiated for 'Show' types, but this will not be very+-- human-readable for a lot of types.+class Describe a where+  -- | Convert the value to a human-readable output as a strict 'Text' value.+  describe :: a -> Text++  -- | Convert the value to human-readable output in a text 'Builder' which can+  -- be efficiently concatenated with other 'Builder's.+  describeBuilder :: a -> Builder++  default describeBuilder :: Show a => a -> Builder+  describe = builderToStrict . describeBuilder+  describeBuilder = Builder.fromString . show++instance Describe F.SrcSpan+instance Describe Text where+  describeBuilder = Builder.fromText+instance Describe [Char] where+  describeBuilder = Builder.fromString+instance Describe () where+  describeBuilder = const mempty+instance Describe Int+instance Describe Integer+instance Describe Float+instance Describe Double+instance Describe Void++-- | A convenience combinator to directly convert a lazy text 'Builder' to a+-- strict 'Text' value.+builderToStrict :: Builder -> Text+builderToStrict = Lazy.toStrict . Builder.toLazyText++-- | Write a 'Describe'-able value directly into a writer monad.+tellDescribe :: (MonadWriter Builder m, Describe a) => a -> m ()+tellDescribe = tell . describeBuilder++-- | Convert a 'Show'-able value directly to strict 'Text'. Useful when you have+-- a 'Show' instance but not a 'Describe' instance.+describeShow :: (Show a) => a -> Text+describeShow = describe . show++--------------------------------------------------------------------------------+--  Messages+--------------------------------------------------------------------------------++-- | A message origin, containing a file and a source span.+data Origin =+  Origin+  { _oFile :: FilePath+  , _oSpan :: F.SrcSpan+  }+  deriving (Show, Eq)++makeLenses ''Origin++instance Describe Origin where+  describeBuilder origin =+    "at [" <> Builder.fromString (origin ^. oFile) <>+    ", " <> describeBuilder (origin ^. oSpan) <> "]"++-- | A logging level. At each logging level, only produce output at that level or lower.+data LogLevel+  = LogError+  -- ^ At level 'LogError', only error messages are shown.+  | LogWarn+  -- ^ At level 'LogWarn', error and warning messages are shown.+  | LogInfo+  -- ^ At level 'LogInfo', error, warning and information messages are shown.+  | LogDebug+  -- ^ At level 'LogDebug', error, warning, information and debug output is+  -- shown.+  deriving (Show, Eq, Ord)++instance Describe LogLevel where+  describeBuilder LogError = "ERROR"+  describeBuilder LogWarn  = "WARN"+  describeBuilder LogInfo  = "INFO"+  describeBuilder LogDebug = "DEBUG"++-- | A logged message with an origin and a message value.+data LogMessage a =+  LogMessage+  { _lmOrigin :: Maybe Origin+  , _lmMsg    :: a+  }+  deriving (Show, Eq, Functor, Foldable, Traversable)++makeLenses ''LogMessage++instance Describe a => Describe (LogMessage a) where+  describeBuilder msg =+    maybe "" describeBuilder (msg ^. lmOrigin) <>+    ": " <> describeBuilder (msg ^. lmMsg)++-- | A message at one of the four 'LogLevel's.+data SomeMessage e w+  = MsgError (LogMessage e)+  | MsgWarn (LogMessage w)+  | MsgInfo (LogMessage Text)+  | MsgDebug (LogMessage Text)+  deriving (Show, Eq)++makePrisms ''SomeMessage++someMessageOrigin :: Lens' (SomeMessage e w) (Maybe Origin)+someMessageOrigin =+  lens+  (preview $+    (_MsgError . lmOrigin `failing`+     _MsgWarn  . lmOrigin `failing`+     _MsgInfo  . lmOrigin `failing`+     _MsgDebug . lmOrigin+    ) . _Just)+  (flip $ \o ->+   set (_MsgError . lmOrigin) o .+   set (_MsgWarn  . lmOrigin) o .+   set (_MsgInfo  . lmOrigin) o .+   set (_MsgDebug . lmOrigin) o)+++instance (Describe e, Describe w) => Describe (SomeMessage e w) where+  describeBuilder msg = case msg of+    MsgError m -> "ERROR: " <> describeBuilder m+    MsgWarn  m -> "WARN: "  <> describeBuilder m+    MsgInfo  m -> "INFO: "  <> describeBuilder m+    MsgDebug m -> "DEBUG: " <> describeBuilder m++--------------------------------------------------------------------------------+--  'MonadLogger' class+--------------------------------------------------------------------------------++-- | Make an origin at the source span of a piece of Fortran syntax, in the+-- current file.+atSpanned :: (MonadLogger e w m, F.Spanned a) => a -> m Origin+atSpanned astElem = do+  sf <- getDefaultSourceFile+  let sp = F.getSpan astElem+  return $ Origin sf sp++-- | Make an origin at the source span of a piece of Fortran syntax, in the given+-- file.+atSpannedInFile :: (F.Spanned a) => FilePath -> a -> Origin+atSpannedInFile sf = Origin sf . F.getSpan++-- | MTL-style type class for monads that support logging.+class Monad m => MonadLogger e w m | m -> e w where+  -- | Set the default source file, i.e. the file in which messages originate by+  -- default.+  setDefaultSourceFile :: FilePath -> m ()++  -- | Get the current default source file, i.e. the file in which messages+  -- originate by default.+  getDefaultSourceFile :: m FilePath++  -- | Record a log message. Output it based on the 'LogOutput' function used+  -- and store it in the collected logs.+  recordLogMessage :: SomeMessage e w -> m ()++  -- | Log an error message at the given 'Origin'.+  logError :: Origin -> e -> m ()+  logError = logGeneral MsgError++  -- | Log an error message. The origin is the current default source file, with+  -- the source span of the given piece of Fortran syntax.+  logError' :: (F.Spanned a) => a -> e -> m ()+  logError' = withSpannedOrigin logError+++  -- | Log a warning message at the given 'Origin'.+  logWarn :: Origin -> w -> m ()+  logWarn = logGeneral MsgWarn++  -- | Log a warning message. The origin is the current default source file, with+  -- the source span of the given piece of Fortran syntax.+  logWarn' :: (F.Spanned a) => a -> w -> m ()+  logWarn' = withSpannedOrigin logWarn+++  -- | Log an information message at the given 'Origin'.+  logInfo :: Origin -> Text -> m ()+  logInfo = logGeneral MsgInfo++  -- | Log an information message. The origin is the current default source+  -- file, with the source span of the given piece of Fortran syntax.+  logInfo' :: (F.Spanned a) => a -> Text -> m ()+  logInfo' = withSpannedOrigin logInfo++  -- | Log an information message with no origin. For example, use this when+  -- printing output about the progress of an analysis which cannot be+  -- associated with a particular bit of source code.+  logInfoNoOrigin :: Text -> m ()+  logInfoNoOrigin msg = recordLogMessage (MsgInfo (LogMessage Nothing msg))+++  -- | Log a debugging message at the given 'Origin'.+  logDebug :: Origin -> Text -> m ()+  logDebug = logGeneral MsgDebug++  -- | Log a debugging message. The origin is the current default source+  -- file, with the source span of the given piece of Fortran syntax.+  logDebug' :: (F.Spanned a) => a -> Text -> m ()+  logDebug' = withSpannedOrigin logDebug++  default recordLogMessage+    :: (MonadTrans t, MonadLogger e w m', m ~ t m') => SomeMessage e w -> m ()+  default setDefaultSourceFile+    :: (MonadTrans t, MonadLogger e w m', m ~ t m') => FilePath -> m ()+  default getDefaultSourceFile+    :: (MonadTrans t, MonadLogger e w m', m ~ t m') => m FilePath++  recordLogMessage = lift . recordLogMessage+  setDefaultSourceFile = lift . setDefaultSourceFile+  getDefaultSourceFile = lift getDefaultSourceFile++logGeneral :: (MonadLogger e w m) => (LogMessage a -> SomeMessage e w) -> Origin -> a -> m ()+logGeneral mkMsg origin msg =+  recordLogMessage (mkMsg (LogMessage (Just origin) msg))++withSpannedOrigin+  :: (MonadLogger e w m, F.Spanned a)+  => (Origin -> b -> m c) -> a -> b -> m c+withSpannedOrigin f x m = do+  origin <- atSpanned x+  f origin m++instance MonadLogger e w m => MonadLogger e w (ReaderT r m)+instance MonadLogger e w m => MonadLogger e w (ExceptT e' m)+instance MonadLogger e w m => MonadLogger e w (StateT s m)+instance (MonadLogger e w m, Monoid w') => MonadLogger e w (WriterT w' m)+instance MonadLogger e w m => MonadLogger e w (Lazy.StateT s m)+instance (MonadLogger e w m, Monoid w') => MonadLogger e w (Lazy.WriterT w' m)+instance (MonadLogger e w m, Monoid w') => MonadLogger e w (RWST r w' s m)+instance (MonadLogger e w m, Monoid w') => MonadLogger e w (Lazy.RWST r w' s m)++--------------------------------------------------------------------------------+--  'LoggerT' monad+--------------------------------------------------------------------------------++data LoggerState =+  LoggerState+  { _lsLogLevel          :: !LogLevel+  , _lsDefaultSourceFile :: !FilePath+  , _lsPreviousOrigin    :: !(Maybe Origin)+  }++data OpMonoid a = OpMonoid { getOpMonoid :: a }++makeWrapped ''OpMonoid++instance SG.Semigroup a => SG.Semigroup (OpMonoid a) where+  OpMonoid x <> OpMonoid y = OpMonoid (y SG.<> x)++instance (SG.Semigroup a, Monoid a) => Monoid (OpMonoid a) where+  mempty = OpMonoid mempty+  mappend = (SG.<>)++data LoggerEnv m =+  LoggerEnv+  { _leLogFunc :: !(Bool -> LogLevel -> LogLevel -> Text -> Text -> m ())+  }++makeLenses ''LoggerState+makeLenses ''LoggerEnv++hoistEnv :: (m () -> n ()) -> LoggerEnv m -> LoggerEnv n+hoistEnv f = leLogFunc %~ \logFunc b l1 l2 m1 m2 -> f $ logFunc b l1 l2 m1 m2++-- | The logging monad transformer, containing errors of type @e@ and warnings+-- of type @w@.+newtype LoggerT e w m a =+  LoggerT (RWST (LoggerEnv m) (OpMonoid [SomeMessage e w]) LoggerState m a)+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadError e'+    )++instance MonadTrans (LoggerT e w) where+  lift = LoggerT . lift++instance (MonadState s m) => MonadState s (LoggerT e w m) where+  get = lift get+  put = lift . put+  state = lift . state++instance (MonadReader r m) => MonadReader r (LoggerT e w m) where+  ask = lift ask+  local f (LoggerT (RWST k)) = LoggerT $ RWST $ \e -> local f . k e++instance (MonadWriter w' m) => MonadWriter w' (LoggerT e w m) where+  tell = lift . tell++  listen (LoggerT (RWST k)) = LoggerT $ RWST $ \e s -> do+    ((x, w, s'), w') <- listen (k e s)+    return ((x, w'), w, s')++  pass (LoggerT (RWST k)) = LoggerT $ RWST $ \e s ->+    pass $ (\((x, f), w, s') -> ((x, w, s'), f)) <$> k e s++instance (Monad m, Describe e, Describe w) =>+         MonadLogger e w (LoggerT e w m) where+  setDefaultSourceFile = LoggerT . (lsDefaultSourceFile .=)+  getDefaultSourceFile = LoggerT (use lsDefaultSourceFile)++  recordLogMessage msg = do+    LoggerT $ tell (OpMonoid [msg])+    logSomeMessage msg+++-- | This doesn't behave quite as you may think. When a 'LoggerT' is hoisted,+-- the resulting 'LoggerT' cannot output as it goes. It still collects logs to+-- be inspected when it finishes.+instance MFunctor (LoggerT e w) where+  hoist f (LoggerT (RWST k)) = LoggerT $ RWST $ \e s ->+    let e' = hoistEnv (const (return ())) e+    in f (k e' s)+++-- | A function to output logs in a particular monad @m@.+data LogOutput m = LogOutput+  { _loConciseOutput :: Bool+  , _loPrintFunc     :: Text -> m ()+  }+++-- | Output logs to standard output (i.e. the console).+logOutputStd+  :: MonadIO m+  => Bool+  -- ^ If 'True', print more concise output when message origin is repeated.+  -> LogOutput m+logOutputStd b = LogOutput+  { _loConciseOutput = b+  , _loPrintFunc = liftIO . Text.putStrLn+  }+++-- | Output no logs.+logOutputNone+  :: Monad m+  => Bool+  -- ^ If 'True', print more concise output when message origin is repeated.+  -> LogOutput m+logOutputNone b = LogOutput+  { _loConciseOutput = b+  , _loPrintFunc = const (return ())+  }+++-- | Run the logging monad transformer. Returns the action's result value and a+-- list of logs which were collected as it ran.+runLoggerT+  :: (Monad m, Describe e, Describe w)+  => FilePath+  -- ^ The initial default source file. This is only used for displaying message+  -- origins.+  -> LogOutput m+  -- ^ The logging output function. E.g. 'logOutputStd' or 'logOutputNone'.+  -> LogLevel+  -- ^ The log level for on-the-fly logging. Doesn't affect which logs are+  -- collected at the end.+  -> LoggerT e w m a+  -- ^ The logging action to run.+  -> m (a, [SomeMessage e w])+runLoggerT sourceFile output logLevel (LoggerT action) = do+  let st = LoggerState+        { _lsLogLevel = logLevel+        , _lsDefaultSourceFile = sourceFile+        , _lsPreviousOrigin = Nothing+        }++      env = LoggerEnv+        { _leLogFunc = logFuncFrom output+        }++  (x, _, logs) <- runRWST action env st++  return (x, reverse (getOpMonoid logs))+++-- | Change the error and warning types in a logger computation. To change the+-- underlying monad use 'hoist'.+mapLoggerT+  :: (Functor m)+  => (e -> e') -> (w -> w')+  -> LoggerT e w m a -> LoggerT e' w' m a+mapLoggerT mapErr mapWarn (LoggerT x) = LoggerT (mapRWST mapInner x)+  where+    mapInner =+      let messages ty = _3 . _Wrapped . traverse . ty . lmMsg+      in fmap (over (messages _MsgWarn) mapWarn . over (messages _MsgError) mapErr)++--------------------------------------------------------------------------------+--  Internal+--------------------------------------------------------------------------------++logFuncFrom+  :: (Monad m)+  => LogOutput m+  -> (Bool -> LogLevel -> LogLevel -> Text -> Text -> m ())+logFuncFrom LogOutput{ _loConciseOutput, _loPrintFunc } = lf+  where+    lf repeatedOrigin maxLevel level originMsg actualMsg+      | level <= maxLevel =+        let outputMsg =+              describeBuilder level <>+              (if not _loConciseOutput || not repeatedOrigin+               then " " <> describeBuilder originMsg else "") <> ": " <>+              describeBuilder actualMsg+        in _loPrintFunc (builderToStrict outputMsg)+      | otherwise = return ()+++someLogLevel :: SomeMessage e w -> LogLevel+someLogLevel (MsgError _) = LogError+someLogLevel (MsgWarn _)  = LogWarn+someLogLevel (MsgInfo _)  = LogInfo+someLogLevel (MsgDebug _) = LogDebug++someMsgText :: (Describe e, Describe w) => SomeMessage e w -> Text+someMsgText (MsgError msg) = describe (msg ^. lmMsg)+someMsgText (MsgWarn msg)  = describe (msg ^. lmMsg)+someMsgText (MsgInfo msg)  = msg ^. lmMsg+someMsgText (MsgDebug msg) = msg ^. lmMsg+++logSomeMessage+  :: (Monad m, Describe e, Describe w)+  => SomeMessage e w -> LoggerT e w m ()+logSomeMessage msg = do+  let msgText = someMsgText msg+      msgLevel = someLogLevel msg+      msgOrigin = msg ^. someMessageOrigin+      originText = maybe "" describe msgOrigin++  prevOrigin <- LoggerT $ use lsPreviousOrigin+  LoggerT $ lsPreviousOrigin .= msg ^. someMessageOrigin++  let repeatedOrigin = msgOrigin == prevOrigin++  logFunc <- LoggerT $ view leLogFunc+  logLevel <- LoggerT $ use lsLogLevel++  lift $ logFunc repeatedOrigin logLevel msgLevel originText msgText+
+ src/Camfort/Analysis/ModFile.hs view
@@ -0,0 +1,183 @@+{- |+Module      :  Camfort.Analysis.ModFile+Description :  CamFort-specific ModFiles helpers.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++module Camfort.Analysis.ModFile+  (+    -- * Getting mod files+    MFCompiler+  , genModFiles+  , getModFiles+  , readParseSrcDir+  , simpleCompiler+    -- * Using mod files+  , withCombinedModuleMap+  , withCombinedEnvironment+  , lookupUniqueName+  ) where++import           Control.Lens                       (ix, preview)+import           Control.Monad                      (forM)+import           Control.Monad.IO.Class+import qualified Data.ByteString                    as B+import           Data.Char                          (toLower)+import           Data.Data                          (Data)+import           Data.List                          ((\\))+import qualified Data.Map                           as Map+import           Data.Maybe                         (catMaybes)+import           Data.Text.Encoding                 (decodeUtf8With, encodeUtf8)+import           Data.Text.Encoding.Error           (replace)+import           System.Directory                   (doesDirectoryExist,+                                                     listDirectory)+import           System.FilePath                    (takeExtension, (</>))+++import qualified Language.Fortran.Analysis          as FA+import qualified Language.Fortran.Analysis.Renaming as FAR+import qualified Language.Fortran.Analysis.Types    as FAT+import qualified Language.Fortran.AST               as F+import qualified Language.Fortran.Parser.Any        as FP+import qualified Language.Fortran.Util.ModFile      as FM++import           Camfort.Analysis.Annotations       (A, unitAnnotation)+import           Camfort.Helpers++--------------------------------------------------------------------------------+--  Getting mod files+--------------------------------------------------------------------------------++-- | Compiler for ModFile information, parameterised over an underlying monad+-- and the input to the compiler.+type MFCompiler r m = r -> FM.ModFiles -> F.ProgramFile A -> m FM.ModFile++-- | Compile the Modfile with only basic information.+simpleCompiler :: (Monad m) => MFCompiler () m+simpleCompiler () mfs = return . FM.genModFile . fst' . withCombinedEnvironment mfs+  where fst' (x, _, _) = x++genCModFile :: MFCompiler r m -> r -> FM.ModFiles -> F.ProgramFile A -> m FM.ModFile+genCModFile = id++-- | Generate a mode file based on the given mod file compiler+genModFiles+  :: (MonadIO m)+  => FM.ModFiles -> MFCompiler r m -> r -> FilePath -> [Filename] -> m FM.ModFiles+genModFiles mfs mfc env fp excludes = do+  fortranFiles <- liftIO $ fmap fst <$> readParseSrcDir mfs fp excludes+  traverse (genCModFile mfc env mfs) fortranFiles++-- | Retrieve the ModFiles under a given path.+getModFiles :: FilePath -> IO FM.ModFiles+getModFiles dir = do+  -- Figure out the camfort mod files and parse them.+  modFileNames <- (filter isModFile . map (dir </>)) <$> listDirectory dir+  mods <- forM modFileNames $ \modFileName -> do+    modData <- B.readFile modFileName+    let eResult = FM.decodeModFile modData+    case eResult of+      Left msg -> do+        putStrLn $ modFileName ++ ": Error: " ++ show msg+        pure Nothing+      Right modFile -> do+        putStrLn $ modFileName ++ ": successfully parsed precompiled file."+        pure . pure $ modFile+  pure . catMaybes $ mods+  where+    isModFile :: String -> Bool+    isModFile = (== FM.modFileSuffix) . takeExtension++listDirectoryRecursively :: FilePath -> IO [FilePath]+listDirectoryRecursively dir = listDirectoryRec dir ""+  where+    listDirectoryRec :: FilePath -> FilePath -> IO [FilePath]+    listDirectoryRec d f = do+      let fullPath = d </> f+      isDir <- doesDirectoryExist fullPath+      if isDir+      then do+        conts <- listDirectory fullPath+        concat <$> mapM (listDirectoryRec fullPath) conts+      else pure [fullPath]++readParseSrcDir :: FM.ModFiles+                -> FileOrDir+                -> [Filename]+                -> IO [(F.ProgramFile A, SourceText)]+readParseSrcDir mods inp excludes = do+  isdir <- isDirectory inp+  files <-+    if isdir+    then do+      files <- getFortranFiles inp+      -- Compute alternate list of excludes with the+      -- the directory appended+      let excludes' = excludes ++ map (\x -> inp </> x) excludes+      pure $ files \\ excludes'+    else pure [inp]+  mapMaybeM (readParseSrcFile mods) files+  where+    mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+    mapMaybeM f = fmap catMaybes . mapM f++readParseSrcFile :: FM.ModFiles -> Filename -> IO (Maybe (F.ProgramFile A, SourceText))+readParseSrcFile mods f = do+  inp <- flexReadFile f+  let result = FP.fortranParserWithModFiles mods inp f+  case result of+    Right ast -> pure $ Just (fmap (const unitAnnotation) ast, inp)+    Left  err -> print err >> pure Nothing+  where+    -- | Read file using ByteString library and deal with any weird characters.+    flexReadFile :: String -> IO B.ByteString+    flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile++getFortranFiles :: FileOrDir -> IO [String]+getFortranFiles dir =+  filter isFortran <$> listDirectoryRecursively dir+  where+    -- | True if the file has a valid fortran extension.+    isFortran :: Filename -> Bool+    isFortran x = map toLower (takeExtension x) `elem` exts+      where exts = [".f", ".f90", ".f77", ".cmn", ".inc"]++--------------------------------------------------------------------------------+--  Using mod files+--------------------------------------------------------------------------------++-- | Normalize the 'ProgramFile' to include module map information from the+-- 'ModFiles'. Also return the module map, which links source names to unique+-- names within each program unit.+withCombinedModuleMap+  :: (Data a)+  => FM.ModFiles+  -> F.ProgramFile (FA.Analysis a)+  -> (F.ProgramFile (FA.Analysis a), FAR.ModuleMap)+withCombinedModuleMap mfs pf =+  let+    -- Use the module map derived from all of the included Camfort Mod files.+    mmap = FM.combinedModuleMap mfs+    tenv = FM.combinedTypeEnv mfs+    pfRenamed = FAR.analyseRenamesWithModuleMap mmap $ pf+  in (pfRenamed, mmap `Map.union` FM.extractModuleMap pfRenamed)++-- | Normalize the 'ProgramFile' to include environment information from+-- the 'ModFiles'. Also return the module map and type environment.+withCombinedEnvironment+  :: (Data a)+  => FM.ModFiles -> F.ProgramFile a -> (F.ProgramFile (FA.Analysis a), FAR.ModuleMap, FAT.TypeEnv)+withCombinedEnvironment mfs pf =+  let (pfRenamed, mmap) = withCombinedModuleMap mfs (FA.initAnalysis pf)+      tenv = FM.combinedTypeEnv mfs+  in (fst . FAT.analyseTypesWithEnv tenv $ pfRenamed, mmap, tenv)++-- | From a module map, look up the unique name associated with a given source+-- name in the given program unit. Also returns the name type, which tells you+-- whether the name belongs to a subprogram, variable or intrinsic.+lookupUniqueName :: F.ProgramUnitName -> F.Name -> FAR.ModuleMap -> Maybe (F.Name, FA.NameType)+lookupUniqueName puName srcName = preview $ ix puName . ix srcName
src/Camfort/Analysis/Simple.hs view
@@ -15,21 +15,106 @@ -}  {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}  {- Simple syntactic analysis on Fortran programs -}  module Camfort.Analysis.Simple- (countVariableDeclarations) where-+ (countVariableDeclarations, checkImplicitNone, ImplicitNoneReport(..)) where+import Prelude hiding (unlines)+import Control.Monad import Data.Data+import Data.Text (Text, unlines)+import qualified Data.Semigroup as SG+import Data.Monoid ((<>)) import Data.Generics.Uniplate.Operations-import Camfort.Helpers+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as Builder + import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Util.Position as F +import Camfort.Analysis ( ExitCodeOfReport(..), atSpanned, Origin, failAnalysis'+                        , logError', logError, describe, describeBuilder+                        , PureAnalysis, Describe )+ {-| Counts the number of declarations (of variables) in a whole program -} -countVariableDeclarations ::-    forall a . Data a => F.ProgramFile a -> (Int, F.ProgramFile a)-countVariableDeclarations x =-    (sum [1 | _ <- universeBi x :: [F.Declarator a]], x)+newtype VarCountReport = VarCountReport Int+instance ExitCodeOfReport VarCountReport where+  exitCodeOf _ = 0+instance Describe VarCountReport where+  describeBuilder (VarCountReport c) = Builder.fromText $ describe c++countVariableDeclarations :: forall a. Data a => F.ProgramFile a -> PureAnalysis () () VarCountReport+countVariableDeclarations pf = return . VarCountReport $ length (universeBi pf :: [F.Declarator a])++type PULoc = (F.ProgramUnitName, Origin)+data ImplicitNoneReport+  = ImplicitNoneReport [PULoc] -- ^ list of program units identified as needing implicit none++instance SG.Semigroup ImplicitNoneReport where+  ImplicitNoneReport r1 <> ImplicitNoneReport r2 = ImplicitNoneReport $ r1 ++ r2++instance Monoid ImplicitNoneReport where+  mempty = ImplicitNoneReport []+  mappend = (SG.<>)++-- If allPU is False then function obeys host scoping unit rule:+-- 'external' program units (ie. appear at top level) must have+-- implicit-none statements, which are then inherited by internal+-- subprograms. Also, subprograms of interface blocks must have+-- implicit-none statements. If allPU is True then simply checks all+-- program units. FIXME: when we have Fortran 2008 support then+-- submodules must also be checked.+checkImplicitNone :: forall a. Data a => Bool -> F.ProgramFile a -> PureAnalysis String () ImplicitNoneReport+checkImplicitNone allPU pf = do+  checkedPUs <- if allPU+                then sequence [ puHelper pu | pu <- universeBi pf :: [F.ProgramUnit a] ]+                     -- host scoping unit rule + interface exception:+                else sequence ( [ puHelper pu | pu <- childrenBi pf :: [F.ProgramUnit a] ] +++                                [ puHelper pu | int@(F.BlInterface {}) <- universeBi pf :: [F.Block a]+                                              , pu <- childrenBi int :: [F.ProgramUnit a] ] )+  forM_ checkedPUs $ \ r -> case r of+     ImplicitNoneReport [(F.Named name, orig)] -> logError orig name+     _ -> return ()++  return $ mconcat checkedPUs++  where+    isUseStmt (F.BlStatement _ _ _ (F.StUse {})) = True+    isUseStmt _ = False+    isComment (F.BlComment {}) = True+    isComment _ = False+    isUseOrComment b = isUseStmt b || isComment b++    isImplicitNone (F.BlStatement _ _ _ (F.StImplicit _ _ Nothing)) = True; isImplicitNone _ = False+    isImplicitSome (F.BlStatement _ _ _ (F.StImplicit _ _ (Just _))) = True; isImplicitSome _ = False++    checkPU :: F.ProgramUnit a -> Bool+    checkPU pu = case pu of+      F.PUMain _ _ _ bs _              -> checkBlocks bs+      F.PUModule _ _ _ bs _            -> checkBlocks bs+      F.PUSubroutine _ _ _ _ _ bs _    -> checkBlocks bs+      F.PUFunction _ _ _ _ _ _ _ bs _  -> checkBlocks bs+      _                                -> True++    checkBlocks bs = all (not . isImplicitSome) bs && all isUseOrComment useStmts && not (null rest) && all (not . isUseStmt) rest+      where+        (useStmts, rest) = break isImplicitNone bs++    puHelper pu+      | checkPU pu = return mempty+      | otherwise = fmap (\ o -> ImplicitNoneReport [(F.getName pu, o)]) $ atSpanned pu+++instance Describe ImplicitNoneReport where+  describeBuilder (ImplicitNoneReport results)+    | null results = "no cases detected"+    | null (tail results) = "1 case detected"+    | otherwise = Builder.fromText $ describe (length results) <> " cases detected"++instance ExitCodeOfReport ImplicitNoneReport where+  exitCodeOf (ImplicitNoneReport []) = 0+  exitCodeOf (ImplicitNoneReport _)  = 1
src/Camfort/Functionality.hs view
@@ -17,18 +17,22 @@ {- This module collects together stubs that connect analysis/transformations    with the input -> output procedures -} -{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DoAndIfThenElse      #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TupleSections        #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-} -module Camfort.Functionality (+module Camfort.Functionality+  (   -- * Datatypes     AnnotationType(..)+  , CamfortEnv(..)   -- * Commands   , ast   , countVarDecls+  , implicitNone   -- ** Stencil Analysis   , stencilsCheck   , stencilsInfer@@ -37,32 +41,64 @@   , unitsCriticals   , unitsCheck   , unitsInfer-  , unitsSynth   , unitsCompile+  , unitsSynth+  -- ** Invariants Analysis+  , invariantsCheck   -- ** Refactorings   , common   , dead   , equivalences+  -- ** Project Management+  , camfortInitialize   ) where -import Control.Monad-import System.FilePath (takeDirectory)--import Camfort.Analysis.Simple-import Camfort.Transformation.DeadCode-import Camfort.Transformation.CommonBlockElim-import Camfort.Transformation.EquivalenceElim+import           Control.Arrow                                   (first, second)+import           Data.List                                       (intersperse)+import           Data.Void                                       (Void)+import qualified Data.ByteString as B+import           System.Directory                                (doesDirectoryExist, createDirectoryIfMissing,+                                                                  getCurrentDirectory)+import           System.FilePath                                 (takeDirectory,+                                                                  (</>), replaceExtension) -import qualified Camfort.Specification.Units as LU-import Camfort.Specification.Units.Monad+import           Control.Lens+import           Control.Monad.Reader.Class+import           Control.Monad (forM_) -import Camfort.Helpers-import Camfort.Input+import qualified Language.Fortran.AST                            as F+import qualified Language.Fortran.Util.ModFile                   as FM -import Language.Fortran.Util.ModFile-import qualified Camfort.Specification.Stencils as Stencils-import qualified Data.Map.Strict as M+import           Camfort.Analysis+import           Camfort.Analysis.Annotations                    (Annotation)+import           Camfort.Analysis.Logger+import           Camfort.Analysis.ModFile                        (MFCompiler,+                                                                  getModFiles,+                                                                  genModFiles,+                                                                  readParseSrcDir,+                                                                  simpleCompiler)+import           Camfort.Analysis.Simple+import           Camfort.Input+import qualified Camfort.Specification.Stencils                  as Stencils+import           Camfort.Specification.Stencils.Analysis         (compileStencils)+import qualified Camfort.Specification.Units                     as LU+import           Camfort.Specification.Units.Analysis            (compileUnits)+import           Camfort.Specification.Units.Analysis.Consistent (checkUnits)+import           Camfort.Specification.Units.Analysis.Criticals  (inferCriticalVariables)+import           Camfort.Specification.Units.Analysis.Infer      (inferUnits)+import           Camfort.Specification.Units.Monad               (runUnitAnalysis,+                                                                  unitOpts0)+import           Camfort.Specification.Units.MonadTypes          (LiteralsOpt,+                                                                  UnitAnalysis,+                                                                  UnitEnv (..),+                                                                  UnitOpts (..))+import qualified Camfort.Specification.Hoare as Hoare+import           Camfort.Transformation.CommonBlockElim+import           Camfort.Transformation.DeadCode+import           Camfort.Transformation.EquivalenceElim +import           Camfort.Helpers                                 (FileOrDir,+                                                                  Filename)  data AnnotationType = ATDefault | Doxygen | Ford @@ -74,89 +110,294 @@ markerChar Ford      = '!' markerChar ATDefault = '=' +data CamfortEnv =+  CamfortEnv+  { ceInputSources :: FileOrDir+  , ceIncludeDir   :: Maybe FileOrDir+  , ceExcludeFiles :: [Filename]+  , ceLogLevel     :: LogLevel+  } +--------------------------------------------------------------------------------+-- *  Running Functionality++runWithOutput+  :: (Describe e, Describe w)+  => String+  -- ^ Functionality desription+  -> AnalysisProgram e w IO a b+  -- ^ Analysis program+  -> (FileOrDir -> FilePath -> AnalysisRunner e w IO a b r)+  -- ^ Analysis runner+  -> MFCompiler i IO+  -- ^ Mod file compiler+  -> i+  -- ^ Mod file input+  -> FilePath+  -> CamfortEnv+  -> IO r+runWithOutput description program runner mfCompiler mfInput outSrc env =+  let runner' = runner (ceInputSources env) outSrc+  in runFunctionality description program runner' mfCompiler mfInput env+++runFunctionality+  :: (Describe e, Describe w)+  => String+  -- ^ Functionality desription+  -> AnalysisProgram e w IO a b+  -- ^ Analysis program+  -> AnalysisRunner e w IO a b r+  -- ^ Analysis runner+  -> MFCompiler i IO+  -- ^ Mod file compiler+  -> i+  -- ^ Mod file input+  -> CamfortEnv+  -> IO r+runFunctionality description program runner mfCompiler mfInput env = do+  putStrLn $ description ++ " '" ++ ceInputSources env ++ "'"+  incDir' <- maybe getCurrentDirectory pure (ceIncludeDir env)+  isDir <- doesDirectoryExist incDir'+  let incDir | isDir     = incDir'+             | otherwise = takeDirectory incDir'+  -- Previously...+--modFiles <- genModFiles mfCompiler mfInput incDir (ceExcludeFiles env)+  -- ...instead for now, just get the mod files++  modFiles <- getModFiles incDir+  pfsTexts <- readParseSrcDir modFiles (ceInputSources env) (ceExcludeFiles env)+  runner program (logOutputStd True) (ceLogLevel env) modFiles pfsTexts++++-------------------------------------------------------------------------------- -- * Wrappers on all of the features-ast d excludes = do-    xs <- readParseSrcDir d excludes++ast :: CamfortEnv -> IO ()+ast env = do+    incDir' <- maybe getCurrentDirectory pure (ceIncludeDir env)+    modFiles <- getModFiles incDir'+    xs <- readParseSrcDir modFiles (ceInputSources env) (ceExcludeFiles env)     print . fmap fst $ xs -countVarDecls inSrc excludes = do-    putStrLn $ "Counting variable declarations in '" ++ inSrc ++ "'"-    doAnalysisSummary countVariableDeclarations inSrc excludes -dead inSrc excludes outSrc = do-    putStrLn $ "Eliminating dead code in '" ++ inSrc ++ "'"-    report <- doRefactor (mapM (deadCode False)) inSrc excludes outSrc-    putStrLn report+countVarDecls :: CamfortEnv -> IO Int+countVarDecls =+  runFunctionality+  "Counting variable declarations in"+  (generalizePureAnalysis . countVariableDeclarations)+  (describePerFileAnalysis "count variable declarations")+  simpleCompiler () -common inSrc excludes outSrc = do-    putStrLn $ "Refactoring common blocks in '" ++ inSrc ++ "'"-    isDir <- isDirectory inSrc-    let rfun = commonElimToModules (takeDirectory outSrc ++ "/")-    report <- doRefactorAndCreate rfun inSrc excludes outSrc-    putStrLn report+dead :: FileOrDir -> CamfortEnv -> IO Int+dead =+  runWithOutput+  "Eliminating dead code in"+  (fmap generalizePureAnalysis . perFileRefactoring $ deadCode False)+  (doRefactor "dead code elimination")+  simpleCompiler () -equivalences inSrc excludes outSrc = do-    putStrLn $ "Refactoring equivalences blocks in '" ++ inSrc ++ "'"-    report <- doRefactor (mapM refactorEquivalences) inSrc excludes outSrc-    putStrLn report +common :: FileOrDir -> CamfortEnv -> IO Int+common outSrc =+  runWithOutput+  "Refactoring common blocks in"+  (generalizePureAnalysis . commonElimToModules (takeDirectory outSrc ++ "/"))+  (doRefactorAndCreate "common block refactoring")+  simpleCompiler ()+  outSrc+++equivalences :: FileOrDir -> CamfortEnv -> IO Int+equivalences =+  runWithOutput+  "Refactoring equivalences blocks in"+  (fmap generalizePureAnalysis . perFileRefactoring $ refactorEquivalences)+  (doRefactor "equivalence block refactoring")+  simpleCompiler ()++implicitNone :: Bool -> CamfortEnv -> IO Int+implicitNone allPU =+  runFunctionality+  "Checking 'implicit none' completeness"+  (generalizePureAnalysis . (checkImplicitNone allPU))+  (describePerFileAnalysis "check 'implicit none'")+  simpleCompiler ()+ {- Units feature -}-optsToUnitOpts :: LiteralsOpt -> Bool -> Maybe String -> IO UnitOpts-optsToUnitOpts m debug = maybe (pure o1)-  (fmap (\modFiles -> o1 { uoModFiles = M.fromList modFiles }) . getModFilesWithNames)++runUnitsFunctionality+  :: (Describe e, Describe w)+  => String+  -> (UnitOpts -> AnalysisProgram e w IO a b)+  -> AnalysisRunner e w IO a b r+  -> LiteralsOpt+  -> CamfortEnv+  -> IO r+runUnitsFunctionality description unitsProgram runner opts =+  let uo = optsToUnitOpts opts+  in runFunctionality description (unitsProgram uo) runner compileUnits uo++optsToUnitOpts :: LiteralsOpt -> UnitOpts+optsToUnitOpts m = o1   where o1 = unitOpts0 { uoLiterals = m-                       , uoDebug = debug-                       , uoModFiles = M.empty }+                       } -unitsCheck inSrc excludes m debug incDir = do-    putStrLn $ "Checking units for '" ++ inSrc ++ "'"-    uo <- optsToUnitOpts m debug incDir-    let rfun = concatMap (LU.checkUnits uo)-    doAnalysisReportWithModFiles rfun putStrLn inSrc incDir excludes+singlePfUnits+  :: UnitAnalysis a -> UnitOpts+  -> AnalysisProgram () () IO ProgramFile a+singlePfUnits unitAnalysis opts pf =+  let ue = UnitEnv+        { unitOpts = opts+        , unitProgramFile = pf+        }+  in runUnitAnalysis ue unitAnalysis -unitsInfer inSrc excludes m debug incDir = do-    putStrLn $ "Inferring units for '" ++ inSrc ++ "'"-    uo <- optsToUnitOpts m debug incDir-    let rfun = concatMap (LU.inferUnits uo)-    doAnalysisReportWithModFiles rfun putStrLn inSrc incDir excludes -unitsCompile inSrc excludes m debug incDir outSrc = do-    putStrLn $ "Compiling units for '" ++ inSrc ++ "'"-    uo <- optsToUnitOpts m debug incDir-    let rfun = LU.compileUnits uo-    putStrLn =<< doCreateBinary rfun inSrc incDir excludes outSrc+-- slight hack to make doRefactorAndCreate happy+singlePfUnits'+  :: UnitAnalysis a -> UnitOpts+  -> AnalysisProgram () () IO [ProgramFile] a+singlePfUnits' unitAnalysis opts (pf:_) =+  let ue = UnitEnv+        { unitOpts = opts+        , unitProgramFile = pf+        }+  in runUnitAnalysis ue unitAnalysis +multiPfUnits+  :: (Describe a)+  => UnitAnalysis (Either e (a, b))+  -> UnitOpts+  -> AnalysisProgram () () IO [ProgramFile] (Text, [Either e b])+multiPfUnits unitAnalysis opts pfs = do+  let ue pf = UnitEnv+        { unitOpts = opts+        , unitProgramFile = pf+        } -unitsSynth inSrc excludes m debug incDir outSrc annType = do-    putStrLn $ "Synthesising units for '" ++ inSrc ++ "'"-    let marker = markerChar annType-    uo <- optsToUnitOpts m debug incDir-    let rfun =-          mapM (LU.synthesiseUnits uo marker)-    report <- doRefactorWithModFiles rfun inSrc incDir excludes outSrc-    putStrLn report+  results <- traverse (\pf -> runUnitAnalysis (ue pf) unitAnalysis) pfs+  let (rs, ps) = traverse (traverse (\(x, y) -> ([x], y))) results -unitsCriticals inSrc excludes m debug incDir = do-    putStrLn $ "Suggesting variables to annotate with unit specifications in '"-             ++ inSrc ++ "'"-    uo <- optsToUnitOpts m debug incDir-    let rfun = mapM (LU.inferCriticalVariables uo)-    doAnalysisReportWithModFiles rfun (putStrLn . fst) inSrc incDir excludes+      rs' = mconcat . intersperse "\n" . map describe $ rs +  return (rs', ps)++unitsCheck :: LiteralsOpt -> CamfortEnv -> IO Int+unitsCheck =+  runUnitsFunctionality+  "Checking units for"+  (singlePfUnits checkUnits)+  (describePerFileAnalysis "unit checking")+++unitsInfer :: LiteralsOpt -> CamfortEnv -> IO Int+unitsInfer =+  runUnitsFunctionality+  "Inferring units for"+  (singlePfUnits inferUnits)+  (describePerFileAnalysis "unit inference")++{-  TODO: remove if not needed+unitsCompile :: FileOrDir -> LiteralsOpt -> CamfortEnv -> IO ()+unitsCompile outSrc opts env =+  runUnitsFunctionality+  "Compiling units for"+  (singlePfUnits inferAndCompileUnits)+  (compilePerFile "unit compilation" (ceInputSources env) outSrc)+  opts+  env+-}+  -- Previously...+--modFiles <- genModFiles mfCompiler mfInput incDir (ceExcludeFiles env)+  -- ...instead for now, just get the mod files++unitsCompile :: LiteralsOpt -> CamfortEnv -> IO Int+unitsCompile opts env = do+  let uo = optsToUnitOpts opts+  let description = "Compiling units for"+  putStrLn $ description ++ " '" ++ ceInputSources env ++ "'"+  incDir' <- maybe getCurrentDirectory pure (ceIncludeDir env)+  isDir <- doesDirectoryExist incDir'+  let incDir | isDir     = incDir'+             | otherwise = takeDirectory incDir'+  modFiles <- getModFiles incDir++  -- Run the gen mod file routine directly on the input source+  modFiles <- genModFiles modFiles compileUnits uo (ceInputSources env) (ceExcludeFiles env)+  -- Write the mod files out+  forM_ modFiles $ \modFile -> do+     let mfname = replaceExtension (FM.moduleFilename modFile) FM.modFileSuffix+     B.writeFile mfname (FM.encodeModFile modFile)+  return 0++unitsSynth :: AnnotationType -> FileOrDir -> LiteralsOpt -> CamfortEnv -> IO Int+unitsSynth annType outSrc opts env =+  runUnitsFunctionality+  "Synthesising units for"+  (multiPfUnits $ LU.synthesiseUnits (markerChar annType))+  (doRefactor "unit synthesis" (ceInputSources env) outSrc)+  opts+  env+++unitsCriticals :: LiteralsOpt -> CamfortEnv -> IO Int+unitsCriticals =+  runUnitsFunctionality+  "Suggesting variables to annotate with unit specifications in"+  (singlePfUnits inferCriticalVariables)+  (describePerFileAnalysis "unit critical variable analysis")++ {- Stencils feature -}-stencilsCheck inSrc excludes = do-   putStrLn $ "Checking stencil specs for '" ++ inSrc ++ "'"-   let rfun p = (Stencils.check p, p)-   doAnalysisSummary rfun inSrc excludes -stencilsInfer inSrc excludes inferMode = do-   putStrLn $ "Inferring stencil specs for '" ++ inSrc ++ "'"-   let rfun = Stencils.infer inferMode '='-   doAnalysisSummary rfun inSrc excludes -stencilsSynth inSrc excludes inferMode annType outSrc = do-   putStrLn $ "Synthesising stencil specs for '" ++ inSrc ++ "'"-   let rfun = Stencils.synth inferMode (markerChar annType)-   report <- doRefactor rfun inSrc excludes outSrc-   putStrLn report+stencilsCheck :: CamfortEnv -> IO Int+stencilsCheck =+  runFunctionality+  "Checking stencil specs for"+  (generalizePureAnalysis . Stencils.check)+  (describePerFileAnalysis "stencil checking")+  compileStencils ()+++stencilsInfer :: Bool -> CamfortEnv -> IO Int+stencilsInfer useEval =+  runFunctionality+  "Inferring stencil specs for"+  (generalizePureAnalysis . Stencils.infer useEval '=')+  (describePerFileAnalysis "stencil inference")+  compileStencils ()+++stencilsSynth :: AnnotationType -> FileOrDir -> CamfortEnv -> IO Int+stencilsSynth annType =+  let+    program :: AnalysisProgram () () IO [ProgramFile] ((), [Either () ProgramFile])+    program pfs = generalizePureAnalysis $ do+      pfs' <- Stencils.synth (markerChar annType) pfs+      return ((), map Right pfs')++  in runWithOutput+     "Synthesising stencil specs for"+     program+     (doRefactor "stencil synthesis")+     compileStencils ()++{- Invariants Feature-}++invariantsCheck :: Hoare.PrimReprOption -> CamfortEnv -> IO Int+invariantsCheck pro =+  runFunctionality+  "Checking invariants in"+  (Hoare.check pro)+  (describePerFileAnalysis "invariant checking")+  simpleCompiler ()+++-- | Initialize Camfort for the given project.+camfortInitialize :: FilePath -> IO ()+camfortInitialize projectDir =+  createDirectoryIfMissing False (projectDir </> ".camfort")+
src/Camfort/Helpers/Syntax.hs view
@@ -45,6 +45,7 @@  -- Standard imports import Data.Char+import qualified Data.Semigroup as SG  -- Data-type generics imports import Data.Generics.Uniplate.Data@@ -102,10 +103,13 @@ extractVariable (F.ExpSubscript _ _ e _)           = extractVariable e extractVariable _                                  = Nothing +instance SG.Semigroup Int where+  (<>) = (+)+ {-| Set a default monoid instances for Int -} instance Monoid Int where     mempty = 0-    mappend = (+)+    mappend = (SG.<>)  -- SrcSpan helpers
+ src/Camfort/Helpers/TypeLevel.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE TemplateHaskell            #-}++module Camfort.Helpers.TypeLevel where++import           Data.Functor.Identity++import           Language.Expression.Pretty++--------------------------------------------------------------------------------+--  Types+--------------------------------------------------------------------------------++-- | An existential type containing @f a@ for some type @a@.+data Some f where+  Some :: f a -> Some f++-- | A pair of functorial values over the same ground type, where the first+-- value is meant to add constraints rather than real semantic information. The+-- 'Pretty1' instance ignores the first value.+data PairOf f g a = PairOf (f a) (g a)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++type SomePair f g = Some (PairOf f g)++--------------------------------------------------------------------------------+--  Patterns+--------------------------------------------------------------------------------++pattern SomePair :: f a -> g a -> Some (PairOf f g)+pattern SomePair x y = Some (PairOf x y)++--------------------------------------------------------------------------------+--  Combinators+--------------------------------------------------------------------------------++traverseSome+  :: Functor m+  => (forall a. f a -> m (g a))+  -> Some f -> m (Some g)+traverseSome f (Some x) = Some <$> f x++traversePairOf+  :: Functor m+  => (f a -> g a -> m (f' b, g' b))+  -> PairOf f g a -> m (PairOf f' g' b)+traversePairOf f (PairOf x y) = uncurry PairOf <$> f x y++mapSome :: (forall a. f a -> g a) -> Some f -> Some g+mapSome f = runIdentity . traverseSome (Identity . f)++--------------------------------------------------------------------------------+--  Instances+--------------------------------------------------------------------------------++instance Pretty1 f => Pretty (Some f) where+  prettysPrec p = \case+    Some x -> prettys1Prec p x++instance Pretty1 g => Pretty1 (PairOf f g) where+  prettys1Prec p = \case+    PairOf _ x -> prettys1Prec p x++instance Pretty1 f => Show (Some f) where+  show = pretty
src/Camfort/Input.hs view
@@ -7,242 +7,264 @@ Maintainer  :  dom.orchard@gmail.com -} -{-# LANGUAGE DoAndIfThenElse #-}- module Camfort.Input   (     -- * Classes     Default(..)     -- * Datatypes and Aliases-  , FileProgram+  , ProgramFile+  , AnalysisProgram+  , AnalysisRunner     -- * Builders for analysers and refactorings-  , callAndSummarise-  , doAnalysisReportWithModFiles-  , doAnalysisSummary+  , runPerFileAnalysis+  , runMultiFileAnalysis+  , describePerFileAnalysis   , doRefactor   , doRefactorAndCreate-  , doRefactorWithModFiles+  , perFileRefactoring     -- * Source directory and file handling-  , doCreateBinary   , readParseSrcDir-  , getModFilesWithNames+  , loadModAndProgramFiles+    -- * Combinators+  , runThen   ) where -import           Control.Monad (forM)-import           Data.Binary (decodeFileOrFail)-import qualified Data.ByteString.Char8 as B-import           Data.Char (toUpper)-import           Data.List (foldl', (\\), intercalate)-import           Data.Maybe-import           Data.Text.Encoding (encodeUtf8, decodeUtf8With)-import           Data.Text.Encoding.Error (replace)-import           System.Directory-import           System.FilePath ((</>), takeExtension)+import           Control.Monad.IO.Class+import qualified Data.ByteString.Char8         as B+import           Data.Either                   (partitionEithers)+import           Data.List                     (intercalate) -import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Parser.Any as FP-import           Language.Fortran.Util.ModFile+import           Control.Lens -import Camfort.Analysis.Annotations-import Camfort.Helpers-import Camfort.Output+import qualified Language.Fortran.AST          as F+import           Language.Fortran.Util.ModFile (ModFiles, emptyModFiles) --- | Class for default values of some type 't'-class Default t where-    defaultValue :: t+import           Camfort.Analysis+import           Camfort.Analysis.Annotations+import           Camfort.Analysis.Logger+import           Camfort.Analysis.ModFile      (MFCompiler, genModFiles, readParseSrcDir)+import           Camfort.Helpers+import           Camfort.Output --- | Print a string to the user informing them of files excluded--- from the operation.-printExcludes :: Filename -> [Filename] -> IO ()-printExcludes _ []           = pure ()-printExcludes _ [""]         = pure ()-printExcludes inSrc excludes =-  putStrLn $ concat ["Excluding ", intercalate "," excludes, " from ", inSrc, "/"]+-- | An analysis program which accepts inputs of type @a@ and produces results+-- of type @b@.+--+-- Has error messages of type @e@ and warnings of type @w@. Runs in the base+-- monad @m@.+type AnalysisProgram e w m a b = a -> AnalysisT e w m b --- * Builders for analysers and refactorings+-- | An 'AnalysisRunner' is a function to run an 'AnalysisProgram' in a+-- particular way. Produces a final result of type @r@.+type AnalysisRunner e w m a b r =+  AnalysisProgram e w m a b -> LogOutput m -> LogLevel -> ModFiles -> [(ProgramFile, SourceText)] -> m r --- | Perform an analysis that produces information of type @s@.-doAnalysisSummary :: (Monoid s, Show' s)-  => (FileProgram -> (s, FileProgram))-  -> FileOrDir -> [Filename] -> IO ()-doAnalysisSummary aFun inSrc excludes = do-  printExcludes inSrc excludes-  ps <- readParseSrcDir inSrc excludes-  let (out, _) = callAndSummarise aFun ps-  putStrLn . show' $ out+--------------------------------------------------------------------------------+--  Simple runners+-------------------------------------------------------------------------------- --- | Perform an analysis that produces information of type @s@.-callAndSummarise :: (Monoid s)-  => (FileProgram -> (s, a))-  -> [(FileProgram, SourceText)]-  -> (s, [a])-callAndSummarise aFun =-  foldl' (\(n, pss) (ps, _) ->-            let (n', ps') = aFun ps-            in (n `mappend` n', ps' : pss)) (mempty, [])+-- | Given an analysis program for a single file, run it over every input file+-- and collect the reports. Doesn't produce any output.+runPerFileAnalysis+  :: (Monad m, Describe e, Describe w)+  => AnalysisRunner e w m ProgramFile b [AnalysisReport e w b]+runPerFileAnalysis program logOutput logLevel modFiles =+  traverse (\pf ->+    runAnalysisT+      (F.pfGetFilename pf)+      logOutput+      logLevel+      modFiles+      (program pf)) . map fst --- | Perform an analysis which reports to the user, but does not output any files.-doAnalysisReportWithModFiles-  :: ([FileProgram] -> r)-  -> (r -> IO out)-  -> FileOrDir-  -> Maybe FileOrDir-  -> [Filename]-  -> IO out-doAnalysisReportWithModFiles rFun sFun inSrc incDir excludes = do-  printExcludes inSrc excludes-  ps <- readParseSrcDirWithModFiles inSrc incDir excludes+-- | Run an analysis program over every input file and get the report. Doesn't+-- produce any output.+runMultiFileAnalysis+  :: (Monad m, Describe e, Describe w)+  => AnalysisRunner e w m [ProgramFile] b (AnalysisReport e w b)+runMultiFileAnalysis program logOutput logLevel modFiles+  = runAnalysisT "<unknown>" logOutput logLevel modFiles . program . map fst -  let report = rFun . fmap fst $ ps-  sFun report+--------------------------------------------------------------------------------+--  Complex Runners+-------------------------------------------------------------------------------- --- | Perform a refactoring that does not add any new files.-doRefactor :: ([FileProgram]-           -> (String, [FileProgram]))-           -> FileOrDir -> [Filename] -> FileOrDir-           -> IO String-doRefactor rFun inSrc excludes outSrc =-  doRefactorWithModFiles rFun inSrc Nothing excludes outSrc+-- doCreateBinary+--   :: (MonadIO m, Describe r, Describe w, Describe e)+--   => Text -> AnalysisRunner e w m ProgramFile r ()+-- doCreateBinary analysisName = runPerFileAnalysis `runThen` writeCompiledFiles+--   where+--     writeCompiledFiles :: (r, [(Filename, B.ByteString)]) -> IO r+--     writeCompiledFiles (report, bins) = do+--       outputFiles inSrc outSrc bins+--       pure report -doRefactorWithModFiles-  :: ([FileProgram] -> (String, [FileProgram]))-  -> FileOrDir-  -> Maybe FileOrDir-  -> [Filename]-  -> FileOrDir-  -> IO String-doRefactorWithModFiles rFun inSrc incDir excludes outSrc = do-  printExcludes inSrc excludes-  ps <- readParseSrcDirWithModFiles inSrc incDir excludes-  let (report, ps') = rFun . fmap fst $ ps-  let outputs = reassociateSourceText (fmap snd ps) ps'-  outputFiles inSrc outSrc outputs-  pure report+-- FIXME+{-+compilePerFile :: (Describe e, Describe e', Describe w, Describe r) =>+                  Text+               -> FileOrDir+               -> FilePath+               -> AnalysisRunner e w IO [ProgramFile] (r, [Either e' ProgramFile]) ()+compilePerFile analysisName inSrc outSrc =+    runPerFileAnalysis `runThen` writeCompiledFiles+  where+    writeCompiledFiles :: (r, [(Filename, B.ByteString)]) -> IO r+    writeCompiledFiles (report, bins) = do+      outputFiles inSrc outSrc bins+      pure report+-} --- | Perform a refactoring that may create additional files.+-- | Given an analysis program for a single file, run it over every input file+-- and collect the reports, then print those reports to standard output.+describePerFileAnalysis+  :: (MonadIO m, Describe r, ExitCodeOfReport r, Describe w, Describe e)+  => Text -> AnalysisRunner e w m ProgramFile r Int+describePerFileAnalysis analysisName program logOutput logLevel modFiles pfsTexts = do+  reports <- runPerFileAnalysis program logOutput logLevel modFiles pfsTexts+  mapM_ (putDescribeReport analysisName (Just logLevel)) reports+  return $ exitCodeOfSet reports++-- | Accepts an analysis program for multiple input files which produces a+-- result value along with refactored files. Performs the refactoring, and+-- prints the result value with the report.+doRefactor+  :: (Describe e, Describe e', Describe w, Describe r, ExitCodeOfReport r)+  => Text+  -> FileOrDir -> FilePath+  -> AnalysisRunner e w IO [ProgramFile] (r, [Either e' ProgramFile]) Int+doRefactor analysisName inSrc outSrc program logOutput logLevel modFiles pfsTexts = do+  report <- runMultiFileAnalysis program logOutput logLevel modFiles pfsTexts++  let+    -- Get the user-facing output from the report+    report' = fmap fst report+    -- Get the refactoring result form the report+    resultFiles = report ^? arResult . _ARSuccess . _2++  putDescribeReport analysisName (Just logLevel) report'++  -- If the refactoring succeeded, change the files+  case resultFiles of+    Just fs -> finishRefactor inSrc outSrc (map snd pfsTexts) fs >>+               return (exitCodeOf report')+    Nothing -> return (exitCodeOf report')++-- | Accepts an analysis program for multiple input files which produces+-- refactored files and creates new files. Performs the refactoring. doRefactorAndCreate-  :: ([FileProgram] -> (String, [FileProgram], [FileProgram]))-  -> FileOrDir -> [Filename] -> FileOrDir -> IO String-doRefactorAndCreate rFun inSrc excludes outSrc = do-  printExcludes inSrc excludes-  ps <- readParseSrcDir inSrc excludes-  let (report, ps', ps'') = rFun . fmap fst $ ps-  let outputs = reassociateSourceText (fmap snd ps) ps'-  let outputs' = map (\pf -> (pf, B.empty)) ps''+  :: (Describe e, Describe w)+  => Text+  -> FileOrDir -> FilePath+  -> AnalysisRunner e w IO [ProgramFile] ([ProgramFile], [ProgramFile]) Int+doRefactorAndCreate analysisName inSrc outSrc program logOutput logLevel modFiles pfsTexts = do+  report <- runMultiFileAnalysis program logOutput logLevel modFiles pfsTexts++  let+    -- Get the user-facing output from the report+    report' = fmap (const ()) report+    -- Get the refactoring result form the report+    resultFiles = report ^? arResult . _ARSuccess++  putDescribeReport analysisName (Just logLevel) report'++  case resultFiles of+    -- If the refactoring succeeded, change the files+    Just fs -> finishRefactorAndCreate inSrc outSrc (map snd pfsTexts) fs >>+               return (exitCodeOf report')+    Nothing -> return (exitCodeOf report')++-- | Accepts an analysis program to refactor a single file and returns an+-- analysis program to refactor each input file with that refactoring.+perFileRefactoring+  :: (Monad m)+  => AnalysisProgram e w m ProgramFile ProgramFile+  -> AnalysisProgram e w m [ProgramFile] ((), [Either e ProgramFile])+perFileRefactoring program pfs = do+  pfs' <- mapM program pfs+  return ((), fmap pure pfs')++--------------------------------------------------------------------------------+--  Refactoring Combinators+--------------------------------------------------------------------------------++finishRefactor+  :: FileOrDir -> FilePath+  -> [SourceText]+  -- ^ Original source from the input files+  -> [Either e ProgramFile]+  -- ^ Changed input files (or errors)+  -> IO ()+finishRefactor inSrc outSrc inputText analysisOutput = do+  let (_, ps') = partitionEithers analysisOutput+      outputs = reassociateSourceText inputText ps'+   outputFiles inSrc outSrc outputs-  outputFiles inSrc outSrc outputs'-  pure report --- | For refactorings which create additional files.-type FileProgram = F.ProgramFile A -doCreateBinary-  :: ([FileProgram] -> (String, [(Filename, B.ByteString)]))-  -> FileOrDir-  -> Maybe FileOrDir-  -> [Filename]-  -> FileOrDir-  -> IO String-doCreateBinary rFun inSrc incDir excludes outSrc = do-  printExcludes inSrc excludes-  ps <- readParseSrcDirWithModFiles inSrc incDir excludes-  let (report, bins) = rFun . fmap fst $ ps-  outputFiles inSrc outSrc bins-  pure report+finishRefactorAndCreate+  :: FileOrDir -> FilePath+  -> [SourceText]+  -- ^ Original source from the input files+  -> ([ProgramFile], [ProgramFile])+  -- ^ Changed input files, newly created files+  -> IO ()+finishRefactorAndCreate inSrc outSrc inputText analysisOutput = do -reassociateSourceText :: [SourceText]-                      -> [F.ProgramFile Annotation]-                      -> [(F.ProgramFile Annotation, SourceText)]-reassociateSourceText ps ps' = zip ps' ps+  let changedFiles = reassociateSourceText inputText (fst analysisOutput)+      newFiles = map (\pf -> (pf, B.empty)) (snd analysisOutput) --- * Source directory and file handling+  outputFiles inSrc outSrc changedFiles+  outputFiles inSrc outSrc newFiles --- | Read files from a directory.-readParseSrcDir :: FileOrDir  -- ^ Directory to read from.-                -> [Filename] -- ^ Excluded files.-                -> IO [(FileProgram, SourceText)]-readParseSrcDir inp excludes =-  readParseSrcDirWithModFiles inp Nothing excludes+--------------------------------------------------------------------------------+--  Combinators+-------------------------------------------------------------------------------- -readParseSrcDirWithModFiles :: FileOrDir-                            -> Maybe FileOrDir-                            -> [Filename]-                            -> IO [(FileProgram, SourceText)]-readParseSrcDirWithModFiles inp incDir excludes = do-  isdir <- isDirectory inp-  files <--    if isdir-    then do-      files <- getFortranFiles inp-      -- Compute alternate list of excludes with the-      -- the directory appended-      let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes-      pure $ map (\y -> inp ++ "/" ++ y) files \\ excludes'-    else pure [inp]-  mapMaybeM (readParseSrcFileWithModFiles incDir) files-  where-    mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]-    mapMaybeM f = fmap catMaybes . mapM f+-- | Monadic bind for analysis runners.+runThen+  :: (Monad m)+  => AnalysisRunner e w m a b r -> (r -> m r')+  -> AnalysisRunner e w m a b r'+runThen runner withResult program output level modFiles programFiles =+  runner program output level modFiles programFiles >>= withResult -readParseSrcFileWithModFiles :: Maybe FileOrDir-                             -> Filename-                             -> IO (Maybe (FileProgram, SourceText))-readParseSrcFileWithModFiles incDir f = do-  inp <- flexReadFile f-  mods <- maybe (pure emptyModFiles) getModFiles incDir-  let result = FP.fortranParserWithModFiles mods inp f-  case result of-    Right ast -> pure $ Just (fmap (const unitAnnotation) ast, inp)-    Left  err -> print err >> pure Nothing-  where-    -- | Read file using ByteString library and deal with any weird characters.-    flexReadFile :: String -> IO B.ByteString-    flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile+--------------------------------------------------------------------------------+--  Misc+-------------------------------------------------------------------------------- -getFortranFiles :: FileOrDir -> IO [String]-getFortranFiles =-  fmap (filter isFortran) . rGetDirContents-  where-    -- | True if the file has a valid fortran extension.-    isFortran :: Filename -> Bool-    isFortran x = takeExtension x `elem` (exts ++ extsUpper)-      where exts = [".f", ".f90", ".f77", ".cmn", ".inc"]-            extsUpper = map (map toUpper) exts+-- | Class for default values of some type 't'+class Default t where+    defaultValue :: t --- | Recursively get the contents of a directory.-rGetDirContents :: FileOrDir -> IO [Filename]-rGetDirContents d = do-  ds <- listDirectory d-  fmap concat . mapM rGetDirContents' $ ds-  where-    -- | Get contents of directory if path points to a valid-    -- directory, otherwise return the path (a file).-    rGetDirContents' path = do-      let dPath = d </> path-      isDir <- doesDirectoryExist dPath-      if isDir then do-        fmap (fmap (path </>)) (rGetDirContents dPath)-      else pure [path]+-- | Print a string to the user informing them of files excluded+-- from the operation.+printExcludes :: Filename -> [Filename] -> IO ()+printExcludes _ []           = pure ()+printExcludes _ [""]         = pure ()+printExcludes inSrc excludes =+  putStrLn $ concat ["Excluding ", intercalate "," excludes, " from ", inSrc, "/"] --- | Retrieve a list of ModFiles from the directory, each associated--- to the name of the file they are contained within.-getModFilesWithNames :: FileOrDir -> IO [(Filename, ModFile)]-getModFilesWithNames dir = do-  -- Figure out the camfort mod files and parse them.-  modFileNames <- filter isModFile <$> rGetDirContents dir-  forM modFileNames $ \ modFileName -> do-    eResult <- decodeFileOrFail (dir ++ "/" ++ modFileName) -- FIXME, directory manipulation-    case eResult of-      Left (offset, msg) -> do-        putStrLn $ modFileName ++ ": Error at offset " ++ show offset ++ ": " ++ msg-        pure (modFileName, emptyModFile)-      Right modFile -> do-        putStrLn $ modFileName ++ ": successfully parsed precompiled file."-        pure (modFileName, modFile)-  where-    isModFile :: Filename -> Bool-    isModFile = (== modFileSuffix) . takeExtension --- | Retrieve the ModFiles from a directory.-getModFiles :: FileOrDir -> IO ModFiles-getModFiles = fmap (fmap snd) . getModFilesWithNames+-- | For refactorings which create additional files.+type ProgramFile = F.ProgramFile A++reassociateSourceText+  :: [SourceText]+  -> [F.ProgramFile Annotation]+  -> [(F.ProgramFile Annotation, SourceText)]+reassociateSourceText ps ps' = zip ps' ps+++loadModAndProgramFiles+  :: (MonadIO m)+  => MFCompiler r m -> r+  -> FileOrDir -- ^ Input source file or directory+  -> FileOrDir -- ^ Include path+  -> [Filename] -- ^ Excluded files+  -> m (ModFiles, [(ProgramFile, SourceText)])+loadModAndProgramFiles mfc env inSrc incDir excludes = do+  liftIO $ printExcludes inSrc excludes+  modFiles <- genModFiles emptyModFiles mfc env incDir excludes+  ps <- liftIO $ readParseSrcDir modFiles inSrc excludes+  pure (modFiles, ps)+
src/Camfort/Reprint.hs view
@@ -29,6 +29,7 @@ import qualified Data.ByteString.Char8 as B import Data.Data import Control.Monad.Trans.State.Lazy+import Control.Monad.Trans.Class (lift) import qualified Language.Fortran.Util.Position as FU  {-@@ -70,63 +71,61 @@    let cursor0 = FU.initPosition    -- Enter the top-node of a zipper for 'tree'    -- setting the cursor at the start of the file-   (out, cursorn) <- runStateT (enter refactoring (toZipper tree) input) cursor0-   -- Remove from the input the portion covered by the main algorithm-   -- leaving the rest of the file not covered within the bounds of-   -- the tree-   let (_, remaining)  = takeBounds (cursor0, cursorn) input+   (out, (_, remaining)) <- runStateT (enter refactoring (toZipper tree)) (cursor0, input)+   -- Add to the output source the reamining input source    return $ out `B.append` remaining  -- The enter, enterDown, enterRight each take a refactoring and a--- zipper producing a stateful SourceText transformer with FU.Position+-- zipper producing a stateful computation with (FU.Position, SourceText) -- state.  enter, enterDown, enterRight   :: Monad m-  => Refactoring m -> Zipper a -> SourceText -> StateT FU.Position m SourceText+  => Refactoring m -> Zipper a -> StateT (FU.Position, SourceText) m SourceText  -- `enter` applies the generic refactoring to the current context -- of the zipper-enter refactoring z inp = do+enter refactoring z = do    -- Part 1.   -- Apply a refactoring-  cursor     <- get-  (p1, refactored) <- query (`refactoring` inp) z+  (cursor, inp)     <- get+  ((p1, refactored), cursor') <- lift $ runStateT (query (`refactoring` inp) z) cursor    -- Part 2.-  -- Cut out the portion of source text consumed by the refactoring-  cursor'    <- get-  (_, inp')  <- return $ takeBounds (cursor, cursor') inp-  -- If a refactoring was not output,-  -- Enter the children of the current context-  p2         <- if refactored-                   then return B.empty-                   else enterDown refactoring z inp'+  p2 <- if refactored+        then do+          -- If the node was refactored then...+          -- cut out the portion of source text consumed by the refactoring+          (_, inp') <- return $ takeBounds (cursor, cursor') inp+          put (cursor', inp')+          return B.empty+        else do+          -- If a refactoring was not output,+          -- enter the children of the current context+          put (cursor', inp)+          enterDown refactoring z    -- Part 3.-  -- Cut out the portion of source text consumed by the children-  -- then enter the right sibling of the current context-  cursor''   <- get-  (_, inp'') <- return $ takeBounds (cursor', cursor'') inp'-  p3         <- enterRight refactoring z inp''+  -- Enter the right sibling of the current context+  p3 <- enterRight refactoring z -  -- Conat the output for the current context, children, and right sibling+  -- Concat the output for the current context, children, and right sibling   return $ B.concat [p1, p2, p3]  -- `enterDown` navigates to the children of the current context-enterDown refactoring z inp =+enterDown refactoring z =   case down' z of     -- Go to children-    Just dz -> enter refactoring dz inp+    Just dz -> enter refactoring dz     -- No children     Nothing -> return B.empty  -- `enterRight` navigates to the right sibling of the current context-enterRight refactoring z inp =+enterRight refactoring z =   case right z of     -- Go to right sibling-    Just rz -> enter refactoring rz inp+    Just rz -> enter refactoring rz     -- No right sibling     Nothing -> return B.empty
+ src/Camfort/Specification/Hoare.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}++{-|++Hoare-logic-based invariant annotation and automated checking for Fortran.++= Annotations++Programs must be annotation in order to check them. Annotations are of the form++== Static assertions++@+!= static_assert <keyword> (<logic_expression>)+@++The possible keywords are++  [@pre@] program unit preconditions.++  [@post@] program unit postconditions.++  [@seq@] invariants between program statements.++  [@invariant@] loop invariant annotations.++== Logical Expressions++A logical expression is an expression formed from quoted Fortran expressions+combined with an arbitrary combination of the logical operators++  [ @&@ ] conjunction++  [ @|@ ] disjunction++  [ @->@ ] implication++  [ @\<-\>@ ] bi-implication, equivalence++  [ @!@ ] negation++For example,++@+"x >= 3" & ("y = 7" | "y = z")+@++is a valid logical expression.++== Variables++In logical expressions, you may use any Fortran variables that are declared in+the associated program unit, and you may use an annotated function's return+variable as long as it has a declared type (i.e. the function's name unless+otherwise specified). In addition, you may declare auxiliary variables using the+syntax++@+!= decl_aux("\<type spec\>" :: \<name\>)+@++  [@\<type spec\>@] an arbitrary Fortran type specification, such as+    @integer@ or @real(kind=8,dimensions=(3,4))@++  [@\<name\>@] any string (case-insensitive) that is a valid Fortran+    identifier, such as @my_var123@.++Using any undeclared variables will result in an error.++== Necessary Annotations++Annotations are required at the following program points:++* Between any two statements @S1@ and @S2@, where @S2@ is not an assignment.+* On the line after @do ...@.++== Unsupported Program Constructs++Many parts of Fortran are currently unsupported. You will receive a helpful+error message if you try to use something that's unsupported. Notable+unsupported constructs are:++* Standard @do@ loops (@do while@ loops /are/ supported)+* Multi-dimensional arrays+* User-defined data types+* Program sub-units+* Intrinsic functions+* @write@, @read@, etc+* Subroutine and function calls++== Example++Here's an example of a properly annotated Fortran program:++@+!= decl_aux("integer" :: x_)+!= decl_aux("integer" :: y_)+!= static_assert pre("x == x_" & "y == y_")+!= static_assert post("multiply == x_ * y_")+integer function multiply(x, y)+  implicit none++  integer :: x, y+  integer :: r, n++  if (x < 0) then+     x = -x+     y = -y+  end if++  r = 0+  n = 0+  != static_assert seq("x * y == x_ * y_" & "n == 0" & "r == 0" & "n <= x")+  do while (n < x)+     != static_assert invariant("x * y == x_ * y_" & "r == n * y" & "n <= x")+     r = r + y+     n = n + 1+  end do++  multiply = r+end function multiply+@++-}+module Camfort.Specification.Hoare (check, HoareCheckResults(..), PrimReprOption(..)) where++import           Control.Monad.Except+import           Data.List                                 (intersperse)++import qualified Language.Fortran.Analysis                 as FA+import qualified Language.Fortran.Analysis.BBlocks         as FAB+import qualified Language.Fortran.Analysis.Renaming        as FAR+import qualified Language.Fortran.AST                      as F+import qualified Language.Fortran.Util.Position            as F++import           Camfort.Analysis+import           Camfort.Analysis.Annotations+import           Camfort.Analysis.ModFile+import           Camfort.Helpers+import           Camfort.Input+import           Camfort.Specification.Hoare.Annotation+import           Camfort.Specification.Hoare.CheckBackend+import           Camfort.Specification.Hoare.CheckFrontend+import           Camfort.Specification.Hoare.Parser+import           Language.Fortran.Model.Repr.Prim++--------------------------------------------------------------------------------+--  Types+--------------------------------------------------------------------------------++newtype HoareCheckResults = HoareCheckResults [HoareCheckResult]++instance ExitCodeOfReport HoareCheckResults where+  exitCodeOf (HoareCheckResults rs) = exitCodeOfSet rs++instance Describe HoareCheckResults where+  describeBuilder (HoareCheckResults rs) =+    mconcat . intersperse "\n" . map describeBuilder $ rs++-- TODO: Give more control here+data PrimReprOption = PROIdealized | PROPrecise++--------------------------------------------------------------------------------+--  Checking+--------------------------------------------------------------------------------++{-|+The main entry point for the invariant checking analysis. Runs invariant+checking on every annotated program unit in the given program file.++The 'PrimReprOption' argument controls how Fortran data types are treated+symbolically. See the documentation in "Language.Fortran.Model.Repr.Prim" for a+detailed explanation.+-}+check :: PrimReprOption+      -> F.ProgramFile Annotation+      -> HoareAnalysis HoareCheckResults+check pro = fmap HoareCheckResults . invariantChecking (fromPrimReprOption pro) . getBlocks++--------------------------------------------------------------------------------+--  Internal+--------------------------------------------------------------------------------++getBlocks :: F.ProgramFile A -> F.ProgramFile (FA.Analysis (HoareAnnotation A))+getBlocks =+  FAB.analyseBBlocks . FAR.analyseRenames .+  FA.initAnalysis . fmap hoareAnn0++defaultSymSpec :: PrimReprSpec+defaultSymSpec = prsIdealized++fromPrimReprOption :: PrimReprOption -> PrimReprSpec+fromPrimReprOption PROIdealized = prsIdealized+fromPrimReprOption PROPrecise = prsPrecise++--------------------------------------------------------------------------------+--  Testsing+--------------------------------------------------------------------------------++testOn :: FilePath -> IO ()+testOn fp = do+  (mfs, pfsSources) <- loadModAndProgramFiles simpleCompiler () fp fp []+  describePerFileAnalysis+    "invariant checking"+    (check PROIdealized)+    (logOutputStd True)+    LogDebug+    mfs+    pfsSources+  return ()++testHoare = do+  testOn "camfort/samples/invariants/arrays.f90"+  testOn "camfort/samples/invariants/invariants.f90"
+ src/Camfort/Specification/Hoare/Annotation.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# OPTIONS_GHC -Wall #-}++{-|++Fortran AST annotations used for Hoare logic checking.++-}+module Camfort.Specification.Hoare.Annotation where++import           Data.Data++import           Control.Lens++import qualified Language.Fortran.Analysis          as F+import qualified Language.Fortran.AST               as F++import qualified Camfort.Analysis.Annotations       as Ann+import           Camfort.Analysis.CommentAnnotator++import           Camfort.Specification.Hoare.Syntax+++-- | Annotations meant to appear on the main annotated program's AST.+type HA = F.Analysis (HoareAnnotation Ann.A)+++-- | Annotations meant to appear on the AST inside those Fortran expressions+-- that have been parsed from inside logical expression annotations.+type InnerHA = F.Analysis Ann.A++data HoareAnnotation a =+  HoareAnnotation+  { _hoarePrevAnnotation  :: a+  , _hoareSod :: Maybe (SpecOrDecl InnerHA)+  -- ^ A @static_assert@ specification or @decl_aux@ declaration.+  , _hoarePUName :: Maybe F.ProgramUnitName+  -- ^ The name of the program unit that the spec or decl is attached to.+  }+  deriving (Show, Eq, Typeable, Data)++makeLenses ''HoareAnnotation++instance Linkable HA where+  link ann _ = ann++  linkPU ann pu = Ann.onPrev (hoarePUName .~ Just (F.puName pu)) ann++instance ASTEmbeddable HA (SpecOrDecl InnerHA) where+  annotateWithAST ann ast =+    Ann.onPrev (hoareSod .~ Just ast) ann+++hoareAnn0 :: a -> HoareAnnotation a+hoareAnn0 x = HoareAnnotation { _hoarePrevAnnotation = x, _hoareSod = Nothing, _hoarePUName = Nothing }
+ src/Camfort/Specification/Hoare/CheckBackend.hs view
@@ -0,0 +1,804 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# OPTIONS_GHC -Wall #-}++module Camfort.Specification.Hoare.CheckBackend+  ( AnnotatedProgramUnit(..)+  , apuPreconditions+  , apuPostconditions+  , apuPU+  , apuAuxDecls+  , BackendAnalysis+  , HoareCheckResult(..)+  , HoareBackendError(..)+  , checkPU+  ) where++import           Control.Exception                      (Exception (..))+import           Control.Lens+import           Control.Monad.Reader+import           Control.Monad.State.Strict+import           Control.Monad.Writer.Strict+import           Control.Monad.Trans.Maybe+import           Data.Data                              (Data)+import           Data.Foldable                          (foldlM)+import           Data.Generics.Uniplate.Operations      (childrenBi,+                                                         transformBi)+import           Data.Map                               (Map)+import qualified Data.Map                               as Map+import           Data.Maybe                             (isJust, maybeToList)+import           Data.Void                              (Void)++import           Data.SBV                               (SBool, defaultSMTCfg)++import qualified Language.Fortran.Analysis              as F+import qualified Language.Fortran.AST                   as F+import qualified Language.Fortran.LValue                as F+import qualified Language.Fortran.Util.Position         as F++import           Camfort.Analysis+import           Camfort.Analysis.Logger                (Builder, Text)+import           Camfort.Helpers.TypeLevel+import           Camfort.Specification.Hoare.Annotation+import           Camfort.Specification.Hoare.Syntax+import           Camfort.Specification.Hoare.Translate+import           Language.Fortran.Model+import           Language.Fortran.Model.Repr.Prim+import           Language.Fortran.Model.Translate+import           Language.Fortran.Model.Vars++import           Language.Expression+import           Language.Expression.Choice+import           Language.Expression.Pretty+import           Language.Expression.Prop+import           Language.Verification+import           Language.Verification.Conditions++--------------------------------------------------------------------------------+--  Data types+--------------------------------------------------------------------------------++data AnnotatedProgramUnit =+  AnnotatedProgramUnit+  { _apuPreconditions  :: [PrimFormula InnerHA]+  , _apuPostconditions :: [PrimFormula InnerHA]+  , _apuAuxDecls       :: [AuxDecl InnerHA]+  , _apuPU             :: F.ProgramUnit HA+  }++data AnnotationError+  = MissingWhileInvariant+  -- ^ The while block had no associated invariant+  | MissingSequenceAnn+  -- ^ A sequence annotation was required but not found++data HoareBackendError+  = VerifierError (VerifierError FortranVar)+  | TranslateErrorAnn TranslateError+  -- ^ Unit errors come from translating annotation formulae+  | TranslateErrorSrc TranslateError+  -- ^ HA errors come from translating actual source Fortran+  | InvalidSourceName SourceName+  -- ^ A program source name had no unique name+  | UnsupportedBlock (F.Block HA)+  -- ^ Found a block that we don't know how to deal with+  | UnexpectedBlock (F.Block HA)+  -- ^ Found a block in an illegal place+  | ArgWithoutDecl NamePair+  -- ^ Found an argument that didn't come with a variable declaration+  | AuxVarConflict F.Name+  -- ^ An auxiliary variable name conflicted with a program source name+  | AssignVarNotInScope NamePair+  -- ^ The variable was referenced in an assignment but not in scope+  | WrongAssignmentType Text SomeType+  -- ^ Expected array type but got the given type instead+  | NonLValueAssignment+  -- ^ Assigning to an expression that isn't an lvalue+  | UnsupportedAssignment Text+  -- ^ Tried to assign to something that's valid Fortran but unsupported+  | AnnotationError AnnotationError+  -- ^ There was a problem with the annotations++instance Describe AnnotationError where+  describeBuilder =+    \case+      MissingSequenceAnn ->+        "the program was insufficiently annotated; " <>+        "`seq` annotation required before this block"+      MissingWhileInvariant ->+        "found a `do while` block with no invariant; " <>+        "invariant annotations must appear at the start of every `do while` loop"++instance Describe HoareBackendError where+  describeBuilder =+    \case+      VerifierError e ->+        "verifier error: " <> describeBuilder (displayException e)+      TranslateErrorAnn te ->+        "translation error in logic annotation: " <> describeBuilder te+      TranslateErrorSrc te ->+        "translation error in source code: " <> describeBuilder te+      InvalidSourceName nm ->+        "a program source name had no associated unique name: " <>+        describeBuilder (pretty nm)+      UnsupportedBlock _ -> "encountered unsupported block"+      UnexpectedBlock _ -> "a block was found in an illegal location"+      ArgWithoutDecl nm ->+        "argument " <> describeBuilder (show nm) <>+        " doesn't have an associated type declaration"+      AuxVarConflict nm ->+        "auxiliary variable " <> describeBuilder nm <>+        " has the same name as a program variable; this is not allowed"+      AnnotationError e -> describeBuilder e+      AssignVarNotInScope nm ->+        "variable " <> describeBuilder (pretty nm) <>+        " is being assigned to but is not in scope"+      WrongAssignmentType message gotType ->+        "unexpected variable type; expected " <> describeBuilder message <>+        "; got " <>+        describeBuilder (pretty gotType)+      NonLValueAssignment ->+        "assignment an expression which is not a valid lvalue"+      UnsupportedAssignment message ->+        "unsupported assignment; " <> describeBuilder message++type HoareBackendWarning = Void+type BackendAnalysis = AnalysisT HoareBackendError HoareBackendWarning IO++data HoareCheckResult = HoareCheckResult (F.ProgramUnit HA) Bool+  deriving (Show)++instance ExitCodeOfReport HoareCheckResult where+  exitCodeOf (HoareCheckResult _ r) = if r then 0 else 1++describePuName :: F.ProgramUnitName -> Builder+describePuName (F.Named n)         = describeBuilder n+describePuName F.NamelessBlockData = "<nameless block data>"+describePuName F.NamelessComment   = "<nameless comment>"+describePuName F.NamelessMain      = "<nameless main>"++instance Describe HoareCheckResult where+  describeBuilder (HoareCheckResult pu result) =+    "Program unit '" <> describePuName (F.puSrcName pu) <> "': " <>+    (if result then "verified!" else "unverifiable!")++type ScopeVars = Map UniqueName SomeVar++data CheckHoareEnv =+  CheckHoareEnv+  { _heImplicitVars   :: Bool+  , _heVarsInScope    :: ScopeVars+    -- ^ The variables in scope. Associates unique names with name pairs and types.+  , _heSourceToUnique :: Map SourceName [UniqueName]+    -- ^ The corresponding unique names for all the source names we have seen.+  , _heReprHandler    :: forall p k a. Prim p k a -> PrimReprHandler a+  , _hePU             :: F.ProgramUnit HA+  }++emptyEnv :: F.ProgramUnit HA -> PrimReprSpec -> CheckHoareEnv+emptyEnv pu spec = CheckHoareEnv True mempty mempty (makeSymRepr spec) pu++makeLenses ''AnnotatedProgramUnit+makeLenses ''CheckHoareEnv++instance HasPrimReprHandlers CheckHoareEnv where+  primReprHandler = view heReprHandler++--------------------------------------------------------------------------------+--  Main function+--------------------------------------------------------------------------------++checkPU :: AnnotatedProgramUnit+        -> PrimReprSpec+        -> BackendAnalysis HoareCheckResult+checkPU apu symSpec = do++  let pu = apu ^. apuPU++  -- The first part of the checking process has a mutable 'CheckHoareEnv' in+  -- 'StateT' as it collects information to add to the environment.+  ((bodyTriple, initialAssignments), env) <- flip runStateT (emptyEnv pu symSpec) $ do+    logInfo' pu $ " - Setting up"++    (body, initialAssignments) <- initialSetup++    unless (null initialAssignments) $+      logDebug' pu $+      "Found " <> describeShow (length initialAssignments) <>+      " initial assignments: " <> describeShow (map pretty initialAssignments)++    addAuxVariables apu++    let translatePUFormulae =+            readerOfState+          . traverse (tryTranslateFormula pu)++    preconds <- translatePUFormulae (apu ^. apuPreconditions)+    postconds <- translatePUFormulae (apu ^. apuPostconditions)++    logInfo' pu $ " - Interpreting pre- and postconditions"++    let precond = propAnd preconds+        postcond = propAnd postconds++    logInfo' pu $ " - Found preconditions: "  <> describe (pretty precond)+    logInfo' pu $ " - Found postconditions: " <> describe (pretty postcond)++    -- Modify the postcondition by substituting in variable values from the+    -- initial assignments+    let postcond' = chainSub postcond initialAssignments++    return ((precond, postcond', body), initialAssignments)++  -- The second part has an immutable 'CheckHoareEnv' in 'ReaderT'.+  flip runReaderT env $ do+    logInfo' pu $ " - Computing verification conditions"+    (_, vcs) <- runGenM (genBody' initialAssignments bodyTriple)++    logInfo' pu $ " - Verifying conditions:"++    let checkVcs _ [] = return True+        checkVcs i (vc : rest) = do+          logInfo' pu $ "   " <> describeShow i <> ". " <> describe (pretty vc)+          result <- verifyVc (failAnalysis' pu) vc+          if result+            then checkVcs (1 + i) rest+            else do+            logInfo' pu "    - Failed!"+            zipWithM_ printUnchecked [(1 + i)..] vcs+            return False++        printUnchecked i vc = do+          logInfo' pu $ "   " <> describeShow i <> ". " <> describe (pretty vc)+          logInfo' pu   "    - Unchecked"++    HoareCheckResult pu <$> checkVcs (1 :: Int) vcs++--------------------------------------------------------------------------------+--  Variables and names+--------------------------------------------------------------------------------++varOfType :: NamePair -> SomeType -> SomeVar+varOfType names (Some d) = Some (FortranVar d names)+++expNamePair :: F.Expression (F.Analysis a) -> NamePair+expNamePair = NamePair <$> UniqueName . F.varName <*> SourceName . F.srcName+++functionNamePair :: F.ProgramUnit (F.Analysis a) -> NamePair+functionNamePair =+  NamePair <$> UniqueName . fromPuName . F.puName+           <*> SourceName . fromPuName . F.puSrcName+  where+    fromPuName (F.Named n) = n+    fromPuName _           = error "impossible: function has no name"+++-- TODO: Consider reporting a warning when two variables have the same source+-- name.++-- | Create a variable in scope with the given name and type.+newVar :: NamePair -> SomeType -> CheckHoareEnv -> CheckHoareEnv+newVar np@(NamePair uniq src) ty+  = (heVarsInScope . at uniq .~ Just (varOfType np ty))+  . (heSourceToUnique . at src %~ \case+        Nothing -> Just [uniq]+        Just xs -> Just (uniq : xs))+++-- | In specifications attached to program units (pre- and post-conditions), the+-- @fortran-src@ renamer doesn't have access to a renaming environment so it+-- doesn't assign the right unique names. Once we have access to unique names+-- from inside the program unit, this function assigns those names to variables+-- in the PU specifications.+setFormulaUniqueNames+  :: (Data ann)+  => Map SourceName [UniqueName]+  -> PrimFormula (F.Analysis ann)+  -> PrimFormula (F.Analysis ann)+setFormulaUniqueNames nameMap = transformBi setExpUN+  where+    setExpUN :: F.Expression InnerHA -> F.Expression InnerHA+    setExpUN = do+      np <- realNamePair <$> expNamePair+      F.modifyAnnotation (setAnnUniq (np ^. npUnique . _Wrapped))++    realNamePair np@(NamePair _ src) =+      -- TODO: How sound is it to take the first available? Should I throw+      -- warnings?+      case nameMap ^? ix src . _Cons . _1 of+        Just uniq -> NamePair uniq src+        Nothing   -> np++    setAnnUniq uniq a = a { F.uniqueName = Just uniq }++--------------------------------------------------------------------------------+--  Check Monad+--------------------------------------------------------------------------------++type CheckHoareMut = StateT CheckHoareEnv BackendAnalysis+type CheckHoare = ReaderT CheckHoareEnv BackendAnalysis++type FortranAssignment = Assignment MetaExpr FortranVar++-- | Sets up the environment for checking the program unit, including reading+-- past variable declarations. Returns the assignments made in variable+-- declarations, and blocks after the variable declarations.+initialSetup :: CheckHoareMut ([F.Block HA], [FortranAssignment])+initialSetup = do+  pu <- use hePU+  let body = childrenBi pu :: [F.Block HA]++  -- If the program unit is a function, we might need to treat its name as a+  -- variable with its return type.++  -- If the program is a function or subroutine, it might have arguments that we+  -- need to treat as variables.+  rawArgNames <- case pu of+    F.PUFunction _ _ (Just rettype) _ _ funargs retvalue _ _ -> do+      rettype' <- readerOfState $ tryTranslateTypeInfo (typeInfo rettype)++      let retNames = case retvalue  of+            Just rv -> expNamePair rv+            Nothing -> functionNamePair pu++      modify $ newVar retNames rettype'++      return (maybe [] F.aStrip funargs)++    F.PUSubroutine _ _ _ _ subargs _ _ -> return (maybe [] F.aStrip subargs)+    _ -> return []++  let argNames = map expNamePair rawArgNames++  (restBody, initialAssignments) <- readInitialBlocks body++  -- Verify that all argument names have types associated with them.+  forM_ argNames $ \argName -> do+    hasType <- isJust <$> use (heVarsInScope . at (argName ^. npUnique))+    unless hasType $ failAnalysis' pu (ArgWithoutDecl argName)++  return (restBody, initialAssignments)+++-- | Uses the auxiliary variable declaration annotations to add auxiliary+-- variables into scope.+addAuxVariables :: AnnotatedProgramUnit -> CheckHoareMut ()+addAuxVariables apu =+  forM_ (apu ^. apuAuxDecls) $ \auxDecl -> do+    let nm = auxDecl ^. adName+    uniqNm <- uniqueAux nm++    let srcNm = SourceName nm+    sourceToUnique <- use heSourceToUnique++    -- Make sure auxiliary variable source names don't conflict with other+    -- variables (including other auxiliary variables).+    when (srcNm `Map.member` sourceToUnique) $+      failAnalysis' (apu ^. apuPU) $ AuxVarConflict nm++    ty <- readerOfState . tryTranslateTypeInfo . typeInfo $ auxDecl ^. adTy+    modify $ newVar (NamePair uniqNm srcNm) ty+  where+    -- This a bit of a hack: keep prepending underscores until we arrive at a+    -- unique name that hasn't been used yet.+    uniqueAux nm = do+      varsInScope <- use heVarsInScope+      return $ UniqueName+             . head+             . dropWhile ((`Map.member` varsInScope) . UniqueName)+             . iterate (' ' :)+             $ nm+++-- | As part of the initial setup, reads setup blocks like declarations and+-- implicit statements. Updates the environment accordingly. Returns the rest of+-- the blocks, after the setup blocks.+readInitialBlocks :: [F.Block HA] -> CheckHoareMut ([F.Block HA], [FortranAssignment])+readInitialBlocks = runWriterT . dropWhileM readInitialBlock+  where+    -- This function returns 'True' if the block may be part of the setup, and+    -- 'False' otherwise.+    readInitialBlock :: F.Block HA -> WriterT [FortranAssignment] CheckHoareMut Bool+    readInitialBlock bl = case bl of+      F.BlStatement _ _ _ st ->+        case st of+          F.StDeclaration _ _ astTypeSpec attrs decls -> do+            -- This is the part of the type info that applies to every variable+            -- in the declaration list.+            let topTypeInfo =+                  typeInfo astTypeSpec &+                  tiAttributes .~ attrs++            -- Each variable may have extra information that modifies its type info+            declVarsTis <- forM (F.aStrip decls) $ \case+              F.DeclVariable _ _ nameExp declLength mInitialValue -> do+                return (nameExp,+                        topTypeInfo+                        & tiDeclaratorLength .~ declLength,+                        mInitialValue)++              F.DeclArray _ _ nameExp declDims declLength mInitialValue ->+                return (nameExp,+                        topTypeInfo+                        & tiDeclaratorLength .~ declLength+                        & tiDimensionDeclarators .~ Just declDims,+                        mInitialValue)++            forM_ declVarsTis $ \(varNameExp, varTypeInfo, mInitialValue) -> do+              let varNames = expNamePair varNameExp++              varType <- readerOfState $ tryTranslateTypeInfo varTypeInfo++              -- Put the new variable in scope+              modify $ newVar varNames varType++              -- Record the assignment if there is one. NB this must be done+              -- after putting the variable in scope, because making an+              -- assignment checks that it is in scope.+              tell =<< traverse (readerOfState . simpleAssignment varNames)+                          (maybeToList mInitialValue)++            return True++          F.StImplicit _ _ Nothing -> do+            -- TODO: Deal with implicits properly+            return True+          F.StImplicit _ _ (Just _) -> failAnalysis' bl (UnsupportedBlock bl)+          _ -> return False++      -- Skip comments that don't have sequence annotations+      F.BlComment{} | Nothing <- getBlockSeqAnnotation bl -> return True+      _ -> return False+++verifyVc :: (HoareBackendError -> CheckHoare Bool) -> MetaFormula Bool -> CheckHoare Bool+verifyVc handle prop = do+  let getSrProp :: HighRepr Bool -> SBool+      getSrProp (HRHigh x) = x+      getSrProp (HRCore _) = error "absurd"++  let debug = False+      cfg | debug = defaultSMTCfg { verbose = True, transcript = Just "transcript.smt2" }+          | otherwise = defaultSMTCfg++  env <- asks primReprHandlers++  let res = query (getSrProp <$> runReaderT (evalProp' lift (pure . HRCore) prop) env) env+  res' <- liftIO . runVerifierWith cfg $ res++  case res' of+    Right b -> return b+    Left e  -> handle (VerifierError e)++--------------------------------------------------------------------------------+--  Generation Monad+--------------------------------------------------------------------------------++-- | The verification condition generation monad. A writer of meta-formulae with+-- an immutable 'CheckHoareEnv'.+newtype GenM a = GenM (WriterT [MetaFormula Bool] CheckHoare a)+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadReader CheckHoareEnv+    , MonadWriter [MetaFormula Bool]+    , MonadLogger HoareBackendError HoareBackendWarning+    , MonadAnalysis HoareBackendError HoareBackendWarning+    )+++runGenM :: GenM a -> CheckHoare (a, [MetaFormula Bool])+runGenM (GenM action) = runWriterT action+++type FortranTriplet a = Triplet MetaExpr FortranVar a+++genBody' :: [FortranAssignment] -> FortranTriplet [F.Block HA] -> GenM ()+genBody' as (precond, postcond, body) = do+  let seqL = JustAssign as+  seqR <- bodyToSequence body++  case seqL `joinAnnSeq` seqR of+    Just x -> void $ sequenceVCs genBlock (precond, postcond, x)+    Nothing -> failAnalysis' body $ AnnotationError MissingSequenceAnn+++genBody :: FortranTriplet [F.Block HA] -> GenM ()+genBody = genBody' []+++genBlock :: FortranTriplet (F.Block HA) -> GenM ()+genBlock (precond, postcond, bl) = do+  case bl of+    F.BlIf _ _ _ _ conds bodies _ -> do+      condsExprs <- traverse (traverse tryTranslateBoolExpr) conds+      multiIfVCs genBody expr (precond, postcond, (zip condsExprs bodies))++    F.BlDoWhile _ _ _ _ _ cond body _ -> do+      primInvariant <-+        case body of+         b : _ | Just (SodSpec (Specification SpecInvariant f))+                 <- getAnnSod (F.getAnnotation b)+                 -> return f+         _ -> failAnalysis' bl $ AnnotationError MissingWhileInvariant++      invariant <- tryTranslateFormula body primInvariant+      condExpr <- tryTranslateBoolExpr cond++      whileVCs genBody expr invariant (precond, postcond, (condExpr, body))++    F.BlComment _ _ _ -> return ()+    _ -> failAnalysis' bl $ UnsupportedBlock bl+++bodyToSequence :: [F.Block HA] -> GenM (AnnSeq MetaExpr FortranVar (F.Block HA))+bodyToSequence blocks = do+  foldlM combineBlockSequence emptyAnnSeq blocks+++combineBlockSequence+  :: AnnSeq MetaExpr FortranVar (F.Block HA)+  -> F.Block HA+  -> GenM (AnnSeq MetaExpr FortranVar (F.Block HA))+combineBlockSequence prevSeq bl = do+  blSeq <- blockToSequence bl++  case prevSeq `joinAnnSeq` blSeq of+    Just r  -> return r+    Nothing -> failAnalysis' bl $ AnnotationError MissingSequenceAnn+++blockToSequence :: F.Block HA -> GenM (AnnSeq MetaExpr FortranVar (F.Block HA))+blockToSequence bl = do+  chooseFrom [assignment, sequenceSpec, other]+  where+    assignment = fmap (JustAssign . (: [])) <$> tryBlockToAssignment bl++    sequenceSpec =+      traverse+      (fmap propAnnSeq . tryTranslateFormula bl)+      (getBlockSeqAnnotation bl)++    other = return $ case bl of+      F.BlComment{} -> Just emptyAnnSeq+      _             -> Just $ cmdAnnSeq bl++    -- Tries each action in the list, using the first that works and otherwise+    -- reporting an error.+    chooseFrom :: [GenM (Maybe a)] -> GenM a+    chooseFrom =+      (>>= fromMaybeM (failAnalysis' bl $ AnnotationError MissingSequenceAnn)) .+      runMaybeT . msum . map MaybeT+++getBlockSeqAnnotation :: F.Block HA -> Maybe (PrimFormula InnerHA)+getBlockSeqAnnotation = preview (to F.getAnnotation . to getAnnSod . _Just . _SodSpec . _SpecSeq)++--------------------------------------------------------------------------------+-- Handling assignments+++tryBlockToAssignment+  :: ( MonadReader CheckHoareEnv m+     , MonadAnalysis HoareBackendError HoareBackendWarning m+     )+  => F.Block HA -> m (Maybe FortranAssignment)+tryBlockToAssignment bl = do+  case bl of+    F.BlStatement _ _ _ stAst@(F.StExpressionAssign _ _ lexp rvalue) ->+      Just <$> do+        lvalue <- fromMaybeM (failAnalysis' lexp NonLValueAssignment)+                  (F.toLValue lexp)++        case lvalue of+          F.LvSimpleVar {} -> simpleAssignment (expNamePair lexp) rvalue++          F.LvSubscript _ _ lvar@(F.LvSimpleVar {}) ixs ->+            case ixs of+              F.AList _ _ [F.IxSingle _ _ _ ixExpr] ->+                arrayAssignment (lvVarNames lvar) ixExpr rvalue++              _ -> failAnalysis' ixs $+                   UnsupportedAssignment "only simple indices are supported for now"+          _ -> failAnalysis' stAst $+               UnsupportedAssignment "complex assignment"++    _ -> return Nothing+++-- | Create an assignment where the whole value is written to. TODO: this+-- currently only supports primitive values.+simpleAssignment+  :: ( ReportAnn (F.Analysis ann)+     , MonadReader CheckHoareEnv m+     , MonadAnalysis HoareBackendError HoareBackendWarning m+     )+  => NamePair+  -> F.Expression (F.Analysis ann)+  -> m FortranAssignment+simpleAssignment nm rvalAst = do+  Some varV@(FortranVar varD _) <- varFromScope rvalAst nm++  case varD of+    DPrim _ -> do+      rvalExpr <- tryTranslateCoerceExpr varD rvalAst+      return (Assignment varV rvalExpr)+    _ -> failAnalysis' rvalAst $+         WrongAssignmentType+         "primitive value (others unsupported for now)"+         (Some varD)++arrayAssignment+  :: ( ReportAnn (F.Analysis ann)+     , MonadReader CheckHoareEnv m+     , MonadAnalysis HoareBackendError HoareBackendWarning m+     )+  => NamePair+  -> F.Expression (F.Analysis ann)+  -> F.Expression (F.Analysis ann)+  -> m FortranAssignment+arrayAssignment arrName ixAst rvalAst = do+  Some varV@(FortranVar varD _) <- varFromScope rvalAst arrName++  case varD of+    DArray ixIndex valAv -> do+      let ixD = dIndex ixIndex+          valD = dArrValue valAv++      ixExpr   <- intoMetaExpr <$> tryTranslateExpr ixD ixAst+      rvalExpr <- intoMetaExpr <$> tryTranslateExpr valD rvalAst++      -- Replace instances of the array variable with the same array, but with+      -- the new value written at the given index.+      let arrExpr = HFree' $ HPure varV+          arrExpr' = hwrap' $ MopWriteArr varD arrExpr ixExpr rvalExpr++      return (Assignment varV arrExpr')++    _ -> failAnalysis' rvalAst $ WrongAssignmentType "array type" (Some varD)++--------------------------------------------------------------------------------++varFromScope+  :: ( F.Spanned a+     , MonadReader CheckHoareEnv m+     , MonadAnalysis HoareBackendError HoareBackendWarning m+     )+  => a -> NamePair -> m SomeVar+varFromScope loc np = do+  let uniq = np ^. npUnique+  mscoped <- view (heVarsInScope . at uniq)+  case mscoped of+    Just v  -> return v+    Nothing -> failAnalysis' loc $ AssignVarNotInScope np++--------------------------------------------------------------------------------+--  Translation+--------------------------------------------------------------------------------++class Show a => ReportAnn a where+  fromTranslateError :: proxy a -> TranslateError -> HoareBackendError++instance ReportAnn HA      where fromTranslateError _ = TranslateErrorSrc+instance ReportAnn InnerHA where fromTranslateError _ = TranslateErrorAnn+++doTranslate+  :: (MonadReader CheckHoareEnv m, ReportAnn ann)+  => (HoareBackendError -> m a) -> (f ann -> TranslateT m a) -> f ann -> m a+doTranslate handle trans ast = do+  env <- asks toTranslateEnv+  transResult <- runTranslateT (trans ast) env+  case transResult of+    Right x  -> return x+    Left err -> handle (fromTranslateError ast err)+++toTranslateEnv :: CheckHoareEnv -> TranslateEnv+toTranslateEnv env =+  defaultTranslateEnv+    & teImplicitVars .~ env ^. heImplicitVars+    & teVarsInScope .~ env ^. heVarsInScope++--------------------------------------------------------------------------------+-- Shorthands for translating expressions and failing the analysis if the+-- translation fails++tryTranslateExpr+  :: ( ReportAnn (F.Analysis ann)+     , MonadReader CheckHoareEnv m+     , MonadAnalysis HoareBackendError w m+     )+  => D a -> F.Expression (F.Analysis ann) -> m (FortranExpr a)+tryTranslateExpr d e = doTranslate (failAnalysis' e) (translateExpression' d) e++tryTranslateCoerceExpr+  :: ( ReportAnn (F.Analysis ann)+     , MonadReader CheckHoareEnv m+     , MonadAnalysis HoareBackendError w m+     )+  => D a -> F.Expression (F.Analysis ann) -> m (MetaExpr FortranVar a)+tryTranslateCoerceExpr d e =+  doTranslate (failAnalysis' e)+  (fmap squashExpression . translateCoerceExpression d) e++tryTranslateTypeInfo+  :: ( ReportAnn (F.Analysis ann)+     , MonadReader CheckHoareEnv m+     , MonadAnalysis HoareBackendError w m+     )+  => TypeInfo (F.Analysis ann) -> m SomeType+tryTranslateTypeInfo ti = doTranslate (failAnalysis' ti) translateTypeInfo ti++tryTranslateBoolExpr+  :: ( ReportAnn (F.Analysis ann)+     , MonadReader CheckHoareEnv m+     , MonadAnalysis HoareBackendError w m+     )+  => F.Expression (F.Analysis ann) -> m (MetaExpr FortranVar Bool)+tryTranslateBoolExpr e = doTranslate (failAnalysis' e) translateBoolExpression e++tryTranslateFormula+  :: ( F.Spanned o+     , ReportAnn (F.Analysis ann)+     , Data ann+     , MonadReader CheckHoareEnv m+     , MonadAnalysis HoareBackendError w m+     )+  => o -> PrimFormula (F.Analysis ann) -> m (MetaFormula Bool)+tryTranslateFormula loc formula = do+  sourceToUnique <- view heSourceToUnique+  -- TODO: Instead of setting unique names before translation, can we get the+  -- renamer to work inside annotations? I've tried to make this work but ran+  -- into some problems:+  -- - We have to run the renamer before calling 'annotateComments' or it+  --   doesn't find any comments (why?).+  -- - When the renamer is run /after/ calling 'annotateComemnts' it doesn't do+  --   any renaming inside annotations (why?)+  let formulaUN = setFormulaUniqueNames sourceToUnique formula+  doTranslate (failAnalysis' loc) translateFormula formulaUN++--------------------------------------------------------------------------------+--  Utility functions+--------------------------------------------------------------------------------++dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]+dropWhileM _ [] = return []+dropWhileM f (x : xs) = do+  continue <- f x+  if continue+    then dropWhileM f xs+    else return (x : xs)+++fromMaybeM :: (Monad m) => m a -> Maybe a -> m a+fromMaybeM e = maybe e return+++getAnnSod :: HA -> Maybe (SpecOrDecl InnerHA)+getAnnSod = view (to F.prevAnnotation . hoareSod)+++lvVarNames :: F.LValue (F.Analysis x) -> NamePair+lvVarNames e =+  let uniqueName = UniqueName $ F.lvVarName e+      srcName = SourceName $ F.lvSrcName e+  in NamePair uniqueName srcName+++readerOfState :: (MonadState s m) => ReaderT s m a -> m a+readerOfState action = do+  st <- get+  runReaderT action st
+ src/Camfort/Specification/Hoare/CheckFrontend.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}++{-# OPTIONS_GHC -Wall #-}++{-|++This module is responsible for finding annotated program units, and running the+functionality in "Camfort.Specification.Hoare.CheckBackend" on each of them.++-}+module Camfort.Specification.Hoare.CheckFrontend+  (+    -- * Invariant Checking+    invariantChecking++    -- * Analysis Types+  , HoareAnalysis+  , HoareFrontendError(..)+  , HoareFrontendWarning(..)+  ) where++import           Control.Applicative                      (liftA2)+import           Control.Exception+import           Control.Lens+import           Control.Monad.Writer.Strict              hiding (Product)+import           Data.Generics.Uniplate.Operations+import           Data.Map                                 (Map)+import qualified Data.Map                                 as Map+import           Data.Maybe                               (catMaybes)+import           Data.Void                                (absurd)++import qualified Language.Fortran.Analysis                as F+import qualified Language.Fortran.AST                     as F+import qualified Language.Fortran.Util.Position           as F++import           Camfort.Analysis+import qualified Camfort.Analysis.Annotations             as CA+import           Camfort.Analysis.CommentAnnotator+import           Camfort.Specification.Parser             (SpecParseError)++import           Language.Fortran.Model.Repr.Prim++import           Camfort.Specification.Hoare.Annotation+import           Camfort.Specification.Hoare.CheckBackend+import           Camfort.Specification.Hoare.Parser+import           Camfort.Specification.Hoare.Parser.Types (HoareParseError)+import           Camfort.Specification.Hoare.Syntax++--------------------------------------------------------------------------------+--  Invariant Checking+--------------------------------------------------------------------------------++{-|+Runs invariant checking on every annotated program unit in the given program+file. Expects the program file to have basic block and unique analysis+information.++The 'PrimReprSpec' argument controls how Fortran data types are treated+symbolically. See the documentation in "Language.Fortran.Mode.Repr.Prim" for a+detailed explanation.+-}+invariantChecking :: PrimReprSpec -> F.ProgramFile HA -> HoareAnalysis [HoareCheckResult]+invariantChecking primSpec pf = do+  let parserWithAnns = F.initAnalysis . fmap (const CA.unitAnnotation) <$> hoareParser++  pf' <- annotateComments parserWithAnns parseError pf+  annotatedPUs <- findAnnotatedPUs pf'++  let checkAndReport apu = do+        let nm = F.puName (apu ^. apuPU)+            prettyName = describe $ case F.puSrcName (apu ^. apuPU) of+              F.Named x -> x+              _         -> show nm+        logInfo' (apu ^. apuPU) $ "Verifying program unit: " <> prettyName+        loggingAnalysisError . mapAnalysisT BackendError absurd $ checkPU apu primSpec++  catMaybes <$> traverse checkAndReport annotatedPUs++--------------------------------------------------------------------------------+--  Results and errors+--------------------------------------------------------------------------------++type HoareAnalysis = AnalysisT HoareFrontendError HoareFrontendWarning IO++data HoareFrontendError+  = ParseError (SpecParseError HoareParseError)+  | InvalidPUConditions F.ProgramUnitName [SpecOrDecl InnerHA]+  | BackendError HoareBackendError++data HoareFrontendWarning+  = OrphanDecls F.ProgramUnitName++instance Describe HoareFrontendError where+  describeBuilder = \case+    ParseError spe -> "parse error: " <> describeBuilder (displayException spe)+    InvalidPUConditions nm conds ->+      "invalid specification types attached to PU with name " <> describeBuilder (show nm) <> ": " <>+      describeBuilder (show conds)+    BackendError e -> describeBuilder e++instance Describe HoareFrontendWarning where+  describeBuilder = \case+    OrphanDecls nm ->+      "auxiliary variable declared for a program unit with no annotations with name " <>+      describeBuilder (show nm) <> "; skipping invariant checking for this program unit"++--------------------------------------------------------------------------------+--  Internal+--------------------------------------------------------------------------------++parseError :: F.SrcSpan -> SpecParseError HoareParseError -> HoareAnalysis ()+parseError sp err = logError' sp (ParseError err)++-- | Finds all annotated program units in the given program file. Throws errors+-- for program units that are incorrectly annotated. Returns a list of program+-- units which are correctly annotated at the top level.+findAnnotatedPUs :: F.ProgramFile HA -> HoareAnalysis [AnnotatedProgramUnit]+findAnnotatedPUs pf =+  let pusByName :: Map F.ProgramUnitName (F.ProgramUnit HA)+      pusByName = Map.fromList [(F.puName pu, pu) | pu <- universeBi pf]++      -- Each annotation may get linked with one program unit. However, for this+      -- analysis we want to collect all of the annotations that are associated+      -- with the same program unit. For this we need to do some extra work+      -- because the comment annotator can't directly deal with this situation.+      sodsByPU :: Map F.ProgramUnitName [SpecOrDecl InnerHA]+      sodsByPU = Map.fromListWith (++)+        [ (nm, [sod])+        | ann <- universeBi pf :: [HA]+        , nm  <- F.prevAnnotation ann ^.. hoarePUName . _Just+        , sod <- F.prevAnnotation ann ^.. hoareSod    . _Just+        ]++      -- For a given program unit and list of associated specifications, create+      -- an annotated program unit, and report an error if something is wrong.+      collectUnit+        :: F.ProgramUnit HA -> [SpecOrDecl InnerHA]+        -> HoareAnalysis (Maybe AnnotatedProgramUnit)+      collectUnit pu sods = do+        let pres  = sods ^.. traverse . _SodSpec . _SpecPre+            posts = sods ^.. traverse . _SodSpec . _SpecPost+            decls = sods ^.. traverse . _SodDecl++            errors = filter (isn't (_SodSpec . _SpecPre ) .&&+                             isn't (_SodSpec . _SpecPost) .&&+                             isn't _SodDecl)+                     sods+              where (.&&) = liftA2 (&&)++            result = AnnotatedProgramUnit pres posts decls pu++        unless (null errors) $ logError' pu (InvalidPUConditions (F.puName pu) errors)++        if null pres && null posts+          then do+            unless (null decls) $ logWarn' pu (OrphanDecls (F.puName pu))+            return Nothing+          else return $ Just result++      apus :: [HoareAnalysis (Maybe AnnotatedProgramUnit)]+      apus = map snd . Map.toList $ Map.intersectionWith collectUnit pusByName sodsByPU++  in catMaybes <$> sequence apus
+ src/Camfort/Specification/Hoare/Lexer.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -Wall #-}++module Camfort.Specification.Hoare.Lexer (lexer) where++import Data.Monoid (Alt(..))+import Data.Coerce+import qualified Data.Char as Char++import Control.Monad.State+import Control.Monad.Except++import Camfort.Specification.Hoare.Parser.Types+++-- | Lex an invariant annotation.+lexer :: String -> HoareSpecParser [Token]+lexer [] = return []+lexer (' ' : xs) = lexer xs+lexer ('\t' : xs) = lexer xs+lexer xs+  | Just (tok, rest) <- lexSymbol xs+  = addToTokens tok rest+lexer ('"' : xs) = do+  (tok, rest) <- lexQuoted xs+  addToTokens tok rest+lexer xs = do+  mname <- lexName xs+  case mname of+    Just (tok, rest) -> addToTokens tok rest+    Nothing -> throwError (LexError xs)+++addToTokens :: Token -> String -> HoareSpecParser [Token]+addToTokens tok rest = do+ tokens <- lexer rest+ return $ tok : tokens++lexSymbol :: String -> Maybe (Token, String)+lexSymbol xs =+  let symbols =+        [ ("static_assert", TStaticAssert)+        , ("decl_aux", TDeclAux)+        , ("invariant", TInvariant)+        , ("post", TPost)+        , ("pre", TPre)+        , ("seq", TSeq)+        , ("&", TAnd)+        , ("|", TOr)+        , ("<->", TEquiv)+        , ("->", TImpl)+        , ("!", TNot)+        , ("t", TTrue)+        , ("f", TFalse)+        , ("(", TLParen)+        , (")", TRParen)+        , ("::", TDColon)+        ]++      tryMatch (symbol, tok) = (tok,) <$> stripPrefix symbol xs++      firstMatch = getAlt . mconcat . coerce++  in firstMatch (tryMatch <$> symbols)+++lexQuoted :: String -> HoareSpecParser (Token, String)+lexQuoted input = do+  let+    go :: String -> StateT String HoareSpecParser String+    go ('"' : xs) = return xs+    go [] = throwError UnmatchedQuote+    go (c : xs) = do+      modify (c :)+      go xs++  (rest, expr) <- runStateT (go input) []+  return (TQuoted (reverse expr), rest)+++isNameStartChar :: Char -> Bool+isNameStartChar c = Char.isLetter c || c == '_'++isNameChar :: Char -> Bool+isNameChar c =+  Char.isLetter c ||+  Char.isNumber c ||+  c == '_'++lexName :: String -> HoareSpecParser (Maybe (Token, String))+lexName xs =+  let (nm, rest) = span isNameChar xs+  in case nm of+    (n1 : _) | isNameStartChar n1 -> return (Just (TName nm, rest))+    _ -> return Nothing+++stripPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]+stripPrefix (p : refix) (s : tring)+  | p == s = stripPrefix refix tring+  | otherwise = Nothing+stripPrefix [] string = Just string+stripPrefix _ [] = Nothing
+ src/Camfort/Specification/Hoare/Parser.y view
@@ -0,0 +1,113 @@+{++module Camfort.Specification.Hoare.Parser (hoareParser) where++import           Control.Monad.Except++import qualified Language.Fortran.AST as F++import           Language.Verification+import           Language.Expression.Prop++import qualified Camfort.Specification.Parser as Parser+import Camfort.Specification.Hoare.Syntax+import Camfort.Specification.Hoare.Lexer+import Camfort.Specification.Hoare.Parser.Types++}++%monad { HoareSpecParser } { >>= } { return }+%name parseHoare START+%tokentype { Token }+%error { parseError }+%token+  static_assert { TStaticAssert }+  invariant     { TInvariant    }+  post          { TPost         }+  pre           { TPre          }+  seq           { TSeq          }+  true          { TTrue         }+  false         { TFalse        }+  '&'           { TAnd          }+  '|'           { TOr           }+  '->'          { TImpl         }+  '<->'         { TEquiv        }+  '!'           { TNot          }+  '('           { TLParen       }+  ')'           { TRParen       }+  tquoted       { TQuoted $$    }+  decl_aux      { TDeclAux      }+  '::'          { TDColon       }+  tname         { TName $$      }+++%left '|'+%nonassoc '<->'+%right '->'+%left '&'+%left '!'+%nonassoc '<=' '>=' '<' '>' '='+++%%++START :: { SpecOrDecl () }+: HOARE { SodSpec $1 }+| DECL { SodDecl $1 }+++DECL :: { AuxDecl () }+: decl_aux '(' TYPESPEC '::' tname ')' { AuxDecl $5 $3 }++TYPESPEC :: { F.TypeSpec () }+: tquoted {% parseTypeSpec $1 }+++HOARE :: { PrimSpec () }+: static_assert SPEC { $2 }+++SPEC :: { PrimSpec () }+: KIND '(' FORMULA ')' { Specification $1 $3 }+++KIND :: { SpecKind }+: pre       { SpecPre }+| post      { SpecPost }+| seq       { SpecSeq }+| invariant { SpecInvariant }+++FORMULA :: { PrimFormula () }+: true                  { PFLogical (PLLit True) }+| false                 { PFLogical (PLLit False) }+| FORMULA '&' FORMULA   { PFLogical (PLAnd $1 $3) }+| FORMULA '|' FORMULA   { PFLogical (PLOr $1 $3) }+| FORMULA '->' FORMULA  { PFLogical (PLImpl $1 $3) }+| FORMULA '<->' FORMULA { PFLogical (PLEquiv $1 $3) }+| '!' FORMULA           { PFLogical (PLNot $2) }+| '(' FORMULA ')'       { $2 }+| EXPR                  { PFExpr $1 }++EXPR :: { F.Expression () }+: tquoted {% parseExpression $1 }++{++parseError :: [Token] -> HoareSpecParser a+parseError = throwError . ParseError++hoareParser :: Parser.SpecParser HoareParseError (SpecOrDecl ())+hoareParser = Parser.mkParser (\src -> do+                                  tokens <- lexer src+                                  parseHoare tokens)+             ["static_assert", "invariant", "post", "pre", "seq", "decl_aux"]++}++{-+-*- mode: Haskell -*-+Local variables:+eval: (flycheck-mode nil)+End:+-}
+ src/Camfort/Specification/Hoare/Parser/Types.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase         #-}+{-# OPTIONS_GHC -Wall #-}++module Camfort.Specification.Hoare.Parser.Types where++import           Control.Monad.Except+import           Data.Data+import           Control.Exception+import           Data.List                         (intercalate)++import qualified Data.ByteString.Char8             as B++import qualified Language.Fortran.AST              as F+import qualified Language.Fortran.Lexer.FreeForm   as F+import qualified Language.Fortran.Parser.Fortran90 as F+import qualified Language.Fortran.ParserMonad      as F+++data HoareParseError+  = UnmatchedQuote+  | UnexpectedInput+  | MalformedExpression String+  | MalformedTypeSpec String+  | ParseError [Token]+  | LexError String+  deriving (Eq, Ord, Typeable, Data)++instance Show HoareParseError where+  show UnmatchedQuote = "unmatched quote"+  show UnexpectedInput = "unexpected characters in input"+  show (MalformedExpression expr) = "couldn't parse expression: \"" ++ expr ++ "\""+  show (MalformedTypeSpec ts) = "couldn't parse type spec: \"" ++ ts ++ "\""+  show (ParseError tokens) = "unable to parse input: " ++ prettyTokens tokens+  show (LexError xs) = "unable to lex input: " ++ xs++instance Exception HoareParseError where++prettyTokens :: [Token] -> String+prettyTokens = intercalate " " . map prettyToken+  where+    prettyToken = \case+      TQuoted qv -> "\"" ++ qv ++ "\""+      TStaticAssert -> "static_assert"+      TPre -> "pre"+      TPost -> "post"+      TInvariant -> "invariant"+      TSeq -> "seq"+      TRParen -> ")"+      TLParen -> "("+      TAnd -> "&"+      TOr -> "|"+      TImpl -> "->"+      TEquiv -> "<->"+      TNot -> "!"+      TTrue -> "T"+      TFalse -> "F"+      TDeclAux -> "decl_aux"+      TName nm -> nm+      TDColon -> "::"++type HoareSpecParser = Either HoareParseError++data Token =++  -- Quoted Fortran --+    TQuoted String++  -- Static Assertions --+  | TStaticAssert+  | TPre+  | TPost+  | TInvariant+  | TSeq+  | TRParen+  | TLParen+  | TAnd+  | TOr+  | TImpl+  | TEquiv+  | TNot+  | TTrue+  | TFalse++  -- Auxiliary variable declarations --+  | TDeclAux+  | TName String+  | TDColon+  deriving (Show, Eq, Ord, Typeable, Data)++-- TODO: Make this report errors and deal with source position better+parseExpression :: String -> HoareSpecParser (F.Expression ())+parseExpression expr =+  case F.runParse F.statementParser parseState of+    F.ParseOk (F.StExpressionAssign _ _ _ e) _ -> return e+    _ -> throwError (MalformedExpression expr)+  where+    paddedExpr = B.pack $ "      a = " ++ expr+    parseState = F.initParseState paddedExpr F.Fortran90 "<unknown>"+++-- TODO: Make this report errors and deal with source position better+parseTypeSpec :: String -> HoareSpecParser (F.TypeSpec ())+parseTypeSpec ts =+  case F.runParse F.statementParser parseState of+    F.ParseOk (F.StDeclaration _ _ s _ _) _ -> return s+    _ -> throwError (MalformedTypeSpec ts)+  where+    paddedTS = B.pack $ ts ++ " :: dummy"+    parseState = F.initParseState paddedTS F.Fortran90 "<unknown>"
+ src/Camfort/Specification/Hoare/Syntax.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE DeriveTraversable         #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NamedFieldPuns            #-}+{-# LANGUAGE PatternSynonyms           #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TupleSections             #-}+{-# LANGUAGE TypeFamilies              #-}++{-# OPTIONS_GHC -Wall #-}++{-|++Defines the syntax of invariant annotations. See "Camfort.Specification.Hoare"+for a high-level overview.++In this module, the word \'primitive\' is used to refer to untyped expression+syntax (as opposed to the typed expression syntax defined in+"Language.Fortran.Model.Op").++-}+module Camfort.Specification.Hoare.Syntax where++import           Data.Data++import           Control.Lens++import qualified Language.Fortran.AST       as F++import           Language.Expression.Pretty+++-- * Syntax Types++-- | A type of primitive logical operators.+data PrimLogic a+  = PLAnd a a+  | PLOr a a+  | PLImpl a a+  | PLEquiv a a+  | PLNot a+  | PLLit Bool+  deriving (Typeable, Data, Show, Eq, Functor, Foldable, Traversable)+++-- | Logical expressions over Fortran expressions.+data PrimFormula ann+  = PFExpr (F.Expression ann)+  | PFLogical (PrimLogic (PrimFormula ann))+  deriving (Typeable, Data, Show, Eq, Functor)+++-- | Labels for the keyword used in @static_assert@ annotations.+data SpecKind+  = SpecPre+    -- ^ @static_assert pre(...)@+  | SpecPost+    -- ^ @static_assert post(...)@+  | SpecSeq+    -- ^ @static_assert seq(...)@+  | SpecInvariant+    -- ^ @static_assert invariant(...)@+  deriving (Show, Eq, Typeable, Data)+++-- | A @static_assert@ annotation.+data Specification a =+  Specification+  { _specType    :: SpecKind+  , _specFormula :: a+  }+  deriving (Typeable, Data, Eq, Functor)+++-- | A @decl_aux@ annotation.+data AuxDecl ann =+  AuxDecl+  { _adName :: F.Name+  , _adTy   :: F.TypeSpec ann+  }+  deriving (Typeable, Data, Show, Eq, Functor)+++-- | A specification over untyped logical expressions.+type PrimSpec ann = Specification (PrimFormula ann)+++-- | A @static_assert@ or @decl_aux@ annotation.+data SpecOrDecl ann =+    SodSpec (PrimSpec ann)+  | SodDecl (AuxDecl ann)+  deriving (Typeable, Data, Show, Eq, Functor)+++instance Show a => Pretty (PrimFormula a) where pretty = show+++instance (Pretty a) => Show (Specification a) where+  show Specification { _specType, _specFormula } =+    "Specification { " +++    "_specType = " ++ show _specType ++ ", " +++    "_specFormula = " ++ pretty _specFormula +++    " }"++-- * Lenses++makeLenses ''Specification+makeLenses ''AuxDecl+makePrisms ''Specification+makePrisms ''SpecOrDecl+++-- | Given a prism @p@ projecting a pair, @'refining' x p@ projects values from+-- the front left of the pair such that the right of the pair matches @x@.+--+-- >>> [1, 2, 3] ^? refining [] _Cons+-- Nothing+--+-- >>> [1] ^? refining [] _Cons+-- Just 1+--+refining :: (Eq r) => r -> APrism s t (a, r) (a, r) -> Prism s t a a+refining y p = clonePrism p . below (only y) . iso fst (, ())+++-- | Match a @static_assert pre(...)@ annotation.+_SpecPre :: Prism' (Specification a) a+_SpecPre = refining SpecPre (_Specification . swapped)++-- | Match a @static_assert post(...)@ annotation.+_SpecPost :: Prism' (Specification a) a+_SpecPost = refining SpecPost (_Specification . swapped)++-- | Match a @static_assert seq(...)@ annotation.+_SpecSeq :: Prism' (Specification a) a+_SpecSeq = refining SpecSeq (_Specification . swapped)++-- | Match a @static_assert invariant(...)@ annotation.+_SpecInvariant :: Prism' (Specification a) a+_SpecInvariant = refining SpecInvariant (_Specification . swapped)+
+ src/Camfort/Specification/Hoare/Translate.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE TypeFamilies          #-}++{-# OPTIONS_GHC -Wall #-}++{-|++Translation from annotation syntax defined in+"Camfort.Specification.Hoare.Syntax" to strongly-typed meta-expressions defined+in "Language.Fortran.Model.Op.Meta".++-}+module Camfort.Specification.Hoare.Translate+  (+    -- * Meta Expression Types+    MetaExpr+  , MetaFormula+  , AllOps++    -- * Translation+  , translateBoolExpression+  , translateFormula++    -- * Combinators+  , intoMetaExpr+  ) where++import           Prelude                            hiding (span)++import           Control.Lens+import           Control.Monad.Except               (MonadError (..))++import qualified Language.Fortran.Analysis          as F+import qualified Language.Fortran.AST               as F++import           Language.Expression+import           Language.Expression.Choice+import           Language.Expression.Prop++import           Camfort.Helpers.TypeLevel+import           Language.Fortran.Model+import           Language.Fortran.Model.Singletons+import           Language.Fortran.Model.Translate+import           Language.Fortran.Model.Types.Match+import           Language.Fortran.Model.Vars++import           Camfort.Specification.Hoare.Syntax++--------------------------------------------------------------------------------+--  Lifting Logical Values+--------------------------------------------------------------------------------++type AllOps = '[HighOp, MetaOp, CoreOp]+type MetaExpr = HFree' AllOps+type MetaFormula = Prop (MetaExpr FortranVar)++--------------------------------------------------------------------------------+--  Translate+--------------------------------------------------------------------------------++-- | Translate an untyped logical formula into a strongly typed 'MetaFormula'.+translateFormula :: (Monad m) => PrimFormula (F.Analysis ann) -> TranslateT m (MetaFormula Bool)+translateFormula = \case+  PFExpr e -> do+    e' <- translateBoolExpression e+    return $ expr $ e'++  PFLogical x -> foldPrimLogic <$> traverse translateFormula x+++-- | Translate a boolean-valued untyped Fortran expression into a strongly typed 'MetaExpr'.+translateBoolExpression+  :: (Monad m)+  => F.Expression (F.Analysis ann)+  -> TranslateT m (MetaExpr FortranVar Bool)+translateBoolExpression e = do+  SomePair d1 e' <- translateExpression e++  case matchPrimD d1 of+    Just (MatchPrimD (MatchPrim _ SBTLogical) prim1) -> return $+      case prim1 of+        PBool8  -> liftFortranExpr e'+        PBool16 -> liftFortranExpr e'+        PBool32 -> liftFortranExpr e'+        PBool64 -> liftFortranExpr e'+    _ -> throwError $ ErrUnexpectedType "formula" (Some (DPrim PBool8)) (Some d1)+++foldPrimLogic :: PrimLogic (MetaFormula Bool) -> MetaFormula Bool+foldPrimLogic = \case+  PLAnd x y -> x *&& y+  PLOr x y -> x *|| y+  PLImpl x y -> x *-> y+  PLEquiv x y -> x *<-> y+  PLNot x -> pnot x+  PLLit x -> plit x+++--------------------------------------------------------------------------------+--  Util+--------------------------------------------------------------------------------++-- | Convert an expression over 'HighOp', 'MetaOp' or 'CoreOp' into a 'MetaExpr'.+intoMetaExpr :: (ChooseOp op AllOps, HTraversable op) => HFree op v a -> MetaExpr v a+intoMetaExpr = HFree' . hduomapFirst' (review chooseOp)++liftFortranExpr :: (LiftD a b) => FortranExpr a -> MetaExpr FortranVar b+liftFortranExpr e =+  let e' = HWrap (HopLift (LiftDOp (HPure e)))+  in squashExpression e'
src/Camfort/Specification/Parser.hs view
@@ -9,6 +9,8 @@ -}  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}  module Camfort.Specification.Parser   (@@ -23,14 +25,16 @@   ) where  import           Control.Monad.Except (throwError)-import           Data.List (isPrefixOf)-import qualified Data.Text as T+import           Control.Exception (Exception(..))+import           Data.Data+import           Data.List            (isPrefixOf)+import qualified Data.Text            as T  data SpecParseError e   = ParseError e   | InvalidSpecificationCharacter Char   | MissingSpecificationCharacter-  deriving (Eq)+  deriving (Eq, Typeable, Data)  instance (Show e) => Show (SpecParseError e) where   show (InvalidSpecificationCharacter c) =@@ -38,6 +42,12 @@   show MissingSpecificationCharacter = "missing start of specification"   show (ParseError e) = show e +instance Exception e => Exception (SpecParseError e) where+  displayException (InvalidSpecificationCharacter c) =+    "Invalid character at start of specification: " ++ show c+  displayException MissingSpecificationCharacter = "missing start of specification"+  displayException (ParseError e) = displayException e+ -- | Embed an error as a specification parse error. parseError :: e -> SpecParseError e parseError = ParseError@@ -56,6 +66,7 @@     -- | A list of keywords that indicate the type of specification (e.g., @"stencil"@ or @"access"@).   , specKeywords :: [String]   }+  deriving (Functor)  -- | Does the character indicate the start of an abritrary specification? --
src/Camfort/Specification/Stencils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-    Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish @@ -15,19 +16,23 @@ -}  module Camfort.Specification.Stencils- (InferMode, infer, check, synth) where+ (infer, check, synth) where  import Control.Arrow ((***), first, second)+import Data.Maybe (catMaybes) -import Camfort.Specification.Stencils.CheckFrontend hiding (LogLine)-import Camfort.Specification.Stencils.InferenceFrontend-import Camfort.Specification.Stencils.Synthesis-import Camfort.Analysis.Annotations--- These two are redefined here for ForPar ASTs-import Camfort.Helpers+import           Camfort.Analysis+import           Camfort.Analysis.Annotations+import           Camfort.Helpers+import           Camfort.Specification.Stencils.Analysis (StencilsAnalysis)+import qualified Camfort.Specification.Stencils.Annotation as SA+import           Camfort.Specification.Stencils.CheckFrontend hiding (LogLine)+import           Camfort.Specification.Stencils.InferenceFrontend+import           Camfort.Specification.Stencils.Synthesis  import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA+import qualified Language.Fortran.Util.ModFile as MF import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.BBlocks as FAB @@ -35,79 +40,68 @@   -- | Helper for retrieving analysed blocks.-getBlocks = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis+getBlocks = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis . fmap SA.mkStencilAnnotation  -------------------------------------------------- --         Stencil specification inference      -- --------------------------------------------------- -- Top-level of specification inference-infer :: InferMode+infer :: Bool       -> Char       -> F.ProgramFile Annotation-      -> (String, F.ProgramFile Annotation)-infer mode marker pf =-    -- Append filename to any outputs-    if null output-       then ("", infer1)-       else ("\n" ++ filename ++ "\n" ++ output, infer1)-    where-      filename = F.pfGetFilename pf-      output = intercalate "\n"-             . filter (not . white)-             . map formatSpecNoComment $ infer2-      white = all (\x -> (x == ' ') || (x == '\t'))-      infer' = stencilInference mode marker . getBlocks $ pf-      infer1 = fmap FA.prevAnnotation . fst $ infer'-      infer2 = snd infer'+      -> StencilsAnalysis StencilsReport+infer useEval marker pf =+  (StencilsReport . map (F.pfGetFilename pf,)) <$> stencilInference useEval marker (getBlocks pf)  -------------------------------------------------- --         Stencil specification synthesis      -- --------------------------------------------------  -- Top-level of specification synthesis-synth :: InferMode-      -> Char+synth :: Char       -> [F.ProgramFile A]-      -> (String, [F.ProgramFile Annotation])-synth mode marker = first normaliseMsg . foldr buildOutput (("",""), [])+      -> StencilsAnalysis [F.ProgramFile A]+synth marker pfs = do+  syntheses <- unzip <$> traverse buildOutput pfs+  logInfo' pfs $ describe . normaliseMsg . fst $ syntheses+  pure (catMaybes $ snd syntheses)   where-    buildOutput pf =+    buildOutput :: F.ProgramFile A -> StencilsAnalysis ((String, String), Maybe (F.ProgramFile Annotation))+    buildOutput pf = do       let f = F.pfGetFilename pf-      in case synthWithCheck pf of-           Left err         -> first . first  $ (++ mkMsg f err)-           Right (warn,pf') -> second (if null warn-                                       then id-                                       else (++ mkMsg f warn)) *** (pf':)-    synthWithCheck pf =+      result <- synthWithCheck pf+      pure $ case result of+               Left err         -> ((mkMsg f err, ""), Nothing)+               Right (warn,pf') -> (("", mkMsg f warn), Just pf')+    synthWithCheck :: F.ProgramFile A -> StencilsAnalysis (Either String (String, F.ProgramFile Annotation))+    synthWithCheck pf = do       let blocks = getBlocks pf-          checkRes = stencilChecking blocks in-        case checkFailure checkRes of-          Nothing  ->-            let inference = fmap FA.prevAnnotation .-                            fst $ stencilInference Synth marker blocks-                  in Right (maybe "" show (checkWarnings checkRes), inference)-          Just err -> Left $ show err+      checkRes <- stencilChecking blocks+      case checkFailure checkRes of+        Nothing  -> do+          res <- fst <$> stencilSynthesis marker blocks+          let inference = fmap SA.getBaseAnnotation res+          pure $ Right (maybe "" show (checkWarnings checkRes), inference)+        Just err -> pure . Left $ show err -    mkMsg f e = "\nEncountered the following errors when checking\-                \ stencil specs for '" ++ f ++ "'\n\n" ++ e+    mkMsg _ "" = ""+    mkMsg f e  = "\nEncountered the following errors when checking\+                 \ stencil specs for '" ++ f ++ "'\n\n" ++ e -    normaliseMsg ("",  warn) = warn-    normaliseMsg (err, warn) = err ++ warn ++ "\nPlease resolve these errors, and then\-                            \ run synthesis again."+    normaliseMsg outs =+      let errors = fmap fst outs+          fullMsg = concatMap (uncurry (++)) outs+      in if any (/="") errors then fullMsg ++ errorTrailer else fullMsg+      where errorTrailer = "\nPlease resolve these errors, and then\+                           \ run synthesis again."   -------------------------------------------------- --         Stencil specification checking       -- -------------------------------------------------- -check :: F.ProgramFile Annotation -> String-check pf =-    -- Append filename to any outputs-    if null output then "" else "\n" ++ filename ++ "\n" ++ output-    where-     filename = F.pfGetFilename pf-     output = show . stencilChecking . getBlocks $ pf+check :: F.ProgramFile Annotation -> StencilsAnalysis CheckResult+check = stencilChecking . getBlocks  -- Local variables: -- mode: haskell
+ src/Camfort/Specification/Stencils/Analysis.hs view
@@ -0,0 +1,28 @@+{- |+Module      :  Camfort.Specification.Stencils.Analysis+Description :  Helpers for generic stencils analysis.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++module Camfort.Specification.Stencils.Analysis+  ( StencilsAnalysis+  , compileStencils+  ) where++import qualified Language.Fortran.Util.ModFile as MF++import           Camfort.Analysis+import           Camfort.Analysis.ModFile      (MFCompiler, simpleCompiler)++-- TODO:+-- type StencilsAnalysis = PureAnalysis StencilCheckError StencilCheckWarning++type StencilsAnalysis = PureAnalysis () ()++-- | Compile a program to a 'ModFile' containing stencils information.+compileStencils :: Monad m => MFCompiler () m+compileStencils = simpleCompiler
src/Camfort/Specification/Stencils/Annotation.hs view
@@ -1,42 +1,137 @@-{--   Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish--   Licensed under the Apache License, Version 2.0 (the "License");-   you may not use this file except in compliance with the License.-   You may obtain a copy of the License at+{- |+Module      :  Camfort.Specification.Stencils.Annotation+Description :  Annotation with stencil information.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0 -       http://www.apache.org/licenses/LICENSE-2.0+Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental -   Unless required by applicable law or agreed to in writing, software-   distributed under the License is distributed on an "AS IS" BASIS,-   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.-   See the License for the specific language governing permissions and-   limitations under the License.+Defines the 'StencilAnnotation' datatype, which is used for annotating a+'ProgramFile' with stencil information. -} -{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Camfort.Specification.Stencils.Annotation () where+module Camfort.Specification.Stencils.Annotation+  (+    StencilAnnotation+  , SA+  , mkStencilAnnotation+  -- ** Specification Annotation Helpers+  , getAstSpec+  , getParseSpec+  , getRegionSpec+  , getStencilBlock+  , giveAstSpec+  , giveParseSpec+  , giveRegionSpec+    -- ** Base Annotation+  , getBaseAnnotation+  , modifyBaseAnnotation+  ) where -import Camfort.Analysis.Annotations-import Camfort.Analysis.CommentAnnotator-import qualified Camfort.Specification.Stencils.Parser.Types as Gram+import Data.Data (Data) -import qualified Language.Fortran.AST as F+import qualified Language.Fortran.AST      as F import qualified Language.Fortran.Analysis as FA +import qualified Camfort.Analysis.Annotations                as Ann+import           Camfort.Analysis.CommentAnnotator+import qualified Camfort.Specification.Stencils.Parser.Types as Gram+import qualified Camfort.Specification.Stencils.Syntax       as Syn++-- | Specification annotation.+data SpecAnnotation+  -- | Unprocessed syntax tree.+  = ParserSpec Gram.Specification+  -- | Region definition.+  | RegionDecl Syn.RegionDecl+  -- | Normalised AST specification.+  | ASTSpec Syn.SpecDecls+  deriving (Eq, Show, Data)++data StencilAnnotation a = StencilAnnotation  {+      prevAnnotation :: a+      -- | Assocatated specification.+    , stencilSpec    :: Maybe SpecAnnotation+      -- | Associated assignment.+    , stencilBlock   :: Maybe (F.Block (FA.Analysis (StencilAnnotation a)))+    } deriving (Show, Eq, Data)++-- | Create a new stencil annotation.+mkStencilAnnotation :: a -> StencilAnnotation a+mkStencilAnnotation a = StencilAnnotation+  { prevAnnotation = a+  , stencilSpec    = Nothing+  , stencilBlock   = Nothing+  }++-- | Convenience name for common annotation type.+type SA = FA.Analysis (StencilAnnotation Ann.A)++modifyBaseAnnotation :: (Ann.A -> Ann.A) -> SA -> SA+modifyBaseAnnotation f = Ann.onPrev (\ann -> ann { prevAnnotation = f (prevAnnotation ann) })++-- | Retrieve the underlying (base) annotation from a stencil annotation.+getBaseAnnotation :: SA -> Ann.A+getBaseAnnotation = prevAnnotation . FA.prevAnnotation++setSpec :: SpecAnnotation -> SA -> SA+setSpec s = Ann.onPrev (\ann -> ann { stencilSpec = Just s })++-- | Set the annotation's stencil specification to a parsed specification.+giveParseSpec :: Gram.Specification -> SA -> SA+giveParseSpec spec = setSpec (ParserSpec spec)++-- | Set the annotation's stencil specification to a region alias.+giveRegionSpec :: Syn.RegionDecl -> SA -> SA+giveRegionSpec spec = setSpec (RegionDecl spec)++-- | Set the annotation's stencil specification to a normalized specification.+giveAstSpec :: Syn.SpecDecls -> SA -> SA+giveAstSpec spec = setSpec (ASTSpec spec)++getSA :: SA -> StencilAnnotation Ann.A+getSA = FA.prevAnnotation++getSpec :: SA -> Maybe SpecAnnotation+getSpec = stencilSpec . getSA++-- | Retrieve a parsed specification from an annotation.+getParseSpec :: SA -> Maybe Gram.Specification+getParseSpec s = case getSpec s of+  (Just (ParserSpec spec)) -> Just spec+  _                        -> Nothing++-- | Retrieve a region environment from an annotation.+getRegionSpec :: SA -> Maybe Syn.RegionDecl+getRegionSpec s = case getSpec s of+  (Just (RegionDecl renv)) -> Just renv+  _                        -> Nothing++-- | Retrieve a normalized specification from an annotation.+getAstSpec :: SA -> Maybe Syn.SpecDecls+getAstSpec s = case getSpec s of+  (Just (ASTSpec ast)) -> Just ast+  _                    -> Nothing++getStencilBlock :: SA -> Maybe (F.Block SA)+getStencilBlock = stencilBlock . getSA+ {- *** Routines for associating annotations to ASTs -}  -- Instances for embedding parsed specifications into the AST-instance ASTEmbeddable (FA.Analysis Annotation) Gram.Specification where+instance ASTEmbeddable SA Gram.Specification where   annotateWithAST ann ast =-    onPrev (giveParseSpec ast) ann+    Ann.onPrev (\ann' -> ann' { stencilSpec = Just $ ParserSpec ast }) ann -instance Linkable (FA.Analysis Annotation) where-  link ann (b@(F.BlDo {})) =-      onPrev (\ann -> ann { stencilBlock = Just b }) ann-  link ann (b@(F.BlStatement _ _ _ (F.StExpressionAssign {}))) =-      onPrev (\ann -> ann { stencilBlock = Just b }) ann-  link ann _ = ann+instance Linkable SA where+  link ann b@F.BlDo{} =+      Ann.onPrev (\ann' -> ann' { stencilBlock = Just b }) ann+  link ann (b@(F.BlStatement _ _ _ F.StExpressionAssign{})) =+      Ann.onPrev (\ann' -> ann' { stencilBlock = Just b }) ann+  link   ann _ = ann   linkPU ann _ = ann
src/Camfort/Specification/Stencils/CheckBackend.hs view
@@ -14,9 +14,10 @@    limitations under the License. -} -{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ImplicitParams         #-}+{-# LANGUAGE TupleSections          #-}  module Camfort.Specification.Stencils.CheckBackend   (@@ -25,13 +26,23 @@     -- * Errors   , SynToAstError   , regionNotInScope+    -- * Helpers+  , checkOffsetsAgainstSpec   ) where -import Data.Function (on)+import           Algebra.Lattice (joins1)+import           Control.Arrow (second)+import           Data.Function (on)+import           Data.Int (Int64)+import           Data.List (sort)+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as S -import Camfort.Specification.Stencils.Syntax-import Camfort.Specification.Stencils.Model+import qualified Camfort.Helpers.Vec as V+import qualified Camfort.Specification.Stencils.Consistency as C+import           Camfort.Specification.Stencils.Model import qualified Camfort.Specification.Stencils.Parser.Types as SYN+import           Camfort.Specification.Stencils.Syntax  data SynToAstError = RegionNotInScope String   deriving (Eq)@@ -100,6 +111,52 @@     case lookup v ?renv of       Nothing -> Left (RegionNotInScope v)       Just rs -> return rs++-- *** Other Helpers++checkOffsetsAgainstSpec :: [(Variable, Multiplicity [[Int]])]+                        -> [(Variable, Specification)]+                        -> Bool+checkOffsetsAgainstSpec offsetMaps specMaps =+  variablesConsistent && all specConsistent specToVecList+  where+    variablesConsistent =+      let vs1 = sort . fmap fst $ offsetMaps+          vs2 = sort . fmap fst $ specMaps+      in vs1 == vs2+    specConsistent spec =+      case spec of+        (spec', Once (V.VL vs)) -> spec' `C.consistent` (Once . toUNF) vs == C.Consistent+        (spec', Mult (V.VL vs)) -> spec' `C.consistent` (Mult . toUNF) vs == C.Consistent+    toUNF :: [ V.Vec n Int64 ] -> UnionNF n Offsets+    toUNF = joins1 . NE.fromList . map (return . fmap intToSubscript)++    -- This function generates the special offsets subspace, subscript,+    -- that either had one element or is the whole set.+    intToSubscript :: Int64 -> Offsets+    intToSubscript i+      | fromIntegral i == absoluteRep = SetOfIntegers+      | otherwise = Offsets . S.singleton $ i++    -- Convert list of list of indices into vectors and wrap them around+    -- existential so that we don't have to prove they are all of the same+    -- size.+    specToVecList :: [ (Specification, Multiplicity (V.VecList Int64)) ]+    specToVecList = map (second (fmap V.fromLists)) specToIxs++    specToIxs :: [ (Specification, Multiplicity [ [ Int64 ] ]) ]+    specToIxs = pairWithFst specMaps (map (second toInt64) offsetMaps)++    toInt64 :: Multiplicity [ [ Int ] ] -> Multiplicity [ [ Int64 ] ]+    toInt64 = fmap (map (map fromIntegral))++    -- Given two maps for each key in the first map generate a set of+    -- tuples matching the (val,val') where val and val' are corresponding+    -- values from each set.+    pairWithFst :: Eq a => [ (a, b) ] -> [ (a, c) ] -> [ (b, c) ]+    pairWithFst [] _ = []+    pairWithFst ((key, val):xs) ys =+      map ((val,) . snd) (filter ((key ==) . fst) ys) ++ pairWithFst xs ys  -- Local variables: -- mode: haskell
src/Camfort/Specification/Stencils/CheckFrontend.hs view
@@ -16,8 +16,6 @@  {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}  module Camfort.Specification.Stencils.CheckFrontend   (@@ -31,39 +29,40 @@   , existingStencils   ) where -import Control.Arrow-import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) import Control.Monad.State.Strict import Control.Monad.Writer.Strict hiding (Product) import Data.Function (on) import Data.Generics.Uniplate.Operations import Data.List (intercalate, sort, union)+import Data.Maybe -import Camfort.Analysis.Annotations-import Camfort.Analysis.CommentAnnotator-import qualified Camfort.Helpers.Vec as V-import Camfort.Specification.Parser (SpecParseError)-import Camfort.Specification.Stencils.CheckBackend-import qualified Camfort.Specification.Stencils.Consistency as C-import Camfort.Specification.Stencils.Generate+import           Camfort.Analysis+import           Camfort.Analysis.Annotations+import           Camfort.Analysis.CommentAnnotator+import           Camfort.Specification.Parser (SpecParseError)+import           Camfort.Specification.Stencils.Analysis (StencilsAnalysis)+import           Camfort.Specification.Stencils.Annotation (SA)+import qualified Camfort.Specification.Stencils.Annotation as SA+import           Camfort.Specification.Stencils.CheckBackend+import           Camfort.Specification.Stencils.Generate+import           Camfort.Specification.Stencils.Model import qualified Camfort.Specification.Stencils.Parser as Parser-import Camfort.Specification.Stencils.Parser.Types (reqRegions)-import Camfort.Specification.Stencils.Model-import Camfort.Specification.Stencils.Syntax+import           Camfort.Specification.Stencils.Parser.Types (reqRegions)+import           Camfort.Specification.Stencils.Syntax -import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.BBlocks as FAB+import qualified Language.Fortran.AST               as F+import qualified Language.Fortran.Analysis          as FA+import qualified Language.Fortran.Analysis.BBlocks  as FAB import qualified Language.Fortran.Analysis.DataFlow as FAD-import qualified Language.Fortran.Util.Position as FU--import qualified Data.Map as M-import Data.Maybe-import Algebra.Lattice (joins1)-import Data.Int-import qualified Data.Set as S+import qualified Language.Fortran.Util.ModFile      as MF+import qualified Language.Fortran.Util.Position     as FU +-- TODO: Replace instances of this with logging of errors and warnings newtype CheckResult = CheckResult [StencilResult]+instance ExitCodeOfReport CheckResult where+  exitCodeOf (CheckResult rs) = exitCodeOfSet rs  -- | Retrieve a list of 'StencilResult' from a 'CheckResult'. --@@ -111,6 +110,11 @@   | SCWarn StencilCheckWarning   deriving (Eq) +instance ExitCodeOfReport StencilResult where+  exitCodeOf (SCOkay {}) = 0+  exitCodeOf (SCFail _) = 1+  exitCodeOf (SCWarn _) = 0+ class GetSpan a where   getSpan :: a -> FU.SrcSpan @@ -156,7 +160,7 @@ notWellSpecified got inferred = SCFail $ NotWellSpecified got inferred  -- | Create a check result informating a user of a parse error.-parseError :: FU.SrcSpan -> (SpecParseError Parser.SpecParseError) -> StencilResult+parseError :: FU.SrcSpan -> SpecParseError Parser.SpecParseError -> StencilResult parseError srcSpan err = SCFail $ ParseError srcSpan err  -- | Create a check result informating that a region already exists.@@ -193,6 +197,7 @@  instance Show CheckResult where   show = intercalate "\n" . fmap show . getCheckResult+instance Describe CheckResult  instance Show CheckError where   show = intercalate "\n" . fmap show . getCheckError@@ -208,11 +213,14 @@ instance Show StencilCheckError where   show (SynToAstError err srcSpan) = prettyWithSpan srcSpan (show err)   show (NotWellSpecified (spanActual, stencilActual) (spanInferred, stencilInferred)) =-    let sp = replicate 8 ' '-    in concat [prettyWithSpan spanActual "Not well specified.\n", sp,-               "Specification is:\n", sp, sp, pprintSpecDecls stencilActual, "\n",-               sp, "but at ", show spanInferred, " the code behaves as\n", sp, sp,-               pprintSpecDecls stencilInferred]+    concat $ [prettyWithSpan spanActual "Not well specified.\n", sp,+             "Specification is:\n", sp, sp, pprintSpecDecls stencilActual, "\n",+              sp, "but at ", show spanInferred] ++ msg+    where+      sp = replicate 8 ' '+      msg = case stencilInferred of+              [] -> [" there is no specifiable array computation"]+              _ ->  [" the code behaves as\n", sp, sp, pprintSpecDecls stencilInferred]   show (ParseError srcSpan err) = prettyWithSpan srcSpan (show err)   show (RegionExists srcSpan name) =     prettyWithSpan srcSpan ("Region '" ++ name ++ "' already defined")@@ -224,43 +232,43 @@     "Warning: Unused region '" ++ name ++ "'"  -- Entry point-stencilChecking :: F.ProgramFile (FA.Analysis A) -> CheckResult-stencilChecking pf = CheckResult . snd . runWriter $ do-  -- Attempt to parse comments to specifications-  pf' <- annotateComments Parser.specParser (\srcSpan err -> tell [parseError srcSpan err]) pf-  let -- get map of AST-Block-ID ==> corresponding AST-Block-      bm         = FAD.genBlockMap pf'-      -- get map of program unit  ==> basic block graph-      bbm        = FAB.genBBlockMap pf'-      -- build the supergraph of global dependency-      sgr        = FAB.genSuperBBGr bbm-      -- extract the supergraph itself-      gr         = FAB.superBBGrGraph sgr-      -- get map of variable name ==> { defining AST-Block-IDs }-      dm         = FAD.genDefMap bm-      -- perform reaching definitions analysis-      rd         = FAD.reachingDefinitions dm gr-      -- create graph of definition "flows"-      flowsGraph =  FAD.genFlowsToGraph bm dm gr rd-      -- identify every loop by its back-edge-      beMap      = FAD.genBackEdgeMap (FAD.dominators gr) gr-      ivmap      = FAD.genInductionVarMapByASTBlock beMap gr-      -- results :: Checker (F.ProgramFile (F.ProgramFile (FA.Analysis A)))-      results    = descendBiM perProgramUnitCheck pf'+stencilChecking :: F.ProgramFile SA -> StencilsAnalysis CheckResult+stencilChecking pf = do+  fmap (CheckResult . snd) . runWriterT $ do+    -- Attempt to parse comments to specifications+    pf' <- annotateComments Parser.specParser (\srcSpan err -> tell [parseError srcSpan err]) pf+    let -- get map of AST-Block-ID ==> corresponding AST-Block+        bm         = FAD.genBlockMap pf'+        -- get map of program unit  ==> basic block graph+        bbm        = FAB.genBBlockMap pf'+        -- build the supergraph of global dependency+        sgr        = FAB.genSuperBBGr bbm+        -- extract the supergraph itself+        gr         = FAB.superBBGrGraph sgr+        -- get map of variable name ==> { defining AST-Block-IDs }+        dm         = FAD.genDefMap bm+        -- perform reaching definitions analysis+        rd         = FAD.reachingDefinitions dm gr+        -- create graph of definition "flows"+        flowsGraph =  FAD.genFlowsToGraph bm dm gr rd+        -- identify every loop by its back-edge+        beMap      = FAD.genBackEdgeMap (FAD.dominators gr) gr+        ivmap      = FAD.genInductionVarMapByASTBlock beMap gr+        -- results :: Checker (F.ProgramFile (F.ProgramFile (FA.Analysis A)))+        results    = descendBiM perProgramUnitCheck pf' -  let addUnusedRegionsToResult = do-        regions'     <- fmap regions get-        usedRegions' <- fmap usedRegions get-        let unused = filter ((`notElem` usedRegions') . snd) regions'-        mapM_ (addResult . uncurry unusedRegion) unused-      output = checkResult $ execState-        (runReaderT-          (runChecker (results >> addUnusedRegionsToResult))-          flowsGraph)-        (startState ivmap)+    let addUnusedRegionsToResult = do+          regions'     <- fmap regions get+          usedRegions' <- fmap usedRegions get+          let unused = filter ((`notElem` usedRegions') . snd) regions'+          mapM_ (addResult . uncurry unusedRegion) unused -  tell output+    output <- lift $ checkResult . snd <$>+          runChecker (results >> addUnusedRegionsToResult) flowsGraph (startState ivmap) +    tell output++ data CheckState = CheckState   { regionEnv     :: RegionEnv   , checkResult   :: [StencilResult]@@ -299,18 +307,28 @@              , usedRegions   = []              } -newtype Checker a =-  Checker { runChecker :: ReaderT (FAD.FlowsGraph A) (State CheckState) a }-  deriving ( Functor, Applicative, Monad-           , MonadReader (FAD.FlowsGraph A)-           , MonadState CheckState-           ) +type CheckerEnv = FAD.FlowsGraph (SA.StencilAnnotation A)+type Checker = ReaderT CheckerEnv (StateT CheckState StencilsAnalysis)+++runChecker+  :: Checker a+  -> FAD.FlowsGraph (SA.StencilAnnotation A) -> CheckState+  -> StencilsAnalysis (a, CheckState)+runChecker c flows state = do+  let env = flows+  runStateT (runReaderT c env) state+++getFlowsGraph :: Checker (FAD.FlowsGraph (SA.StencilAnnotation A))+getFlowsGraph = asks id+ -- If the annotation contains an unconverted stencil specification syntax tree -- then convert it and return an updated annotation containing the AST-parseCommentToAST :: FA.Analysis A -> FU.SrcSpan -> Checker (Either SynToAstError (FA.Analysis A))+parseCommentToAST :: SA -> FU.SrcSpan -> Checker (Either SynToAstError SA) parseCommentToAST ann span =-  case getParseSpec (FA.prevAnnotation ann) of+  case SA.getParseSpec ann of     Just stencilComment -> do          informRegionsUsed (reqRegions stencilComment)          renv <- fmap regionEnv get@@ -323,91 +341,46 @@                           then addResult (regionExistsError span var)                                >> pure id                           else addRegionToTracked span var-                               >> pure (giveRegionSpec reg))-                     (pure . giveAstSpec . pure) ast-             pure . pure $ onPrev pfun ann+                               >> pure (SA.giveRegionSpec reg))+                     (pure . SA.giveAstSpec . pure) ast+             pure . pure $ pfun ann            Left err  -> pure . Left $ err      _ -> pure . pure $ ann  -- If the annotation contains an encapsulated region environment, extract it -- and add it to current region environment in scope-updateRegionEnv :: FA.Analysis A -> Checker ()+updateRegionEnv :: SA -> Checker () updateRegionEnv ann =-  case getRegionSpec (FA.prevAnnotation ann) of+  case SA.getRegionSpec ann of     Just renv -> modify (\s -> s { regionEnv = renv : regionEnv s })     _         -> pure () -checkOffsetsAgainstSpec :: [(Variable, Multiplicity [[Int]])]-                        -> [(Variable, Specification)]-                        -> Bool-checkOffsetsAgainstSpec offsetMaps specMaps =-  variablesConsistent &&-  all (\case-          (spec, Once (V.VL vs)) -> spec `C.consistent` (Once . toUNF) vs == C.Consistent-          (spec, Mult (V.VL vs)) -> spec `C.consistent` (Mult . toUNF) vs == C.Consistent)-  specToVecList-  where-    variablesConsistent =-      let vs1 = sort . fmap fst $ offsetMaps-          vs2 = sort . fmap fst $ specMaps-      in vs1 == vs2-    toUNF :: [ V.Vec n Int64 ] -> UnionNF n Offsets-    toUNF = joins1 . map (return . fmap intToSubscript)--    -- This function generates the special offsets subspace, subscript,-    -- that either had one element or is the whole set.-    intToSubscript :: Int64 -> Offsets-    intToSubscript i-      | fromIntegral i == absoluteRep = SetOfIntegers-      | otherwise = Offsets . S.singleton $ i--    -- Convert list of list of indices into vectors and wrap them around-    -- existential so that we don't have to prove they are all of the same-    -- size.-    specToVecList :: [ (Specification, Multiplicity (V.VecList Int64)) ]-    specToVecList = map (second (fmap V.fromLists)) specToIxs--    specToIxs :: [ (Specification, Multiplicity [ [ Int64 ] ]) ]-    specToIxs = pairWithFst specMaps (map (second toInt64) offsetMaps)--    toInt64 :: Multiplicity [ [ Int ] ] -> Multiplicity [ [ Int64 ] ]-    toInt64 = fmap (map (map fromIntegral))--    -- Given two maps for each key in the first map generate a set of-    -- tuples matching the (val,val') where val and val' are corresponding-    -- values from each set.-    pairWithFst :: Eq a => [ (a, b) ] -> [ (a, c) ] -> [ (b, c) ]-    pairWithFst [] _ = []-    pairWithFst ((key, val):xs) ys =-      map ((val,) . snd) (filter ((key ==) . fst) ys) ++ pairWithFst xs ys- -- Go into the program units first and record the module name when -- entering into a module perProgramUnitCheck ::-   F.ProgramUnit (FA.Analysis A) -> Checker (F.ProgramUnit (FA.Analysis A))+   F.ProgramUnit SA -> Checker (F.ProgramUnit SA)  perProgramUnitCheck p@F.PUModule{} = do     modify (\s -> s { prog = Just $ FA.puName p })     descendBiM perBlockCheck p perProgramUnitCheck p = descendBiM perBlockCheck p -perBlockCheck :: F.Block (FA.Analysis A) -> Checker (F.Block (FA.Analysis A))+perBlockCheck :: F.Block SA -> Checker (F.Block SA)  perBlockCheck b@(F.BlComment ann span _) = do   ast       <- parseCommentToAST ann span   case ast of     Left err -> addResult (synToAstError err span) *> pure b     Right ann' -> do-      flowsGraph <- ask       updateRegionEnv ann'       let b' = F.setAnnotation ann' b-      case (getAstSpec $ FA.prevAnnotation ann', stencilBlock $ FA.prevAnnotation ann') of+      case (SA.getAstSpec ann', SA.getStencilBlock ann') of         -- Comment contains a specification and an Associated block         (Just specDecls, Just block) ->          case block of           s@(F.BlStatement _ span' _ (F.StExpressionAssign _ _ lhs _)) -> do-             checkStencil flowsGraph s specDecls span' (isArraySubscript lhs) span+             checkStencil s specDecls span' (isArraySubscript lhs) span              return b'            -- Stub, maybe collect stencils inside 'do' block@@ -428,9 +401,9 @@   return b  -- | Validate the stencil and log an appropriate result.-checkStencil :: FAD.FlowsGraph A -> F.Block (FA.Analysis A) -> SpecDecls-  -> FU.SrcSpan -> Maybe [F.Index (FA.Analysis Annotation)] -> FU.SrcSpan -> Checker ()-checkStencil flowsGraph block specDecls spanInferred maybeSubs span = do+checkStencil :: F.Block SA -> SpecDecls+  -> FU.SrcSpan -> Maybe [F.Index SA] -> FU.SrcSpan -> Checker ()+checkStencil block specDecls spanInferred maybeSubs span = do   -- Work out whether this is a stencil (non empty LHS indices) or not   let (subs, isStencil) = case maybeSubs of                              Nothing -> ([], False)@@ -441,9 +414,12 @@   let ivs = extractRelevantIVS ivmap block    -- Do analysis; create list of relative indices+  flowsGraph <- getFlowsGraph   let lhsN         = fromMaybe [] (neighbourIndex ivmap subs)-      relOffsets = fst . runWriter $ genOffsets flowsGraph ivs lhsN [block]-      multOffsets = map (\relOffset ->++  relOffsets <- lift . lift $ fst <$> runStencilInferer (genOffsets lhsN [block]) ivs flowsGraph++  let multOffsets = map (\relOffset ->           case relOffset of           (var, (True, offsets)) -> (var, Mult offsets)           (var, (False, offsets)) -> (var, Once offsets)) relOffsets@@ -458,7 +434,7 @@                    if specExists then addResult (duplicateSpecification span)                      else addResult (specOkay span s v spanInferred)) expandedDecls     else do-    let inferred = fst . fst . runWriter $ genSpecifications flowsGraph ivs lhsN block+    inferred <- lift . lift $ fst . fst <$> runStencilInferer (genSpecifications lhsN block) ivs flowsGraph     addResult (notWellSpecified (span, specDecls) (spanInferred, inferred))   where     seenBefore :: (Variable, Specification) -> Checker Bool@@ -470,18 +446,6 @@                                     , scVar = var}                                 -> spec' == spec && bspan == spanInferred && v == var                               _ -> False) checkLog--genOffsets ::-     FAD.FlowsGraph A-  -> [Variable]-  -> [Neighbour]-  -> [F.Block (FA.Analysis A)]-  -> Writer EvalLog [(Variable, (Bool, [[Int]]))]-genOffsets flowsGraph ivs lhs blocks = do-    let (subscripts, _) = genSubscripts flowsGraph blocks-    assocsSequence $ mkOffsets subscripts-  where-    mkOffsets = M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs)  existingStencils :: CheckResult -> [(Specification, FU.SrcSpan, Variable)] existingStencils = mapMaybe getExistingStencil . getCheckResult
src/Camfort/Specification/Stencils/Consistency.hs view
@@ -8,11 +8,16 @@ import Camfort.Specification.Stencils.DenotationalSemantics import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.Syntax+import Camfort.Analysis (ExitCodeOfReport(..))  data ConsistencyResult =     Consistent   | Inconsistent String   deriving (Eq, Show)++instance ExitCodeOfReport ConsistencyResult where+  exitCodeOf Consistent = 0+  exitCodeOf (Inconsistent _) = 1  -- | This function checks multiplicity consistency and then delegates the -- spatial consistency to |consistent'| function.
src/Camfort/Specification/Stencils/DenotationalSemantics.hs view
@@ -77,7 +77,7 @@     convert :: RegionProd -> Either String (UnionNF n (Interval Standard))     convert (Product rs)       | null rs = Left "Empty region product"-      | otherwise = Right $ meets1 . map convert' $ rs+      | otherwise = Right $ meets1 . NE.fromList . map convert' $ rs      convert' r = return $ proto nOfDims $       case r of
src/Camfort/Specification/Stencils/Generate.hs view
@@ -8,57 +8,62 @@ Stability   :  experimental -} -{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE PatternGuards             #-}+{-# LANGUAGE ScopedTypeVariables       #-}  module Camfort.Specification.Stencils.Generate   (     EvalLog   , Neighbour(..)+  , convIxToNeighbour   , extractRelevantIVS-  , assocsSequence+  , genOffsets   , genSpecifications-  , genSubscripts+  , indicesToSpec   , isArraySubscript   , neighbourIndex+  , runStencilInferer+   -- Various helpers that get used by other tools, e.g., array-analysis   , isVariableExpr   , convIxToNeighbour   , indicesToRelativisedOffsets   , indicesToSpec   , neighbourToOffset   , relativise+  , consistentIVSuse   ) where -import Control.Monad (void, when, zipWithM)-import Control.Monad.State.Strict (get, put, runState, State)-import Control.Monad.Writer.Strict (tell, Writer)-import Data.Data (Data)-import Data.Foldable (foldrM)-import Data.Generics.Uniplate.Operations (transformBi, universeBi)-import Data.Graph.Inductive.Graph (lab, pre)+import           Control.Monad (void, when, zipWithM)+import           Control.Monad.State.Strict (State, get, put, runState)+import           Control.Monad.Writer.Strict (WriterT, runWriterT, tell)+import           Control.Monad.Reader (ReaderT, runReaderT, asks)+import           Data.Data (Data)+import           Data.Foldable (foldrM)+import           Data.Generics.Uniplate.Operations (transformBi, universeBi)+import           Data.Graph.Inductive.Graph (lab, pre) import qualified Data.IntMap as IM import qualified Data.Map as M-import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe)-import Data.Monoid ((<>))+import           Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe)+import           Data.Monoid ((<>)) import qualified Data.Set as S -import qualified Language.Fortran.Analysis as FA+import qualified Language.Fortran.AST               as F+import qualified Language.Fortran.Analysis          as FA import qualified Language.Fortran.Analysis.DataFlow as FAD-import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Util.Position as FU+import           Language.Fortran.Util.ModFile (ModFiles)+import qualified Language.Fortran.Util.Position     as FU -import Camfort.Analysis.Annotations (A, Annotation)-import Camfort.Helpers (collect)+import           Camfort.Analysis+import           Camfort.Helpers (collect) import qualified Camfort.Helpers.Vec as V-import Camfort.Specification.Stencils.Model+import           Camfort.Specification.Stencils.Annotation ()+import           Camfort.Specification.Stencils.Analysis+import           Camfort.Specification.Stencils.InferenceBackend+import           Camfort.Specification.Stencils.Model   (Approximation(..), Multiplicity(..))-import Camfort.Specification.Stencils.Annotation ()-import Camfort.Specification.Stencils.Syntax+import           Camfort.Specification.Stencils.Syntax   ( absoluteRep   , fromBool   , groupKeyBy@@ -69,10 +74,33 @@   , Specification(..)   , Variable) -import Camfort.Specification.Stencils.CheckBackend-import Camfort.Specification.Stencils.InferenceBackend+type Indices a = [[F.Index (FA.Analysis a)]]+ type EvalLog = [(String, Variable)] +data SIEnv ann = SIEnv+  {+    -- | In-scope induction variables.+    sieIvs :: [Variable]+  , sieFlowsGraph :: FAD.FlowsGraph ann+  }++-- | Analysis for working with low-level stencil inference.+type StencilInferer ann = ReaderT (SIEnv ann) (WriterT EvalLog StencilsAnalysis)++-- | Get the list of in-scope induction variables.+getIvs :: StencilInferer ann [Variable]+getIvs = asks sieIvs++-- | Get the FlowsGraph for the current analysis.+getFlowsGraph :: StencilInferer ann (FAD.FlowsGraph ann)+getFlowsGraph = asks sieFlowsGraph++runStencilInferer :: StencilInferer ann a -> [Variable] -> FAD.FlowsGraph ann -> StencilsAnalysis (a, EvalLog)+runStencilInferer si ivs flowsGraph = do+  let senv = SIEnv { sieIvs = ivs, sieFlowsGraph = flowsGraph }+  runWriterT $ runReaderT si senv+ {-| Representation for indices as either:      * neighbour indices      * constant@@ -84,7 +112,7 @@  {-| Match expressions which are array subscripts, returning Just of their     index expressions, else Nothing -}-isArraySubscript :: F.Expression (FA.Analysis A) -> Maybe [F.Index (FA.Analysis A)]+isArraySubscript :: F.Expression (FA.Analysis a) -> Maybe [F.Index (FA.Analysis a)] isArraySubscript (F.ExpSubscript _ _ (F.ExpValue _ _ (F.ValVariable _)) subs) =    Just $ F.aStrip subs isArraySubscript (F.ExpDataRef _ _ e e') =@@ -94,7 +122,10 @@ {-| Given an induction-variable-map, convert a list of indices to     Maybe a list of constant or neighbourhood indices.     If any are non neighbourhood then return Nothing -}-neighbourIndex :: FAD.InductionVarMapByASTBlock -> [F.Index (FA.Analysis A)] -> Maybe [Neighbour]+neighbourIndex :: (Data a)+               => FAD.InductionVarMapByASTBlock+               -> [F.Index (FA.Analysis a)]+               -> Maybe [Neighbour] neighbourIndex ivs ixs =   if NonNeighbour `notElem` neighbours   then Just neighbours@@ -102,63 +133,73 @@     where       neighbours = map (\ix -> convIxToNeighbour (extractRelevantIVS ivs ix) ix) ixs -genSpecifications ::-     FAD.FlowsGraph A-  -> [Variable]-  -> [Neighbour]-  -> F.Block (FA.Analysis A)-  -> Writer EvalLog ([([Variable], Specification)], [Int])-genSpecifications flowsGraph ivs lhs block = do-    let (subscripts, visitedNodes) = genSubscripts flowsGraph [block]-    varToSpecs <- assocsSequence $ mkSpecs subscripts-    case varToSpecs of-      [] -> do-         tell [("EVALMODE: Empty specification (tag: emptySpec)", "")]-         return ([], visitedNodes)-      _ -> do-         let varsToSpecs = groupKeyBy varToSpecs-         return (splitUpperAndLower varsToSpecs, visitedNodes)-    where-      mkSpecs = M.mapWithKey (\v -> indicesToSpec ivs v lhs)+genSpecifications+  :: (Data a, Show a, Eq a)+  => [Neighbour]+  -> F.Block (FA.Analysis a)+  -> StencilInferer a ([([Variable], Specification)], [Int])+genSpecifications lhs block = do+  (subscripts, visitedNodes) <- genSubscripts [block]+  varToSpecs <- assocsSequence . mkSpecs $ subscripts+  case varToSpecs of+    [] -> do+       tell [("EVALMODE: Empty specification (tag: emptySpec)", "")]+       return ([], visitedNodes)+    _ -> do+       let varsToSpecs = groupKeyBy varToSpecs+       return (splitUpperAndLower varsToSpecs, visitedNodes)+  where+    mkSpecs = M.mapWithKey (`indicesToSpec` lhs) -      splitUpperAndLower = concatMap splitUpperAndLower'-      splitUpperAndLower' (vs, Specification (Mult (Bound (Just l) (Just u))) isStencil)-        | isUnit l =-         [(vs, Specification (Mult (Bound Nothing (Just u))) isStencil)]-        | otherwise =-         [(vs, Specification (Mult (Bound (Just l) Nothing)) isStencil),-          (vs, Specification (Mult (Bound Nothing (Just u))) isStencil)]-      splitUpperAndLower' (vs, Specification (Once (Bound (Just l) (Just u))) isStencil)-        | isUnit l =-         [(vs, Specification (Mult (Bound Nothing (Just u))) isStencil)]-        | otherwise =-         [(vs, Specification (Once (Bound (Just l) Nothing)) isStencil),-          (vs, Specification (Once (Bound Nothing (Just u))) isStencil)]-      splitUpperAndLower' x = [x]+    splitUpperAndLower = concatMap splitUpperAndLower'+    splitUpperAndLower' (vs, Specification (Mult (Bound (Just l) (Just u))) isStencil)+      | isUnit l =+       [(vs, Specification (Mult (Bound Nothing (Just u))) isStencil)]+      | otherwise =+       [(vs, Specification (Mult (Bound (Just l) Nothing)) isStencil),+        (vs, Specification (Mult (Bound Nothing (Just u))) isStencil)]+    splitUpperAndLower' (vs, Specification (Once (Bound (Just l) (Just u))) isStencil)+      | isUnit l =+       [(vs, Specification (Mult (Bound Nothing (Just u))) isStencil)]+      | otherwise =+       [(vs, Specification (Once (Bound (Just l) Nothing)) isStencil),+        (vs, Specification (Once (Bound Nothing (Just u))) isStencil)]+    splitUpperAndLower' x = [x] +genOffsets+  :: (Data a, Show a, Eq a)+  => [Neighbour]+  -> [F.Block (FA.Analysis a)]+  -> StencilInferer a [(Variable, (Bool, [[Int]]))]+genOffsets lhs blocks = do+  (subscripts, _) <- genSubscripts blocks+  assocsSequence . mkOffsets $ subscripts+  where+    mkOffsets = M.mapWithKey (`indicesToRelativisedOffsets` lhs)+ {-| genSubscripts-   Takes * a flows graph-         * a list of blocks representing an RHS+   Takes * a list of blocks representing an RHS    Returns a map from array variables to indices, and a list of    nodes that were visited when computing this information -}-genSubscripts ::-     FAD.FlowsGraph A-  -> [F.Block (FA.Analysis A)]-  -> (M.Map Variable [[F.Index (FA.Analysis A)]], [Int])-genSubscripts flowsGraph blocks =-    (subscripts, visitedNodes)+genSubscripts+  :: (Data a, Show a, Eq a)+  => [F.Block (FA.Analysis a)]+  -> StencilInferer a (M.Map Variable (Indices a), [Int])+genSubscripts blocks = do+  flowsGraph <- getFlowsGraph+  let (maps, visitedNodes) = runState (mapM (genSubscripts' True flowsGraph) blocks) []+      subscripts = M.unionsWith (++) maps+  pure (subscripts, visitedNodes)   where-    (maps, visitedNodes) = runState (mapM (genSubscripts' True flowsGraph) blocks) []-    subscripts = M.unionsWith (++) maps-     -- Generate all subscripting expressions (that are translations on     -- induction variables) that flow to this block     -- The State monad provides a list of the visited nodes so far-    genSubscripts' ::-        Bool-     -> FAD.FlowsGraph A-     -> F.Block (FA.Analysis A)-     -> State [Int] (M.Map Variable [[F.Index (FA.Analysis A)]])+    genSubscripts'+      :: (Data a, Show a, Eq a)+      => Bool+      -> FAD.FlowsGraph a+      -> F.Block (FA.Analysis a)+      -> State [Int] (M.Map Variable (Indices a))      genSubscripts' False _ (F.BlStatement _ _ _ (F.StExpressionAssign _ _ e _))        | isJust $ isArraySubscript e@@ -178,9 +219,7 @@             put $ node : visited             let blocksFlowingIn = mapMaybe (lab flowsGraph) $ pre flowsGraph node             -- Try to get the block from the flowsGraph before analysis its rhses-            let blockG = case (lab flowsGraph node) of-                           Nothing -> block-                           Just b  -> b+            let blockG = fromMaybe block (lab flowsGraph node)             dependencies <- mapM (genSubscripts' False flowsGraph) blocksFlowingIn             return $ M.unionsWith (++) (genRHSsubscripts blockG : dependencies) @@ -188,17 +227,15 @@  -- | Given an induction variable map, and a piece of syntax -- return a list of induction variables in scope for this index-extractRelevantIVS :: (FU.Spanned (ast (FA.Analysis A)), F.Annotated ast) =>+extractRelevantIVS :: (FU.Spanned (ast (FA.Analysis a)), F.Annotated ast) =>      FAD.InductionVarMapByASTBlock-  -> ast (FA.Analysis A)+  -> ast (FA.Analysis a)   -> [Variable] extractRelevantIVS ivmap f = ivsList   where     ivsList = S.toList $ fromMaybe S.empty $ IM.lookup label ivmap -    label   = case (FA.insLabel . F.getAnnotation $ f) of-                Just label -> label-                Nothing    -> error errorMsg+    label   = fromMaybe (error errorMsg) (FA.insLabel . F.getAnnotation $ f)     -- For debugging purposes     errorMsg = show (FU.getSpan f)             ++ " get IVs associated to labelled index "@@ -207,47 +244,46 @@    its Neighbour representation    e.g., for the expression a(i+1,j-1) then this function gets    passed expr = i + 1   (returning +1) and expr = j - 1 (returning -1) -}-convIxToNeighbour :: [Variable] -> F.Index (FA.Analysis Annotation) -> Neighbour+convIxToNeighbour :: (Data a) => [Variable] -> F.Index (FA.Analysis a) -> Neighbour convIxToNeighbour _ (F.IxRange _ _ Nothing Nothing Nothing)     = Neighbour "" 0 convIxToNeighbour _ (F.IxRange _ _ Nothing Nothing                   (Just (F.ExpValue _ _ (F.ValInteger "1")))) = Neighbour "" 0 -convIxToNeighbour ivs (F.IxSingle _ _ _ exp)  = expToNeighbour ivs exp+convIxToNeighbour ivs (F.IxSingle _ _ _ expr)  = expToNeighbour ivs expr convIxToNeighbour _ _ = NonNeighbour -- indexing expression is a range  -- Combinator for reducing a map with effects and partiality inside -- into an effectful list of key-value pairs assocsSequence :: Monad m => M.Map k (m (Maybe a)) -> m [(k, a)] assocsSequence maps = do-    assocs <- mapM strength . M.toList $ maps-    return . mapMaybe strength $ assocs+  assocs <- mapM strength . M.toList $ maps+  return . mapMaybe strength $ assocs   where     strength :: Monad m => (a, m b) -> m (a, b)     strength (a, mb) = mb >>= (\b -> return (a, b))  -- Convert list of indexing expressions to a spec-indicesToSpec :: [Variable]-              -> Variable+indicesToSpec :: (Data a)+              => Variable               -> [Neighbour]-              -> [[F.Index (FA.Analysis Annotation)]]-              -> Writer EvalLog (Maybe Specification)-indicesToSpec ivs a lhs ixs = do-    mMultOffsets <- indicesToRelativisedOffsets ivs a lhs ixs-    return $ do-      (mult, offsets) <- mMultOffsets-      spec <- relativeIxsToSpec offsets-      let spec' = setLinearity (fromBool mult) spec-      return $ setType lhs spec'+              -> Indices a+              -> StencilInferer a (Maybe Specification)+indicesToSpec a lhs ixs = do+  mMultOffsets <- indicesToRelativisedOffsets a lhs ixs+  return $ do+    (mult, offsets) <- mMultOffsets+    spec <- relativeIxsToSpec offsets+    let spec' = setLinearity (fromBool mult) spec+    return $ setType lhs spec'  -- Get all RHS subscript which are translated induction variables -- return as a map from (source name) variables to a list of relative indices-genRHSsubscripts ::-     F.Block (FA.Analysis A)-  -> M.Map Variable [[F.Index (FA.Analysis A)]]-genRHSsubscripts b = genRHSsubscripts' (transformBi replaceModulo b)+genRHSsubscripts :: forall a. (Data a, Eq a)+                 => F.Block (FA.Analysis a) -> M.Map Variable (Indices a)+genRHSsubscripts block = genRHSsubscripts' (transformBi replaceModulo block)   where     -- Any occurence of an subscript "modulo(e, e')" is replaced with "e"-    replaceModulo :: F.Expression (FA.Analysis A) -> F.Expression (FA.Analysis A)+    replaceModulo :: F.Expression (FA.Analysis a) -> F.Expression (FA.Analysis a)     replaceModulo (F.ExpFunctionCall _ _                       (F.ExpValue _ _ (F.ValIntrinsic iname)) subs)         | iname `elem` ["modulo", "mod", "amod", "dmod"]@@ -257,9 +293,9 @@     replaceModulo e = e      genRHSsubscripts' b =-       collect [ (FA.srcName exp, e)-         | F.ExpSubscript _ _ exp subs <- FA.rhsExprs b-         , isVariableExpr exp+       collect [ (FA.srcName expr, e)+         | F.ExpSubscript _ _ expr subs <- FA.rhsExprs b+         , isVariableExpr expr          , let e = F.aStrip subs          , not (null e)] @@ -291,25 +327,26 @@          Neighbour (FA.varName e) (if x < 0 then abs x else (- x))              where x = read offs -expToNeighbour ivs e =+expToNeighbour ivs expr =   -- Record when there is some kind of relative index on an inducion variable   -- but that is not a neighbourhood index by our definitions   if null ivs' then Constant (F.ValInteger "0") else NonNeighbour   where     -- set of all induction variables involved in this expression     ivs' = [i | e@(F.ExpValue _ _ F.ValVariable{})-                 <- universeBi e :: [F.Expression (FA.Analysis a)]+                 <- universeBi expr :: [F.Expression (FA.Analysis a)]                 , let i = FA.varName e                 , i `elem` ivs] -indicesToRelativisedOffsets :: [Variable]-                            -> Variable+indicesToRelativisedOffsets :: (Data a)+                            => Variable                             -> [Neighbour]-                            -> [[F.Index (FA.Analysis Annotation)]]-                            -> Writer EvalLog (Maybe (Bool, [[Int]]))-indicesToRelativisedOffsets ivs a lhs ixs = do+                            -> Indices a+                            -> StencilInferer a (Maybe (Bool, [[Int]]))+indicesToRelativisedOffsets a lhs ixs = do+  ivs <- getIvs    -- Convert indices to neighbourhood representation-  let rhses = map (map (\ix -> convIxToNeighbour ivs ix) ) ixs+  let rhses = fmap (fmap (convIxToNeighbour ivs)) ixs    -- As an optimisation, do duplicate check in front-end first   -- so that duplicate indices don't get passed into the main engine@@ -341,27 +378,31 @@ -- Convert list of relative offsets to a spec relativeIxsToSpec :: [[Int]] -> Maybe Specification relativeIxsToSpec ixs =-    if isEmpty exactSpec then Nothing else Just exactSpec-    where exactSpec = inferFromIndicesWithoutLinearity . V.fromLists $ ixs+  if isEmpty exactSpec then Nothing else Just exactSpec+  where exactSpec = inferFromIndicesWithoutLinearity . V.fromLists $ ixs  {-| Set the type of Specification (stencil or access) based on the lhs     set of neighbourhood indices; empty implies this is an access     specification -} setType :: [Neighbour] -> Specification -> Specification setType [] (Specification spec _) = Specification spec False+setType xs (Specification spec _) | all isConstant xs = Specification spec False+  where+    isConstant (Constant _) = True+    isConstant _            = False setType _  (Specification spec _)  = Specification spec True  -- Given a list of the neighbourhood representation for the LHS, of size n -- and a list of size-n lists of offsets, relativise the offsets relativise :: [Neighbour] -> [[Neighbour]] -> [[Neighbour]] relativise lhs rhses = foldr relativiseRHS rhses lhs-    where-      relativiseRHS (Neighbour lhsIV i) rhses =-          map (map (relativiseBy lhsIV i)) rhses-      relativiseRHS _ rhses = rhses+  where+    relativiseRHS (Neighbour lhsIV i) rs =+        map (map (relativiseBy lhsIV i)) rs+    relativiseRHS _ rs = rs -      relativiseBy v i (Neighbour u j) | v == u = Neighbour u (j - i)-      relativiseBy _ _ x = x+    relativiseBy v i (Neighbour u j) | v == u = Neighbour u (j - i)+    relativiseBy _ _ x = x  -- Helper predicates isVariableExpr :: F.Expression a -> Bool
src/Camfort/Specification/Stencils/InferenceBackend.hs view
@@ -28,6 +28,7 @@   ) where  import Data.List+import qualified Data.List.NonEmpty as NE import Data.Maybe import Algebra.Lattice (joins1) @@ -47,7 +48,7 @@   where     approxVecs =       toApprox . map (fmap absRepToInf . transposeVecInterval) $ spans-    approxUnion = fmap (optimise . joins1 . map return) approxVecs+    approxUnion = fmap (optimise . joins1 . NE.fromList . map return) approxVecs      toApprox :: [ V.Vec n (Interval Arbitrary) ]              -> Approximation [ V.Vec n (Interval Standard) ]
src/Camfort/Specification/Stencils/InferenceFrontend.hs view
@@ -15,7 +15,6 @@ -}  {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -23,37 +22,41 @@  module Camfort.Specification.Stencils.InferenceFrontend   (-    -- * Datatypes and Aliases-    InferMode(..)     -- * Functions-  , stencilInference+    stencilInference+  , stencilSynthesis+    -- * report+  , StencilsReport(..)   ) where -import Control.Monad.State.Strict-import Control.Monad.Reader-import Control.Monad.Writer.Strict hiding (Product)+import Control.Monad.RWS.Strict+import Control.Monad.Writer.Strict -import Camfort.Analysis.CommentAnnotator-import Camfort.Specification.Stencils.CheckBackend (synToAst)-import Camfort.Specification.Stencils.CheckFrontend+import           Camfort.Analysis+import           Camfort.Analysis.Annotations+import           Camfort.Analysis.CommentAnnotator+import           Camfort.Helpers (collect, descendReverseM, descendBiReverseM)+import qualified Camfort.Helpers.Vec as V+import           Camfort.Input+import           Camfort.Specification.Stencils.Analysis (StencilsAnalysis)+import           Camfort.Specification.Stencils.Annotation (SA)+import qualified Camfort.Specification.Stencils.Annotation as SA+import           Camfort.Specification.Stencils.CheckBackend (synToAst)+import           Camfort.Specification.Stencils.CheckFrontend   (CheckResult, existingStencils, stencilChecking)-import Camfort.Specification.Stencils.Generate-import Camfort.Specification.Stencils.InferenceBackend-import Camfort.Specification.Stencils.Model-import Camfort.Specification.Stencils.Syntax+import           Camfort.Specification.Stencils.Generate+import           Camfort.Specification.Stencils.InferenceBackend+import           Camfort.Specification.Stencils.Model import qualified Camfort.Specification.Stencils.Parser as Parser-import Camfort.Specification.Stencils.Parser.Types (SpecInner)+import           Camfort.Specification.Stencils.Parser.Types (SpecInner)+import           Camfort.Specification.Stencils.Syntax import qualified Camfort.Specification.Stencils.Synthesis as Synth-import Camfort.Analysis.Annotations-import Camfort.Helpers (collect, descendReverseM, descendBiReverseM)-import qualified Camfort.Helpers.Vec as V-import Camfort.Input -import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.BBlocks as FAB+import qualified Language.Fortran.AST               as F+import qualified Language.Fortran.Analysis          as FA+import qualified Language.Fortran.Analysis.BBlocks  as FAB import qualified Language.Fortran.Analysis.DataFlow as FAD-import qualified Language.Fortran.Util.Position as FU+import qualified Language.Fortran.Util.Position     as FU  import Data.Data import Data.Foldable@@ -64,14 +67,6 @@ import Data.Maybe import Data.Monoid ((<>)) --- Define modes of interaction with the inference-data InferMode =-  AssignMode | EvalMode | Synth-  deriving (Eq, Show, Data, Read)--instance Default InferMode where-    defaultValue = AssignMode- data InferState = IS {      ivMap        :: FAD.InductionVarMapByASTBlock    , visitedNodes :: [Int]}@@ -80,8 +75,11 @@   {     -- | Known (existing) specifications.     ieExistingSpecs :: [(Specification, FU.SrcSpan, Variable)]-  , ieFlowsGraph    :: FAD.FlowsGraph A-  , ieInferMode     :: InferMode+  , ieFlowsGraph    :: FAD.FlowsGraph (SA.StencilAnnotation A)+  -- | Provide additional evaluation information when active.+  , ieUseEval       :: Bool+  -- | Instruct the inferer to perform synthesis.+  , ieDoSynth       :: Bool   , ieMarker        :: Char   , ieMetaInfo      :: F.MetaInfo   }@@ -89,31 +87,69 @@  -- The inferer returns information as a LogLine type LogLine = (FU.SrcSpan, Either [([Variable], Specification)] (String,Variable))++data StencilsReport = StencilsReport [(String, LogLine)] -- ^ (filename, logged stencil)+instance ExitCodeOfReport StencilsReport where+  exitCodeOf _ = 0++instance Show StencilsReport where+  show (StencilsReport flogs) = unlines . filter (not . white) $ output+    where+      output = [ Synth.formatSpecNoComment ll | (_, ll) <- flogs ]+      white  = all (\x -> (x == ' ') || (x == '\t'))++instance Describe StencilsReport+ -- The core of the inferer works within this monad-type Inferer = WriterT [LogLine]-                 (ReaderT InferEnv-                    (State InferState)) +type Inferer = RWST InferEnv [LogLine] InferState StencilsAnalysis++getExistingSpecs :: Inferer [(Specification, FU.SrcSpan, Variable)]+getExistingSpecs = asks ieExistingSpecs++getFlowsGraph :: Inferer (FAD.FlowsGraph (SA.StencilAnnotation A))+getFlowsGraph = asks ieFlowsGraph++getMetaInfo :: Inferer F.MetaInfo+getMetaInfo = asks ieMetaInfo++getMarker :: Inferer Char+getMarker = asks ieMarker++getUseEval :: Inferer Bool+getUseEval = asks ieUseEval++getDoSynth :: Inferer Bool+getDoSynth = asks ieDoSynth+ runInferer :: CheckResult-           -> InferMode+           -> Bool+           -> Bool            -> Char            -> F.MetaInfo            -> FAD.InductionVarMapByASTBlock-           -> FAD.FlowsGraph A+           -> FAD.FlowsGraph (SA.StencilAnnotation A)            -> Inferer a-           -> (a, [LogLine])-runInferer cr mode marker mi ivmap flTo =-    flip evalState (IS ivmap [])-  . flip runReaderT env-  . runWriterT+           -> StencilsAnalysis (a, [LogLine])+runInferer cr useEval doSynth marker mi ivmap flTo inferer = do+  evalRWST inferer env (IS ivmap [])   where env = IE           { ieExistingSpecs = existingStencils cr           , ieFlowsGraph    = flTo-          , ieInferMode     = mode+          , ieUseEval       = useEval+          , ieDoSynth       = doSynth           , ieMarker        = marker           , ieMetaInfo      = mi           } +-- | Run something only when eval mode is active.+whenEval :: Inferer () -> Inferer ()+whenEval i = getUseEval >>= (`when` i)++-- | Run something only when we should perform synthesis.+ifSynth :: Inferer a -> Inferer a -> Inferer a+ifSynth t e = getDoSynth >>= (\doSynth -> if doSynth then t else e)+ -- | Attempt to convert a 'Parser.Specification' into a 'Specification'. -- -- Only performs conversions for spatial specifications.@@ -124,35 +160,46 @@                          Right x  -> Just x  -- | Main stencil inference code-stencilInference :: InferMode+stencilInference :: Bool                  -> Char-                 -> F.ProgramFile (FA.Analysis A)-                 -> (F.ProgramFile (FA.Analysis A), [LogLine])-stencilInference mode marker pf =-    (F.ProgramFile mi pus', log1)-  where-    -- Parse specification annotations and include them into the syntax tree-    -- that way if generate specifications at the same place we can-    -- decide whether to synthesise or not+                 -> F.ProgramFile SA+                 -> StencilsAnalysis [LogLine]+stencilInference useEval marker pf = execWriterT $ stencilSynthesis' useEval False marker pf -    -- TODO: might want to output log0 somehow (though it doesn't fit LogLine)-    (pf'@(F.ProgramFile mi pus), _log0) =-         if mode == Synth-          then runWriter (annotateComments Parser.specParser (const . const . pure $ ()) pf)-          else (pf, [])+stencilSynthesis :: Char+                 -> F.ProgramFile SA+                 -> StencilsAnalysis (F.ProgramFile SA, [LogLine])+stencilSynthesis marker pf = do+  let (pf', _log0 :: String) = runWriter (annotateComments Parser.specParser (const . const . pure $ ()) pf)+  logDebug' pf $ describe _log0+  runWriterT $ stencilSynthesis' False True marker pf' -    (pus', log1)    = runWriter (transformBiM perPU pus)-    checkRes        = stencilChecking pf+-- | Main stencil synthesis code+stencilSynthesis' :: Bool+                  -> Bool+                  -> Char+                  -> F.ProgramFile SA+                  -> WriterT [LogLine] StencilsAnalysis+                     (F.ProgramFile SA)+stencilSynthesis' useEval doSynth marker pf@(F.ProgramFile mi pus) = do+  checkRes <- lift $ stencilChecking pf -    -- Run inference per program unit-    perPU :: F.ProgramUnit (FA.Analysis A)-          -> Writer [LogLine] (F.ProgramUnit (FA.Analysis A))+  let+    -- get map of AST-Block-ID ==> corresponding AST-Block+    bm    = FAD.genBlockMap pf+    -- get map of program unit ==> basic block graph+    bbm   = FAB.genBBlockMap pf+    -- get map of variable name ==> { defining AST-Block-IDs }+    dm    = FAD.genDefMap bm +    -- -- Run inference per program unit+    perPU :: F.ProgramUnit SA+          -> WriterT [LogLine] StencilsAnalysis (F.ProgramUnit SA)     perPU pu | Just _ <- FA.bBlocks $ F.getAnnotation pu = do         let -- Analysis/infer on blocks of just this program unit             blocksM = mapM perBlockInfer (F.programUnitBody pu)             -- Update the program unit body with these blocks-            pum = (F.updateProgramUnitBody pu) <$> blocksM+            pum = F.updateProgramUnitBody pu <$> blocksM              -- perform reaching definitions analysis             rd = FAD.reachingDefinitions dm gr@@ -167,42 +214,36 @@             -- identify every loop by its back-edge             ivMap = FAD.genInductionVarMapByASTBlock beMap gr -            (pu', log) = runInferer checkRes mode marker mi ivMap flTo pum+        (pu', log) <- lift $ runInferer checkRes useEval doSynth marker mi ivMap flTo pum         tell log-        return pu'+        pure pu'+    perPU pu = pure pu -    perPU pu = return pu+  pus' <- transformBiM perPU pus -    -- get map of AST-Block-ID ==> corresponding AST-Block-    bm    = FAD.genBlockMap pf'-    -- get map of program unit ==> basic block graph-    bbm   = FAB.genBBlockMap pf'-    -- get map of variable name ==> { defining AST-Block-IDs }-    dm    = FAD.genDefMap bm+  pure (F.ProgramFile mi pus')  {- *** 1 . Core inference over blocks -}  genSpecsAndReport ::      FU.SrcSpan -> [Neighbour]-  -> F.Block (FA.Analysis A)+  -> F.Block SA   -> Inferer [([Variable], Specification)]  genSpecsAndReport span lhsIxs block = do   -- Get the induction variables relative to the current block   (IS ivmap _) <- get   let ivs = extractRelevantIVS ivmap block--  mode         <- fmap ieInferMode ask-  flowsGraph   <- fmap ieFlowsGraph ask+  flowsGraph   <- getFlowsGraph   -- Generate specification for the-  let ((specs, visited), evalInfos) = runWriter $ genSpecifications flowsGraph ivs lhsIxs block+  ((specs, visited), evalInfos) <- lift $ runStencilInferer (genSpecifications lhsIxs block) ivs flowsGraph   -- Remember which nodes were visited during this traversal   modify (\state -> state { visitedNodes = visitedNodes state ++ visited })   -- Report the specifications   tell [ (span, Left specs) ]    -- Evaluation mode information reporting:-  when (mode == EvalMode) $ do+  whenEval $ do     tell [ (span, Right ("EVALMODE: assign to relative array subscript\                          \ (tag: tickAssign)","")) ]     forM_ evalInfos $ \evalInfo ->@@ -214,8 +255,8 @@   return specs  -- Traverse Blocks in the AST and infer stencil specifications-perBlockInfer :: F.Block (FA.Analysis A)-              -> Inferer (F.Block (FA.Analysis A))+perBlockInfer :: F.Block SA+              -> Inferer (F.Block SA) perBlockInfer = perBlockInfer' False -- The primed version, perBlockInfer' has a flag indicating whether -- the following code is inside a do-loop since we only target@@ -225,54 +266,55 @@  perBlockInfer' inDo b@(F.BlStatement ann span@(FU.SrcSpan lp _) _ stmnt) = do   (IS ivmap visitedStmts) <- get-  mode <- fmap ieInferMode ask   let label = fromMaybe (-1) (FA.insLabel ann)   if label `elem` visitedStmts   then -- This statement has been part of a visited dataflow path     return b   else do     -- On all StExpressionAssigns that occur in stmt....-    userSpecs <- fmap ieExistingSpecs ask+    userSpecs <- getExistingSpecs     let lhses = [lhs | (F.StExpressionAssign _ _ lhs _)-                         <- universe stmnt :: [F.Statement (FA.Analysis A)]]-    specs <- mapM (genSpecsFor ivmap mode) lhses-    marker <- fmap ieMarker ask-    mi     <- fmap ieMetaInfo ask-    if mode == Synth && not (null specs) && specs /= [[]]-    then-      let specComment = Synth.formatSpec mi tabs marker (span, Left specs')-          specs' = concatMap (mapMaybe noSpecAlready) specs+                         <- universe stmnt :: [F.Statement SA]]+    specs <- mapM (genSpecsFor ivmap) lhses+    marker <- getMarker+    mi     <- getMetaInfo+    ifSynth+      (if not (null specs) && specs /= [[]]+       then+         let specComment = Synth.formatSpec mi tabs marker (span, Left specs')+             specs' = concatMap (mapMaybe noSpecAlready) specs -          noSpecAlready (vars, spec) =-            if null vars'-            then Nothing-            else Just (vars', spec)-            where vars' = filter (\v -> (spec, span, v) `notElem` userSpecs) vars+             noSpecAlready (vars, spec) =+               if null vars'+               then Nothing+               else Just (vars', spec)+               where vars' = filter (\v -> (spec, span, v) `notElem` userSpecs) vars -          -- Indentation for the specification to match the code-          tabs  = FU.posColumn lp - 1-          (FU.SrcSpan loc _) = span-          span' = FU.SrcSpan (lp {FU.posColumn = 1}) (lp {FU.posColumn = 1})-          ann'  = ann { FA.prevAnnotation = (FA.prevAnnotation ann) { refactored = Just loc } }-      in pure (F.BlComment ann' span' (F.Comment specComment))-    else return b+             -- Indentation for the specification to match the code+             tabs  = FU.posColumn lp - 1+             (FU.SrcSpan loc _) = span+             span' = FU.SrcSpan (lp {FU.posColumn = 1}) (lp {FU.posColumn = 1})+             ann'  = SA.modifyBaseAnnotation (\ba -> ba { refactored = Just loc }) ann+         in pure (F.BlComment ann' span' (F.Comment specComment))+       else pure b)+       (pure b)   where     -- Assignment to a variable-    genSpecsFor _ _ (F.ExpValue _ _ (F.ValVariable _)) | inDo = genSpecsAndReport span [] b+    genSpecsFor :: FAD.InductionVarMapByASTBlock -> F.Expression SA -> Inferer [([Variable], Specification)]+    genSpecsFor _ (F.ExpValue _ _ (F.ValVariable _)) | inDo = genSpecsAndReport span [] b     -- Assignment to something else...-    genSpecsFor ivmap mode lhs =+    genSpecsFor ivmap lhs =       case isArraySubscript lhs of         Just subs ->           -- Left-hand side is a subscript-by relative index or by a range           case neighbourIndex ivmap subs of             Just lhs -> genSpecsAndReport span lhs b-            Nothing  -> if mode == EvalMode-                        then do-                          tell [(span , Right ("EVALMODE: LHS is an array\-                                              \ subscript we can't handle \-                                              \(tag: LHSnotHandled)",""))]-                          pure []-                        else pure []+            Nothing  -> do+              whenEval $+                tell [(span , Right ("EVALMODE: LHS is an array\+                                     \ subscript we can't handle \+                                     \(tag: LHSnotHandled)",""))]+              pure []         -- Not an assign we are interested in         _ -> pure []
src/Camfort/Specification/Units.hs view
@@ -20,402 +20,37 @@  -} -{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}--module Camfort.Specification.Units-  (checkUnits, inferUnits, compileUnits, synthesiseUnits, inferCriticalVariables, chooseImplicitNames)-where--import qualified Data.Map.Strict as M-import Data.Data-import Data.List (intercalate, find, sort, group, nub, inits)-import Data.Maybe (fromMaybe, maybeToList, mapMaybe, maybe)-import Data.Binary-import Data.Generics.Uniplate.Operations-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as LB-import GHC.Generics (Generic)--import Camfort.Helpers-import Camfort.Analysis.Annotations-import Camfort.Input-import Camfort.Reprint (subtext)+module Camfort.Specification.Units (synthesiseUnits) where --- Provides the types and data accessors used in this module-import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.Monad-import Camfort.Specification.Units.InferenceFrontend-import Camfort.Specification.Units.Synthesis (runSynthesis)+import Control.Monad.Reader (asks) -import qualified Language.Fortran.Analysis.Renaming as FAR-import qualified Language.Fortran.Analysis.Types as FAT+import qualified Language.Fortran.AST      as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Util.Position as FU-import Language.Fortran.Util.ModFile --- | Run a unit inference.-runInference :: UnitOpts-             -> F.ProgramFile UA-             -> UnitSolver a-             -> (Either UnitException a, UnitState, UnitLogs)-runInference uOpts pf runner = runUnitSolver uOpts pf $ do-  let compiledUnits = combinedCompiledUnits . M.elems . uoModFiles $ uOpts-  modifyTemplateMap  . const . cuTemplateMap  $ compiledUnits-  modifyNameParamMap . const . cuNameParamMap $ compiledUnits-  initInference-  runner---- *************************************---   Unit inference (top - level)------ *************************************--{-| Infer one possible set of critical variables for a program -}-inferCriticalVariables-  :: UnitOpts-  -> F.ProgramFile Annotation-  -> (Report, Int)-inferCriticalVariables uOpts pf-  | Right vars <- eVars = okReport vars-  | Left exc   <- eVars = (errReport exc, -1)-  where-    fname = F.pfGetFilename pf-    -- Format report-    okReport []   = (logs ++ "\n" ++ fname-                         ++ ":No additional annotations are necessary.\n", 0)-    okReport vars = ( logs ++ "\n" ++ fname ++ ": "-                           ++ show numVars-                           ++ " variable declarations suggested to be given a specification:\n"-                           ++ unlines [ "    " ++ declReport d | d <- M.toList dmapSlice ]-                    , numVars)-      where-        varNames  = map unitVarName vars-        dmapSlice = M.filterWithKey (\ k _ -> k `elem` varNames) dmap-        numVars   = M.size dmapSlice--    declReport (v, (dc, ss)) = vfilename ++ " (" ++ showSrcSpan ss ++ ")    " ++ fromMaybe v (M.lookup v uniqnameMap)-      where vfilename = fromMaybe fname $ M.lookup v fromWhereMap--    unitVarName (UnitVar (v, _))                 = v-    unitVarName (UnitParamVarUse (_, (v, _), _)) = v-    unitVarName _                                = "<bad>"--    errReport exc = logs ++ "\n" ++ fname ++ ":\n" ++ show exc--    (eVars, state, logs) = runInference uOpts pfRenamed runCriticalVariables-    pfUA = usProgramFile state -- the program file after units analysis is done--    -- Use the module map derived from all of the included Camfort Mod files.-    mmap = combinedModuleMap (M.elems (uoModFiles uOpts))-    pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf--    -- Map of all declarations-    dmap = extractDeclMap pfRenamed `M.union` combinedDeclMap (M.elems (uoModFiles uOpts))--    mmap' = extractModuleMap pfRenamed `M.union` mmap -- post-parsing-    -- unique name -> src name across modules-    uniqnameMap = M.fromList [-                (FA.varName e, FA.srcName e) |-                e@(F.ExpValue _ _ (F.ValVariable {})) <- universeBi pfRenamed :: [F.Expression UA]-                -- going to ignore intrinsics here-              ] `M.union` (M.unions . map (M.fromList . map (\ (a, (b, _)) -> (b, a)) . M.toList) $ M.elems mmap')-    fromWhereMap = genUniqNameToFilenameMap . M.elems $ uoModFiles uOpts--checkUnits, inferUnits :: UnitOpts -> F.ProgramFile Annotation -> Report-{-| Check units-of-measure for a program -}-checkUnits uOpts pf-  | Right mCons <- eCons = okReport mCons-  | Left exc    <- eCons = errReport exc-  where-    fname = F.pfGetFilename pf-    -- Format report-    okReport Nothing     = logs ++ "\n" ++ fname ++ ": Consistent. " ++ show nVars ++ " variables checked."-    okReport (Just cons) = logs ++ "\n" ++ fname ++ ": Inconsistent:\n" ++ reportErrors cons ++ "\n\n" ++-                           unlines (map showSrcConstraint constraints)-    showSrcConstraint :: (Constraint, FU.SrcSpan) -> String-    showSrcConstraint (con, srcSpan) = show srcSpan ++ ": " ++ show con--    reportErrors cons = unlines [ maybe "" showSS ss ++ str | (ss, str) <- reports ]-      where-        reports = map head . group . sort . map reportError . filter relevantConstraints $ cons-        showSS  = (++ ": ") . (" - at "++) . showSrcSpan--        relevantConstraints c = not (isPolymorphic0 c) && not (isReflexive c)--        isPolymorphic0 (ConEq (UnitParamLitAbs {}) _) = True-        isPolymorphic0 (ConEq _ (UnitParamLitAbs {})) = True-        isPolymorphic0 _                         = False--        isReflexive (ConEq u1 u2) = u1 == u2--    reportError con = (span, pprintConstr (orient (unrename con)) ++ additionalInfo con)-      where-        span = findCon con-        -- Create additional info for errors-        additionalInfo con =-           if null (errorInfo con)-           then ""-           else "\n    instead" ++ intercalate "\n" (mapNotFirst (pad 10) (errorInfo con))-        -- Create additional info about inconsistencies involving variables-        errorInfo con =-            [" '" ++ sName ++ "' is '" ++ pprintUnitInfo (unrename u) ++ "'"-              | UnitVar (vName, sName) <- universeBi con-              , u                       <- findUnitConstrFor con vName ]-        -- Find unit information for variable constraints-        findUnitConstrFor con v = mapMaybe (\con' -> if con == con'-                                                     then Nothing-                                                     else constrainedTo v con')-                                           (concat $ M.elems templateMap)-        constrainedTo v (ConEq (UnitVar (v', _)) u) | v == v' = Just u-        constrainedTo v (ConEq u (UnitVar (v', _))) | v == v' = Just u-        constrainedTo _ _ = Nothing--        mapNotFirst f [] = []-        mapNotFirst f (x : xs) =  x : (map f xs)--        orient (ConEq u (UnitVar v)) = ConEq (UnitVar v) u-        orient (ConEq u (UnitParamVarUse v)) = ConEq (UnitParamVarUse v) u-        orient c = c--        pad o = (++) (replicate o ' ')--        srcSpan con | Just ss <- findCon con = showSrcSpan ss ++ " "-                    | otherwise                   = ""--    -- Find a given constraint within the annotated AST. FIXME: optimise--    findCon :: Constraint -> Maybe FU.SrcSpan-    findCon con = lookupWith (eq con) constraints-      where eq c1 c2 = or [ conParamEq c1 c2' | c2' <- universeBi c2 ]---    constraints = [ (c, srcSpan)-                  | x <- universeBi pfUA :: [F.Expression UA]-                  , let srcSpan = FU.getSpan x-                  , c <- maybeToList (getConstraint x)-                  ] ++--                  [ (c, srcSpan)-                  | x <- universeBi pfUA :: [F.Statement UA]-                  , let srcSpan = FU.getSpan x-                  , c <- maybeToList (getConstraint x)-                  ] ++--                  [ (c, srcSpan)-                  | x <- universeBi pfUA :: [F.Argument UA]-                  , let srcSpan = FU.getSpan x-                  , c <- maybeToList (getConstraint x)-                  ] ++--                  [ (c, srcSpan)-                  | x <- universeBi pfUA :: [F.Declarator UA]-                  , let srcSpan = FU.getSpan x-                  , c <- maybeToList (getConstraint x)-                  ] ++--                  -- Why reverse? So that PUFunction and PUSubroutine appear-                  -- first in the list, before PUModule.-                  reverse [ (c, srcSpan)-                  | x <- universeBi pfUA :: [F.ProgramUnit UA]-                  , let srcSpan = FU.getSpan x-                  , c <- maybeToList (getConstraint x)-                  ]--    varReport     = intercalate ", " . map showVar--    showVar (UnitVar (_, s)) = s-    showVar (UnitLiteral _)   = "<literal>" -- FIXME-    showVar _                 = "<bad>"--    errReport exc = logs ++ "\n" ++ fname ++ ":  " ++ show exc--    (eCons, state, logs) = runInference uOpts pfRenamed runInconsistentConstraints-    templateMap = usTemplateMap state-    pfUA :: F.ProgramFile UA-    pfUA = usProgramFile state -- the program file after units analysis is done--    -- number of 'real' variables checked, e.g. not parametric-    nVars = M.size . M.filter (not . isParametricUnit) $ usVarUnitMap state-    isParametricUnit u = case u of UnitParamPosAbs {} -> True; UnitParamPosUse {} -> True-                                   UnitParamVarAbs {} -> True; UnitParamVarUse {} -> True-                                   _ -> False--    -- Use the module map derived from all of the included Camfort Mod files.-    mmap = combinedModuleMap (M.elems (uoModFiles uOpts))-    pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf--lookupWith :: (a -> Bool) -> [(a,b)] -> Maybe b-lookupWith f = fmap snd . find (f . fst)----- | Create unique names for all of the inferred implicit polymorphic--- unit variables.-chooseImplicitNames :: [(VV, UnitInfo)] -> [(VV, UnitInfo)]-chooseImplicitNames vars = replaceImplicitNames (genImplicitNamesMap vars) vars--genImplicitNamesMap :: Data a => a -> M.Map UnitInfo UnitInfo-genImplicitNamesMap x = M.fromList [ (absU, UnitParamEAPAbs (newN, newN)) | (absU, newN) <- zip absUnits newNames ]-  where-    absUnits = nub [ u | u@(UnitParamPosAbs _)             <- universeBi x ]-    eapNames = nub $ [ n | u@(UnitParamEAPAbs (_, n))      <- universeBi x ] ++-                     [ n | u@(UnitParamEAPUse ((_, n), _)) <- universeBi x ]-    newNames = filter (`notElem` eapNames) . map ('\'':) $ nameGen-    nameGen  = concatMap sequence . tail . inits $ repeat ['a'..'z']--replaceImplicitNames :: Data a => M.Map UnitInfo UnitInfo -> a -> a-replaceImplicitNames implicitMap = transformBi replace-  where-    replace u@(UnitParamPosAbs _) = fromMaybe u $ M.lookup u implicitMap-    replace u                     = u--{-| Check and infer units-of-measure for a program-    This produces an output of all the unit information for a program -}-inferUnits uOpts pf-  | Right []   <- eVars = checkUnits uOpts pf-  | Right vars <- eVars = okReport vars-  | Left exc   <- eVars = errReport exc-  where-    fname = F.pfGetFilename pf-    -- Format report-    okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] ++ show vars-      where-        expInfo = [ (ei, u) | ei@(ExpInfo _ vname sname) <- declVariableNames pfUA-                            , u <- maybeToList ((vname, sname) `lookup` vars) ]--    expReport (ExpInfo ss vname sname, u) = "  " ++ showSrcSpan ss ++ " unit " ++ show u ++ " :: " ++ sname--    errReport exc = logs ++ "\n" ++ fname ++ ":  " ++ show exc--    (eVars, state, logs) = runInference uOpts pfRenamed (chooseImplicitNames <$> runInferVariables)--    pfUA = usProgramFile state -- the program file after units analysis is done--    -- Use the module map derived from all of the included Camfort Mod files.-    mmap = combinedModuleMap (M.elems (uoModFiles uOpts))-    pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf--combinedCompiledUnits :: ModFiles -> CompiledUnits-combinedCompiledUnits mfs = CompiledUnits { cuTemplateMap = M.unions tmaps-                                          , cuNameParamMap = M.unions nmaps }-  where-    cus = map mfCompiledUnits mfs-    tmaps = map cuTemplateMap cus-    nmaps = map cuNameParamMap cus---- | Name of the labeled data within a ModFile containing unit-specific info.-unitsCompiledDataLabel = "units-compiled-data"--mfCompiledUnits :: ModFile -> CompiledUnits-mfCompiledUnits mf = case lookupModFileData unitsCompiledDataLabel mf of-  Nothing -> emptyCompiledUnits-  Just bs -> case decodeOrFail (LB.fromStrict bs) of-    Left _ -> emptyCompiledUnits-    Right (_, _, cu) -> cu--genUnitsModFile :: F.ProgramFile UA -> CompiledUnits -> ModFile-genUnitsModFile pf cu = alterModFileData f unitsCompiledDataLabel $ genModFile pf-  where-    f _ = Just . LB.toStrict $ encode cu--compileUnits :: UnitOpts -> [FileProgram] -> (String, [(Filename, B.ByteString)])-compileUnits uOpts fileprogs = (concat reports, concat bins)-  where-    (reports, bins) = unzip [ (report, bin) | fileprog <- fileprogs-                                            , let (report, bin) = compileUnits' uOpts fileprog ]--compileUnits' :: UnitOpts -> FileProgram -> (String, [(Filename, B.ByteString)])-compileUnits' uOpts pf-  | Right cu <- eCUnits = okReport cu-  | Left exc <- eCUnits = errReport exc-  where-    fname = F.pfGetFilename pf-    -- Format report-    okReport cu = ( logs ++ "\n" ++ fname ++ ":\n" ++ if uoDebug uOpts then debugInfo else []-                     -- FIXME, filename manipulation (needs to go in -I dir?)-                    , [(fname ++ modFileSuffix, encodeModFile (genUnitsModFile pfTyped cu))] )-      where-        debugInfo = unlines [ n ++ ":\n  " ++ intercalate "\n  " (map show cs) | (n, cs) <- M.toList (cuTemplateMap cu) ] ++-                    unlines ("nameParams:" : (map show . M.toList $ cuNameParamMap cu))---    errReport exc = ( logs ++ "\n" ++ fname ++ ":  " ++ show exc-                    , [] )-    (eCUnits, state, logs) = runInference uOpts pfTyped runCompileUnits-    pfUA = usProgramFile state -- the program file after units analysis is done--    -- Use the module map derived from all of the included Camfort Mod files.-    mmap = combinedModuleMap (M.elems (uoModFiles uOpts))-    tenv = combinedTypeEnv (M.elems (uoModFiles uOpts))-    pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf-    pfTyped = fst . FAT.analyseTypesWithEnv tenv $ pfRenamed+import           Camfort.Analysis.Annotations+import           Camfort.Specification.Units.Analysis+  (UnitAnalysis, runInference)+import           Camfort.Specification.Units.Analysis.Consistent+  (ConsistencyError)+import           Camfort.Specification.Units.Analysis.Infer+  (InferenceReport, InferenceResult(..), getInferred, inferUnits)+import qualified Camfort.Specification.Units.Annotation as UA+import           Camfort.Specification.Units.InferenceBackend (chooseImplicitNames)+import           Camfort.Specification.Units.Monad+import           Camfort.Specification.Units.MonadTypes (UnitEnv(..))+import           Camfort.Specification.Units.Synthesis (runSynthesis) -synthesiseUnits :: UnitOpts-                -> Char-                -> F.ProgramFile Annotation-                -> (Report, F.ProgramFile Annotation) {-| Synthesis unspecified units for a program (after checking) -}-synthesiseUnits uOpts marker pf-  | Right []   <- eVars = (checkUnits uOpts pf, pf)-  | Right vars <- eVars = (okReport vars, pfFinal)-  | Left exc   <- eVars = (errReport exc, pfFinal)-  where-    fname = F.pfGetFilename pf-    -- Format report-    okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ]-      where-        expInfo = [ (ei, u) | ei@(ExpInfo _ vname sname) <- declVariableNames pfUA-                            , u <- maybeToList ((vname, sname) `lookup` vars) ]--    expReport (ExpInfo ss vname sname, u) = "  " ++ showSrcSpan ss ++ " unit " ++ show u ++ " :: " ++ sname--    errReport exc = logs ++ "\n" ++ fname ++ ":  " ++ show exc--    (eVars, state, logs) = runInference uOpts pfRenamed (runInferVariables >>= (runSynthesis marker . chooseImplicitNames))--    pfUA = usProgramFile state -- the program file after units analysis is done-    pfFinal = fmap prevAnnotation . fmap FA.prevAnnotation $ pfUA -- strip annotations--    -- Use the module map derived from all of the included Camfort Mod files.-    mmap = combinedModuleMap (M.elems (uoModFiles uOpts))-    pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf-------------------------------------------------------- clear out the unique names in the UnitInfos.-unrename :: Data a => a -> a-unrename = transformBi $ \ x -> case x of-  UnitVar (u, s)                      -> UnitVar (s, s)-  UnitParamVarAbs ((_, f), (_, s))    -> UnitParamVarAbs ((f, f), (s, s))-  UnitParamVarUse ((_, f), (_, s), i) -> UnitParamVarUse ((f, f), (s, s), i)-  UnitParamEAPAbs (_, s)              -> UnitParamEAPAbs (s, s)-  UnitParamEAPUse ((_, s), i)         -> UnitParamEAPUse ((s, s), i)-  u                                   -> u---showSrcSpan :: FU.SrcSpan -> String-showSrcSpan (FU.SrcSpan l u) = show l--data ExpInfo = ExpInfo { expInfoSrcSpan :: FU.SrcSpan, expInfoVName :: F.Name, expInfoSName :: F.Name }-  deriving (Show, Eq, Ord, Typeable, Data, Generic)---- | List of declared variables (including both decl statements & function returns, defaulting to first)-declVariableNames :: F.ProgramFile UA -> [ExpInfo]-declVariableNames pf = sort . M.elems $ M.unionWith (curry fst) declInfo puInfo-  where-    declInfo = M.fromList [ (expInfoVName ei, ei) | ei <- declVariableNamesDecl pf ]-    puInfo   = M.fromList [ (expInfoVName ei, ei) | ei <- declVariableNamesPU pf ]--declVariableNamesDecl :: F.ProgramFile UA -> [ExpInfo]-declVariableNamesDecl pf = flip mapMaybe (universeBi pf :: [F.Declarator UA]) $ \ d -> case d of-  F.DeclVariable _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _   -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))-  F.DeclArray    _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))-  _                                                             -> Nothing-declVariableNamesPU :: F.ProgramFile UA -> [ExpInfo]-declVariableNamesPU pf = flip mapMaybe (universeBi pf :: [F.ProgramUnit UA]) $ \ pu -> case pu of-  F.PUFunction _ ss _ _ _ _ (Just v@(F.ExpValue _ _ (F.ValVariable _))) _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))-  F.PUFunction _ ss _ _ _ _ Nothing _ _                                     -> Just (ExpInfo ss (puName pu) (puSrcName pu))-  _                                                                         -> Nothing+synthesiseUnits+  :: Char -> UnitAnalysis (Either ConsistencyError (InferenceReport, F.ProgramFile Annotation))+synthesiseUnits marker = do+  infRes <- inferUnits+  pfOriginal <- asks unitProgramFile+  case infRes of+    InfInconsistent err       -> pure $ Left err+    Inferred report -> do+      (_, state) <- runInference+        (runSynthesis marker . chooseImplicitNames . getInferred $ report)+      let pfUA    = usProgramFile state -- the program file after units analysis is done+          pfFinal = fmap (UA.prevAnnotation . FA.prevAnnotation) pfUA -- strip annotations+      pure . Right $ (report, pfFinal)
+ src/Camfort/Specification/Units/Analysis.hs view
@@ -0,0 +1,965 @@+{- |+Module      :  Camfort.Specification.Units.Analysis+Description :  Helpers for units refactoring and analysis.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++{-# LANGUAGE OverloadedStrings #-}++module Camfort.Specification.Units.Analysis+  ( UnitAnalysis+  , compileUnits+  , initInference+  , runInference+  , runUnitAnalysis+    -- ** Helpers+  , puName+  , puSrcName+  ) where++import           Control.Monad+import           Control.Monad.State.Strict+import           Control.Monad.Writer.Strict+import           Control.Monad.Reader+import           Data.Data (Data)+import qualified Data.IntMap.Strict as IM+import           Data.Generics.Uniplate.Operations+import           Data.List (nub, intercalate)+import qualified Data.Array as A+import qualified Data.Map.Strict as M+import           Data.Maybe (isJust, fromMaybe)+import qualified Data.Set as S+import qualified Numeric.LinearAlgebra as H -- for debugging+import           Data.Text (Text)+import           Control.Lens ((^?), _1)+import qualified Debug.Trace as D++import qualified Language.Fortran.AST      as F+import qualified Language.Fortran.Analysis as FA+import           Language.Fortran.Analysis (varName, srcName)+import           Language.Fortran.Parser.Utils (readReal, readInteger)+import           Language.Fortran.Util.ModFile+import           Language.Fortran.Util.Position (getSpan)++import           Camfort.Analysis+import           Camfort.Analysis.Logger (LogLevel(..))+import           Camfort.Analysis.Annotations (Annotation)+import           Camfort.Analysis.CommentAnnotator (annotateComments)+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           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 qualified Camfort.Specification.Units.InferenceBackendSBV as BackendSBV++-- | Prepare to run an inference function.+initInference :: UnitSolver ()+initInference = do+  pf <- getProgramFile++  -- Parse unit annotations found in comments and link to their+  -- corresponding statements in the AST.+  let (linkedPF, _) =+        runWriter $ annotateComments unitParser+        (\srcSpan err -> tell $ "Error " ++ show srcSpan ++ ": " ++ show err) pf+  modifyProgramFile $ const linkedPF++  -- The following insert* functions examine the AST and insert+  -- mappings into the tables stored in the UnitState.++  -- First, find all given unit annotations and insert them into our+  -- mappings.  Also obtain all unit alias definitions.+  insertGivenUnits++  -- For function or subroutine parameters (or return variables) that+  -- are not given explicit units, give them a parametric polymorphic+  -- unit.+  insertParametricUnits++  -- Any other variables get assigned a unique undetermined unit named+  -- after the variable. This assumes that all variables have unique+  -- names, which the renaming module already has assured.+  insertUndeterminedUnits++  -- Now take the information that we have gathered and annotate the+  -- variable expressions within the AST with it.+  annotateAllVariables++  -- Annotate the literals within the program based upon the+  -- Literals-mode option.+  annotateLiterals++  -- With the variable expressions annotated, we now propagate the+  -- information throughout the AST, giving units to as many+  -- expressions as possible, and also constraints wherever+  -- appropriate.+  propagateUnits++  -- Gather up all of the constraints that we identified in the AST.+  -- These constraints will include parametric polymorphic units that+  -- have not yet been instantiated into their particular uses.+  abstractCons <- extractConstraints+  dumpConsM "***abstractCons" abstractCons++  -- Eliminate all parametric polymorphic units by copying them for+  -- each specific use cases and substituting a unique call-site+  -- identifier that distinguishes each use-case from the others.+  cons <- applyTemplates abstractCons+  dumpConsM "***concreteCons" cons++  -- Remove any traces of CommentAnnotator, since the annotations can+  -- cause generic operations traversing the AST to get confused.+  modifyProgramFile UA.cleanLinks++  modifyConstraints (const cons)++  debugLogging++-- | Run a 'UnitSolver' analysis within a 'UnitsAnalysis'.+runInference :: UnitSolver a -> UnitAnalysis (a, UnitState)+runInference solver = do+  uOpts <- asks unitOpts+  pf <- asks unitProgramFile+  mfs <- lift analysisModFiles++  let (pf', _, _) = withCombinedEnvironment mfs . fmap UA.mkUnitAnnotation $ pf++  runUnitSolver pf' $ do+    initializeModFiles+    initInference+    solver++--------------------------------------------------++-- | Seek out any parameters to functions or subroutines that do not+-- already have units, and insert parametric units for them into the+-- map of variables to UnitInfo.+insertParametricUnits :: UnitSolver ()+insertParametricUnits = getProgramFile >>= (mapM_ paramPU . universeBi)+  where+    paramPU pu =+      forM_ (indexedParams pu) $ \ (i, param) ->+        -- Insert a parametric unit if the variable does not already have a unit.+        modifyVarUnitMap $ M.insertWith (curry snd) param (UnitParamPosAbs (fname, i))+      where+        fname = (puName pu, puSrcName pu)++-- | Return the list of parameters paired with its positional index.+indexedParams :: F.ProgramUnit UA -> [(Int, VV)]+indexedParams pu+  | F.PUFunction _ _ _ _ _ Nothing (Just r) _ _       <- pu = [(0, toVV r)]+  | F.PUFunction _ _ _ _ _ Nothing _ _ _              <- pu = [(0, (fname, sfname))]+  | F.PUFunction _ _ _ _ _ (Just paList) (Just r) _ _ <- pu = zip [0..] $ map toVV (r : F.aStrip paList)+  | F.PUFunction _ _ _ _ _ (Just paList) _ _ _        <- pu = zip [0..] $ (fname, sfname) : map toVV (F.aStrip paList)+  | F.PUSubroutine _ _ _ _ (Just paList) _ _          <- pu = zip [1..] $ map toVV (F.aStrip paList)+  | otherwise                                               = []+  where+    fname  = puName pu+    sfname = puSrcName pu+    toVV e = (varName e, srcName e)++--------------------------------------------------++-- | Any remaining variables with unknown units are given unit UnitVar+-- with a unique name (in this case, taken from the unique name of the+-- variable as provided by the Renamer), or UnitParamVarAbs if the+-- variables are inside of a function or subroutine.+insertUndeterminedUnits :: UnitSolver ()+insertUndeterminedUnits = do+  pf   <- getProgramFile+  dmap <- lift . lift $ M.union (extractDeclMap pf) . combinedDeclMap <$> analysisModFiles+  forM_ (universeBi pf :: [F.ProgramUnit UA]) $ \ pu ->+    modifyPUBlocksM (transformBiM (insertUndeterminedUnitVar dmap)) pu++-- Specifically handle variables+insertUndeterminedUnitVar :: DeclMap -> F.Expression UA -> UnitSolver (F.Expression UA)+insertUndeterminedUnitVar dmap v@(F.ExpValue _ _ (F.ValVariable _)) = do+  let vname = varName v+  let sname = srcName v+  let unit  = toUnitVar dmap (vname, sname)+  modifyVarUnitMap $ M.insertWith (curry snd) (varName v, srcName v) unit+  pure v+insertUndeterminedUnitVar _ e = pure e++-- Choose UnitVar or UnitParamVarAbs depending upon how the variable was declared.+toUnitVar :: DeclMap -> VV -> UnitInfo+toUnitVar dmap (vname, sname) = unit+  where+    unit = case fst <$> M.lookup vname dmap of+      Just (DCFunction (F.Named fvname, F.Named fsname))   -> UnitParamVarAbs ((fvname, fsname), (vname, sname))+      Just (DCSubroutine (F.Named fvname, F.Named fsname)) -> UnitParamVarAbs ((fvname, fsname), (vname, sname))+      _                                                    -> UnitVar (vname, sname)++--------------------------------------------------++-- | Convert explicit polymorphic annotations such as (UnitName "'a")+-- into UnitParamEAPAbs with a 'context-unique-name' given by the+-- ProgramUnitName combined with the supplied unit name.+transformExplicitPolymorphism :: Maybe F.ProgramUnitName -> UnitInfo -> UnitInfo+transformExplicitPolymorphism (Just (F.Named f)) (UnitName a@('\'':_)) = UnitParamEAPAbs (a, f ++ "_" ++ a)+transformExplicitPolymorphism _ u                                      = u++-- | Any units provided by the programmer through comment annotations+-- will be incorporated into the VarUnitMap.+insertGivenUnits :: UnitSolver ()+insertGivenUnits = do+  pf <- getProgramFile+  mapM_ checkPU (universeBi pf)+  where+    -- Look through each Program Unit for the comments+    checkPU :: F.ProgramUnit UA -> UnitSolver ()+    checkPU (F.PUComment a _ _)+      -- Look at unit assignment between function return variable and spec.+      | Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec+      , Just pu                                      <- mPU = insertPUUnitAssigns (toUnitInfo unitsAST) pu vars+      -- Add a new unit alias.+      | Just (P.UnitAlias name unitsAST) <- mSpec = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST))+      | otherwise                                 = pure ()+      where+        mSpec = UA.unitSpec (FA.prevAnnotation a)+        mPU   = UA.unitPU   (FA.prevAnnotation a)+    -- Other type of ProgramUnit (e.g. one with a body of blocks)+    checkPU pu = mapM_ (checkBlockComment getName) [ b | b@F.BlComment{} <- universeBi (F.programUnitBody pu) ]+      where+        getName = case pu of+          F.PUFunction {}   -> Just $ F.getName pu+          F.PUSubroutine {} -> Just $ F.getName pu+          _                 -> Nothing++    -- Look through each comment that has some kind of unit annotation within it.+    checkBlockComment :: Maybe F.ProgramUnitName -> F.Block UA -> UnitSolver ()+    checkBlockComment pname (F.BlComment a _ _)+      -- Look at unit assignment between variable and spec.+      | Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec+      , Just b                                       <- mBlock = insertBlockUnitAssigns pname (toUnitInfo unitsAST) b vars+      -- Add a new unit alias.+      | Just (P.UnitAlias name unitsAST) <- mSpec  = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST))+      | otherwise                                  = pure ()+      where+        mSpec  = UA.unitSpec  (FA.prevAnnotation a)+        mBlock = UA.unitBlock (FA.prevAnnotation a)+    checkBlockComment _ _ = error "received non-comment in checkBlockComment"++    -- Figure out the unique names of the referenced variables and+    -- then insert unit info under each of those names.+    insertBlockUnitAssigns :: Maybe F.ProgramUnitName -> UnitInfo -> F.Block UA -> [String] -> UnitSolver ()+    insertBlockUnitAssigns pname info (F.BlStatement _ _ _ (F.StDeclaration _ _ _ _ decls)) varRealNames = do+      -- figure out the 'unique name' of the varRealName that was found in the comment+      -- FIXME: account for module renaming+      -- FIXME: might be more efficient to allow access to variable renaming environ at this program point+      let info' = transform (transformExplicitPolymorphism pname) info+      let m = M.fromList [ ((varName e, srcName e), info')+                         | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi decls :: [F.Expression UA]+                         , varRealName <- varRealNames+                         , varRealName == srcName e ]+      modifyVarUnitMap $ M.unionWith const m+      modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m+    insertBlockUnitAssigns _ _ _ _ = error "received non-statement/declaration in insertBlockUnitAssigns"++    -- Insert unit annotation for function return variable+    insertPUUnitAssigns :: UnitInfo -> F.ProgramUnit UA -> [String] -> UnitSolver ()+    insertPUUnitAssigns info pu@(F.PUFunction _ _ _ _ _ _ mret _ _) varRealNames+      | (retUniq, retSrc) <- case mret of Just ret -> (FA.varName ret, FA.srcName ret)+                                          Nothing  -> (puName pu, puSrcName pu)+      , retSrc `elem` varRealNames = do+          let pname = Just $ F.getName pu+          let info' = transform (transformExplicitPolymorphism pname) info+          let m = M.fromList [ ((retUniq, retSrc), info') ]+          modifyVarUnitMap $ M.unionWith const m+          modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m+    insertPUUnitAssigns _ _ _ = error "received non-function in insertPUUnitAssigns"++--------------------------------------------------++-- | Take the unit information from the VarUnitMap and use it to+-- annotate every variable expression in the AST.+annotateAllVariables :: UnitSolver ()+annotateAllVariables = modifyProgramFileM $ \ pf -> do+  varUnitMap <- getVarUnitMap+  let annotateExp e@(F.ExpValue _ _ (F.ValVariable _))+        | Just info <- M.lookup (varName e, srcName e) varUnitMap = UA.setUnitInfo info e+      -- may need to annotate intrinsics separately+      annotateExp e = e+  pure $ transformBi annotateExp pf++--------------------------------------------------++-- | Give units to literals based upon the rules of the Literals mode.+--+-- LitUnitless: All literals are unitless.+-- LitPoly:     All literals are polymorphic.+-- LitMixed:    The literal "0" or "0.0" is fully parametric polymorphic.+--              All other literals are monomorphic, possibly unitless.+annotateLiterals :: UnitSolver ()+annotateLiterals = modifyProgramFileM (transformBiM annotateLiteralsPU)++annotateLiteralsPU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)+annotateLiteralsPU pu = do+  mode <- asks (uoLiterals . unitOpts)+  case mode of+    LitUnitless -> modifyPUBlocksM (transformBiM expUnitless) pu+    LitPoly     -> modifyPUBlocksM (transformBiM (withLiterals genParamLit)) pu+    LitMixed    -> modifyPUBlocksM (transformBiM expMixed) pu+  where+    -- Follow the LitMixed rules.+    expMixed e = case e of+      F.ExpValue _ _ (F.ValInteger i) | readInteger i == Just 0 -> withLiterals genParamLit e+                                      | isPolyCtxt              -> expUnitless e+                                      | otherwise               -> withLiterals genUnitLiteral e+      F.ExpValue _ _ (F.ValReal i) | readReal i == Just 0       -> withLiterals genParamLit e+                                   | isPolyCtxt                 -> expUnitless e+                                   | otherwise                  -> withLiterals genUnitLiteral e+      _                                                         -> pure e++    -- Set all literals to unitless.+    expUnitless e+      | isLiteral e = pure $ UA.setUnitInfo UnitlessLit e+      | otherwise   = pure e++    -- Set all literals to the result of given monadic computation.+    withLiterals m e+      | isLiteral e = flip UA.setUnitInfo e <$> m+      | otherwise   = pure e++    isPolyCtxt = case pu of F.PUFunction {} -> True; F.PUSubroutine {} -> True; _ -> False++-- | Is it a literal, literally?+isLiteral :: F.Expression UA -> Bool+isLiteral (F.ExpValue _ _ (F.ValReal _))    = True+isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True+isLiteral _                                 = False++-- | Is expression a literal and is it zero?+isLiteralNonZero :: F.Expression UA -> Bool+isLiteralNonZero (F.ExpValue _ _ (F.ValInteger i)) = readInteger i /= Just 0+isLiteralNonZero (F.ExpValue _ _ (F.ValReal i))    = readReal i    /= Just 0+isLiteralNonZero _                                 = False++isLiteralZero = not . isLiteralNonZero++--------------------------------------------------++-- | Convert all parametric templates into actual uses, via substitution.+applyTemplates :: Constraints -> UnitSolver Constraints+-- postcondition: returned constraints lack all Parametric constructors+applyTemplates cons = do+  dumpConsM "applyTemplates" cons+  -- Get a list of the instances of parametric polymorphism from the constraints.+  let instances = nub [ (name, i) | UnitParamPosUse ((name, _), _, i) <- universeBi cons ]++  -- Also generate a list of 'dummy' instances to ensure that every+  -- 'toplevel' function and subroutine is thoroughly expanded and+  -- analysed, even if it is not used in the current ProgramFile. (It+  -- might be part of a library module, for instance).+  pf <- getProgramFile+  dummies <- forM (topLevelFuncsAndSubs pf) $ \ pu -> do+    ident <- freshId+    pure (puName pu, ident)++  logDebug' pf $ ("instances: " <> describeShow instances)+  logDebug' pf $ ("dummies: " <> describeShow dummies)++  -- Work through the instances, expanding their templates, and+  -- substituting the callId into the abstract parameters.+  concreteCons <- liftM2 (++) (foldM (substInstance False []) [] instances)+                              (foldM (substInstance True []) [] dummies)+  dumpConsM "applyTemplates: concreteCons" concreteCons++  -- Also include aliases in the final set of constraints, where+  -- aliases are implemented by simply asserting that they are equal+  -- to their definition.+  aliasMap <- getUnitAliasMap+  let aliases = [ ConEq (UnitAlias name) def | (name, def) <- M.toList aliasMap ]+  let transAlias (UnitName a) | a `M.member` aliasMap = UnitAlias a+      transAlias u                                    = u++  dumpConsM "aliases" aliases+  pure . transformBi transAlias $ cons ++ concreteCons ++ aliases++-- | Look up the Parametric templates for a given function or+-- subroutine, and do the substitutions. Process any additional+-- polymorphic calls that are uncovered, unless they are recursive+-- calls that have already been seen in the current call stack.+substInstance :: Bool -> [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints+substInstance isDummy callStack output (name, callId) = do+  tmap <- getTemplateMap++  -- Look up the templates associated with the given function or+  -- subroutine name. And then transform the templates by generating+  -- new callIds for any constraints created by function or subroutine+  -- calls contained within the templates.+  --+  -- The reason for this is because functions called by functions can+  -- be used in a parametric polymorphic way.++  -- npc <- nameParamConstraints name -- In case it is an imported function, use this.+  let npc = [] -- disabled for now+  template <- transformBiM callIdRemap $ npc `fromMaybe` M.lookup name tmap+  dumpConsM ("substInstance " ++ show isDummy ++ " " ++ show callStack ++ " " ++ show (name, callId) ++ " template lookup") template++  -- Reset the usCallIdRemap field so that it is ready for the next+  -- set of templates.+  modifyCallIdRemap (const IM.empty)++  -- If any new instances are discovered, also process them, unless recursive.+  let instances = nub [ (name', i) | UnitParamPosUse ((name', _), _, i) <- universeBi template ]+  template' <- if name `elem` callStack then+                 -- Detected recursion: we do not support polymorphic-unit recursion,+                 -- ergo all subsequent recursive calls are assumed to have the same+                 -- unit-assignments as the first call.+                 pure []+               else+                 foldM (substInstance False (name:callStack)) [] instances++  dumpConsM ("instantiating " ++ show (name, callId) ++ ": (output ++ template) is") (output ++ template)+  dumpConsM ("instantiating " ++ show (name, callId) ++ ": (template') is") template'++  -- Get constraints for any imported variables+  let filterForVars (NPKVariable _) _ = True; filterForVars _ _ = False+  nmap <- M.filterWithKey filterForVars <$> getNameParamMap+  let importedVariables = [ ConEq (UnitVar vv) (foldUnits units) | (NPKVariable vv, units) <- M.toList nmap ]++  -- Convert abstract parametric units into concrete ones.++  let output' = -- Do not instantiate explicitly annotated polymorphic+                -- variables from current context when looking at dummy (name, callId)+                (if isDummy then output ++ template+                            else instantiate callId (output ++ template)) ++++                -- Only instantiate explicitly annotated polymorphic+                -- variables from nested function/subroutine calls.+                instantiate callId template' ++++                -- any imported variables+                importedVariables++  dumpConsM ("final output for " ++ show (name, callId)) output'++  pure output'++-- -- | Generate constraints from a NameParamMap entry.+-- nameParamConstraints :: F.Name -> UnitSolver Constraints+-- nameParamConstraints fname = do+--   let filterForName (NPKParam (n, _) _) _ = n == fname+--       filterForName _ _                   = False+--   nlst <- (M.toList . M.filterWithKey filterForName) <$> getNameParamMap+--   pure [ ConEq (UnitParamPosAbs (n, pos)) (foldUnits units) | (NPKParam n pos, units) <- nlst ]++-- | If given a usage of a parametric unit, rewrite the callId field+-- to follow an existing mapping in the usCallIdRemap state field, or+-- generate a new callId and add it to the usCallIdRemap state field.+callIdRemap :: UnitInfo -> UnitSolver UnitInfo+callIdRemap info = modifyCallIdRemapM $ \ idMap -> case info of+    UnitParamPosUse (n, p, i)+      | Just i' <- IM.lookup i idMap -> pure (UnitParamPosUse (n, p, i'), idMap)+      | otherwise                    -> freshId >>= \ i' ->+                                          pure (UnitParamPosUse (n, p, i'), IM.insert i i' idMap)+    UnitParamVarUse (n, v, i)+      | Just i' <- IM.lookup i idMap -> pure (UnitParamVarUse (n, v, i'), idMap)+      | otherwise                    -> freshId >>= \ i' ->+                                          pure (UnitParamVarUse (n, v, i'), IM.insert i i' idMap)+    UnitParamLitUse (l, i)+      | Just i' <- IM.lookup i idMap -> pure (UnitParamLitUse (l, i'), idMap)+      | otherwise                    -> freshId >>= \ i' ->+                                          pure (UnitParamLitUse (l, i'), IM.insert i i' idMap)+    UnitParamEAPUse (v, i)+      | Just i' <- IM.lookup i idMap -> pure (UnitParamEAPUse (v, i'), idMap)+      | otherwise                    -> freshId >>= \ i' ->+                                          pure (UnitParamEAPUse (v, i'), IM.insert i i' idMap)++    _                                -> pure (info, idMap)+++-- | Convert a parametric template into a particular use.+instantiate :: Data a => Int -> a -> a+instantiate callId = transformBi $ \ info -> case info of+  UnitParamPosAbs (name, position) -> UnitParamPosUse (name, position, callId)+  UnitParamLitAbs litId            -> UnitParamLitUse (litId, callId)+  UnitParamVarAbs (fname, vname)   -> UnitParamVarUse (fname, vname, callId)+  UnitParamEAPAbs vname            -> UnitParamEAPUse (vname, callId)+  _                                -> info++-- | Return a list of ProgramUnits that might be considered 'toplevel'+-- in the ProgramFile, e.g., possible exports. These must be analysed+-- independently of whether they are actually used in the same file,+-- because other files might use them.+topLevelFuncsAndSubs :: F.ProgramFile a -> [F.ProgramUnit a]+topLevelFuncsAndSubs (F.ProgramFile _ pus) = topLevel =<< pus+  where+    topLevel (F.PUModule _ _ _ _ (Just contains)) = topLevel =<< contains+    topLevel (F.PUMain _ _ _ _ (Just contains))   = topLevel =<< contains+    topLevel f@F.PUFunction{}                  = pure f+    topLevel s@F.PUSubroutine{}                = pure s+    topLevel _                                    = []++--------------------------------------------------++-- | Gather all constraints from the main blocks of the AST, as well as from the varUnitMap+extractConstraints :: UnitSolver Constraints+extractConstraints = do+  pf         <- getProgramFile+  dmap       <- lift . lift $ M.union (extractDeclMap pf) . combinedDeclMap <$> analysisModFiles+  varUnitMap <- getVarUnitMap+  pure $ [ con | b <- mainBlocks pf, con@ConEq{} <- universeBi b ] +++           [ ConEq (toUnitVar dmap v) u | (v, u) <- M.toList varUnitMap ]++-- | A list of blocks considered to be part of the 'main' program.+mainBlocks :: F.ProgramFile UA -> [F.Block UA]+mainBlocks = concatMap getBlocks . universeBi+  where+    getBlocks (F.PUMain _ _ _ bs _)   = bs+    getBlocks (F.PUModule _ _ _ bs _) = bs+    getBlocks _                       = []++--------------------------------------------------++-- | Propagate* functions: decorate the AST with constraints, given+-- that variables have all been annotated.+propagateUnits :: UnitSolver ()+-- precondition: all variables have already been annotated+propagateUnits = modifyProgramFileM $ transformBiM propagatePU        <=<+                                      transformBiM propagateDoSpec    <=<+                                      transformBiM propagateStatement <=<+                                      transformBiM propagateExp++propagateExp :: F.Expression UA -> UnitSolver (F.Expression UA)+propagateExp e = case e of+  F.ExpValue{}                           -> pure e -- all values should already be annotated+  F.ExpBinary _ _ F.Multiplication e1 e2 -> setF2 UnitMul (UA.getUnitInfo e1) (UA.getUnitInfo e2)+  F.ExpBinary _ _ F.Division e1 e2       -> setF2 UnitMul (UA.getUnitInfo e1) (flip UnitPow (-1) <$> UA.getUnitInfo e2)+  F.ExpBinary _ _ F.Exponentiation e1 e2 -> setF2 UnitPow (UA.getUnitInfo e1) (constantExpression e2)+  F.ExpBinary _ _ o e1 e2 | isOp AddOp o -> setF2C ConEq  (UA.getUnitInfo e1) (UA.getUnitInfo e2)+                          | isOp RelOp o -> setF2C ConEq  (UA.getUnitInfo e1) (UA.getUnitInfo e2)+  F.ExpFunctionCall {}                   -> propagateFunctionCall e+  F.ExpSubscript _ _ e1 _                -> pure $ UA.maybeSetUnitInfo (UA.getUnitInfo e1) e+  F.ExpUnary _ _ _ e1                    -> pure $ UA.maybeSetUnitInfo (UA.getUnitInfo e1) e+  _                                      -> do+    logDebug' e $ "progagateExp: unhandled " <> describeShow e+    pure e+  where+    -- Shorter names for convenience functions.+    setF2 f u1 u2  = pure $ UA.maybeSetUnitInfoF2 f u1 u2 e+    -- Remember, not only set a constraint, but also give a unit!+    setF2C f u1 u2 = pure . UA.maybeSetUnitInfo u1 $ UA.maybeSetUnitConstraintF2 f u1 u2 e++propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA)+propagateFunctionCall (F.ExpFunctionCall a s f Nothing)                     = do+  (info, _) <- callHelper f []+  let cons = intrinsicHelper info f []+  pure . UA.setConstraint (ConConj cons) . UA.setUnitInfo info $ F.ExpFunctionCall a s f Nothing+propagateFunctionCall (F.ExpFunctionCall a s f (Just (F.AList a' s' args))) = do+  (info, args') <- callHelper f args+  let cons = intrinsicHelper info f args'+  pure . UA.setConstraint (ConConj cons) . UA.setUnitInfo info $ F.ExpFunctionCall a s f (Just (F.AList a' s' args'))+propagateFunctionCall _ = error "received non-function-call in propagateFunctionCall"++propagateDoSpec :: F.DoSpecification UA -> UnitSolver (F.DoSpecification UA)+propagateDoSpec ast@(F.DoSpecification _ _ (F.StExpressionAssign _ _ e1 _) e2 m_e3) = do+  -- express constraints between the iteration variable, the bounding+  -- expressions and the step expression, or treat the step expression+  -- as a literal 1 if not specified.+  pure . maybe ast (flip UA.setConstraint ast) $ ConConj <$> mconcat [+        -- units(e1) ~ units(e2)+        (:[]) <$> liftM2 ConEq (UA.getUnitInfo e1) (UA.getUnitInfo e2)++        -- units(e1) ~ units(e3) or if e3 not specified then units(e1) ~ 1 in a polymorphic context+        , do u1 <- UA.getUnitInfo e1+             u3 <- (UA.getUnitInfo =<< m_e3) `mplus` if isMonomorphic u1 then mzero else pure UnitlessVar+             pure [ConEq u1 u3]+        ]++propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA)+propagateStatement stmt = case stmt of+  F.StExpressionAssign _ _ e1 e2               -> literalAssignmentSpecialCase e1 e2 stmt+  F.StCall a s sub (Just (F.AList a' s' args)) -> do+    (info, args') <- callHelper sub args+    let cons = intrinsicHelper info sub args'+    pure . UA.setConstraint (ConConj cons) $ F.StCall a s sub (Just (F.AList a' s' args'))+  F.StDeclaration {}                           -> transformBiM propagateDeclarator stmt+  _                                            -> pure stmt++propagateDeclarator :: F.Declarator UA -> UnitSolver (F.Declarator UA)+propagateDeclarator decl = case decl of+  F.DeclVariable _ _ e1 _ (Just e2) -> literalAssignmentSpecialCase e1 e2 decl+  F.DeclArray _ _ e1 _ _ (Just e2)  -> literalAssignmentSpecialCase e1 e2 decl+  _                                 -> pure decl++-- Allow literal assignment to overload the non-polymorphic+-- unit-assignment of the non-zero literal.+literalAssignmentSpecialCase :: (F.Annotated f)+                             => F.Expression UA -> F.Expression UA+                             -> f UA -> UnitSolver (f UA)+literalAssignmentSpecialCase e1 e2 ast+  | isLiteral e2+  , Just u1 <- UA.getUnitInfo e1+  , Just u2 <- UA.getUnitInfo e2+  , isMonomorphic u1 || isLiteralZero e2 = pure ast+  -- otherwise express the constraint between LHS and RHS of assignment.+  | otherwise = pure $ UA.maybeSetUnitConstraintF2 ConEq (UA.getUnitInfo e1) (UA.getUnitInfo e2) ast++propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)+propagatePU pu = do+  let name     = puName pu+  let sname    = puSrcName pu+  let nn       = (name, sname)+  let bodyCons = [ con | con@ConEq{} <- universeBi pu ] -- Constraints within the PU.++  varMap <- getVarUnitMap++  -- If any of the function/subroutine parameters was given an+  -- explicit unit annotation, then create a constraint between that+  -- explicit unit and the UnitParamPosAbs corresponding to the+  -- parameter. This way all other uses of the parameter get linked to+  -- the explicit unit annotation as well.+  givenCons <- forM (indexedParams pu) $ \ (i, param) ->+    case M.lookup param varMap of+      Just UnitParamPosAbs{}    -> pure . ConEq (UnitParamVarAbs (nn, param)) $ UnitParamPosAbs (nn, i)+      Just u                    -> pure . ConEq u $ UnitParamPosAbs (nn, i)+      _                         -> pure . ConEq (UnitParamVarAbs (nn, param)) $ UnitParamPosAbs (nn, i)++  let cons = givenCons ++ bodyCons+  case pu of F.PUFunction {}   -> modifyTemplateMap (M.insert name cons)+             F.PUSubroutine {} -> modifyTemplateMap (M.insert name cons)+             _                 -> pure ()++  -- Set the unitInfo field of a function program unit to be the same+  -- as the unitInfo of its result.+  let pu' = case (pu, indexedParams pu) of+              (F.PUFunction {}, (0, res):_) -> UA.setUnitInfo (UnitParamPosAbs (nn, 0) `fromMaybe` M.lookup res varMap) pu+              _                             -> pu++  pure (UA.setConstraint (ConConj cons) pu')++--------------------------------------------------++-- | Coalesce various function and subroutine call common code.+callHelper :: F.Expression UA -> [F.Argument UA] -> UnitSolver (UnitInfo, [F.Argument UA])+callHelper nexp args = do+  let name = (varName nexp, srcName nexp)+  let ctyp = FA.idCType =<< FA.idType (F.getAnnotation nexp)+  callId <- case ctyp of+    Just FA.CTExternal -> pure 0  -- if external with no further info then no polymorphism+    _                  -> freshId -- every call-site gets its own unique identifier+  let eachArg i arg@(F.Argument _ _ _ e)+        -- add site-specific parametric constraints to each argument+        | Just u <- UA.getUnitInfo e = UA.setConstraint (ConEq u (UnitParamPosUse (name, i, callId))) arg+        | otherwise               = arg+  let args' = zipWith eachArg [1..] args+  -- build a site-specific parametric unit for use on a return variable, if any+  let info = UnitParamPosUse (name, 0, callId)+  pure (info, args')++-- FIXME: use this function to create a list of constraints on intrinsic call-sites...+intrinsicHelper :: Foldable t => UnitInfo -> F.Expression (FA.Analysis a) -> t b -> [Constraint]+intrinsicHelper (UnitParamPosUse (_, _, callId)) f@(F.ExpValue _ _ (F.ValIntrinsic _)) args+  | Just (retU, argUs) <- intrinsicLookup sname = zipWith eachArg [0..numArgs] (retU:argUs)+  where+    numArgs     = length args+    sname       = srcName f+    vname       = varName f+    eachArg i u = ConEq (UnitParamPosUse ((vname, sname), i, callId)) (instantiate callId u)+intrinsicHelper _ _ _ = []++-- | Get info about intrinsics by source name 'sname', taking into+-- account the special case of those with arbitrary number of+-- arguments.+intrinsicLookup :: F.Name -> Maybe (UnitInfo, [UnitInfo])+intrinsicLookup sname = do+  (retU, argUs) <- M.lookup sname intrinsicUnits+  return (retU, if sname `S.member` specialCaseArbitraryArgs then cycle argUs else argUs)++-- | Generate a unique identifier for a literal encountered in the code.+genUnitLiteral :: UnitSolver UnitInfo+genUnitLiteral = UnitLiteral <$> freshId++-- | Generate a unique identifier for a polymorphic literal encountered in the code.+genParamLit :: UnitSolver UnitInfo+genParamLit = UnitParamLitAbs <$> freshId++-- Operate only on the blocks of a program unit, not the contained sub-programunits.+modifyPUBlocksM :: Monad m => ([F.Block a] -> m [F.Block a]) -> F.ProgramUnit a -> m (F.ProgramUnit a)+modifyPUBlocksM f pu = case pu of+  F.PUMain a s n b pus                    -> flip fmap (f b) $ \ b' -> F.PUMain a s n b' pus+  F.PUModule a s n b pus                  -> flip fmap (f b) $ \ b' -> F.PUModule a s n b' pus+  F.PUSubroutine a s r n p b subs         -> flip fmap (f b) $ \ b' -> F.PUSubroutine a s r n p b' subs+  F.PUFunction   a s r rec n p res b subs -> flip fmap (f b) $ \ b' -> F.PUFunction a s r rec n p res b' subs+  F.PUBlockData  a s n b                  -> flip fmap (f b) $ \ b' -> F.PUBlockData  a s n b'+  F.PUComment {}                          -> pure pu -- no blocks++-- Fortran semantics for interpretation of constant expressions+-- involving numeric literals.+data FNum = FReal Double | FInt Integer++fnumToDouble :: FNum -> Double+fnumToDouble (FReal x) = x+fnumToDouble (FInt x)  = fromIntegral x++fAdd, fSub, fMul, fDiv, fPow :: FNum -> FNum -> FNum+fAdd (FReal x) fy      = FReal $ x + fnumToDouble fy+fAdd fx (FReal y)      = FReal $ fnumToDouble fx + y+fAdd (FInt x) (FInt y) = FInt  $ x + y+fSub (FReal x) fy      = FReal $ x - fnumToDouble fy+fSub fx (FReal y)      = FReal $ fnumToDouble fx - y+fSub (FInt x) (FInt y) = FInt  $ x - y+fMul (FReal x) fy      = FReal $ x * fnumToDouble fy+fMul fx (FReal y)      = FReal $ fnumToDouble fx * y+fMul (FInt x) (FInt y) = FInt  $ x * y+fDiv (FReal x) fy      = FReal $ x / fnumToDouble fy+fDiv fx (FReal y)      = FReal $ fnumToDouble fx / y+fDiv (FInt x) (FInt y) = FInt  $ x `quot` y  -- Haskell quot truncates towards zero, like Fortran+fPow (FReal x) fy      = FReal $ x ** fnumToDouble fy+fPow fx (FReal y)      = FReal $ fnumToDouble fx ** y+fPow (FInt x) (FInt y)+  | y >= 0             = FInt  $ x ^ y+  | otherwise          = FReal $ fromIntegral x ^^ y++fDivMaybe :: Maybe FNum -> Maybe FNum -> Maybe FNum+fDivMaybe mx my+  | Just y <- my,+    fnumToDouble y == 0.0 = Nothing+  | otherwise             = liftM2 fDiv mx my++-- | Statically computes if the expression is a constant value.+constantExpression :: F.Expression a -> Maybe Double+constantExpression expr = fnumToDouble <$> ce expr+  where+    ce e = case e of+      (F.ExpValue _ _ (F.ValInteger i))        -> FInt <$> readInteger i+      (F.ExpValue _ _ (F.ValReal r))           -> FReal <$> readReal r+      (F.ExpBinary _ _ F.Addition e1 e2)       -> liftM2 fAdd (ce e1) (ce e2)+      (F.ExpBinary _ _ F.Subtraction e1 e2)    -> liftM2 fSub (ce e1) (ce e2)+      (F.ExpBinary _ _ F.Multiplication e1 e2) -> liftM2 fMul (ce e1) (ce e2)+      (F.ExpBinary _ _ F.Division e1 e2)       -> fDivMaybe (ce e1) (ce e2)+      (F.ExpBinary _ _ F.Exponentiation e1 e2) -> liftM2 fPow (ce e1) (ce e2)+      -- FIXME: expand...+      _                                        -> Nothing++-- | Asks the question: is the operator within the given category?+isOp :: BinOpKind -> F.BinaryOp -> Bool+isOp cat = (== cat) . binOpKind++data BinOpKind = AddOp | MulOp | DivOp | PowerOp | LogicOp | RelOp deriving Eq+binOpKind :: F.BinaryOp -> BinOpKind+binOpKind F.Addition         = AddOp+binOpKind F.Subtraction      = AddOp+binOpKind F.Multiplication   = MulOp+binOpKind F.Division         = DivOp+binOpKind F.Exponentiation   = PowerOp+binOpKind F.Concatenation    = AddOp+binOpKind F.GT               = RelOp+binOpKind F.GTE              = RelOp+binOpKind F.LT               = RelOp+binOpKind F.LTE              = RelOp+binOpKind F.EQ               = RelOp+binOpKind F.NE               = RelOp+binOpKind F.Or               = LogicOp+binOpKind F.And              = LogicOp+binOpKind F.Equivalent       = RelOp+binOpKind F.NotEquivalent    = RelOp+binOpKind (F.BinCustom _)    = RelOp++--------------------------------------------------++logDebugNoOrigin :: Text -> UnitSolver ()+logDebugNoOrigin msg = do+  pf <- gets usProgramFile+  logDebug' pf msg++dumpConsM :: String -> Constraints -> UnitSolver ()+dumpConsM str = logDebugNoOrigin . describe . unlines . ([replicate 50 '-', str ++ ":"]++) . (++[replicate 50 '^']) . map f+  where+    f (ConEq u1 u2)  = show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)+    f (ConConj cons) = intercalate " && " (map f cons)++debugLogging :: UnitSolver ()+debugLogging = do+    (logDebugNoOrigin . describe . unlines . map (\ (ConEq u1 u2) -> "  ***AbsConstraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2))) =<< extractConstraints+    pf   <- getProgramFile+    cons <- getConstraints+    vum  <- getVarUnitMap+    logDebugNoOrigin . describe . unlines $ [ "  " ++ show info ++ " :: " ++ n | ((n, _), info) <- M.toList vum ]+    logDebugNoOrigin ""+    uam <- getUnitAliasMap+    logDebugNoOrigin . describe . unlines $ [ "  " ++ n ++ " = " ++ show info | (n, info) <- M.toList uam ]+    logDebugNoOrigin . describe . unlines $ map (\ (ConEq u1 u2) -> "  ***Constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons+    logDebugNoOrigin $ describeShow cons <> "\n"+    forM_ (universeBi pf) $ \ pu -> case pu of+      F.PUFunction {}+        | Just (ConConj con) <- UA.getConstraint pu ->+          logDebugNoOrigin . describe . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> "    constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) con+      F.PUSubroutine {}+        | Just (ConConj con) <- UA.getConstraint pu ->+          logDebugNoOrigin . describe . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> "    constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) con+      _ -> pure ()+    let (lhsM, rhsM, _, lhsColA, rhsColA) = constraintsToMatrices cons+    logDebugNoOrigin "--------------------------------------------------\nLHS Cols:"+    logDebugNoOrigin $ describeShow lhsColA+    logDebugNoOrigin "--------------------------------------------------\nRHS Cols:"+    logDebugNoOrigin $ describeShow rhsColA+    logDebugNoOrigin "--------------------------------------------------\nLHS M:"+    logDebugNoOrigin $ describeShow lhsM+    logDebugNoOrigin "--------------------------------------------------\nRHS M:"+    logDebugNoOrigin $ describeShow rhsM+    logDebugNoOrigin "--------------------------------------------------\nAUG M:"+    let augM = if H.rows rhsM == 0 || H.cols rhsM == 0 then lhsM else H.fromBlocks [[lhsM, rhsM]]+    logDebugNoOrigin $ describeShow augM+    logDebugNoOrigin "--------------------------------------------------\nSolved (hnf) M:"+    let hnfM = Flint.hnf augM+    logDebugNoOrigin $ describeShow hnfM+    logDebugNoOrigin "--------------------------------------------------\nSolved (normHNF) M:"+    let (solvedM, newColIndices) = Flint.normHNF augM+    logDebugNoOrigin . describeShow $ solvedM+    logDebugNoOrigin $ "newColIndices = " <> describeShow newColIndices+    logDebugNoOrigin "--------------------------------------------------\nLHS Cols with newColIndices:"+    let lhsCols = A.elems lhsColA ++ map (lhsColA A.!) newColIndices+    logDebugNoOrigin $ describe . unlines . map show $ zip [0..] lhsCols+    -- logDebugNoOrigin "--------------------------------------------------\nSolved (SVD) M:"+    -- logDebugNoOrigin $ show (H.linearSolveSVD lhsM rhsM)+    -- logDebugNoOrigin "--------------------------------------------------\nSingular Values:"+    -- logDebugNoOrigin $ show (H.singularValues lhsM)+    logDebugNoOrigin "--------------------------------------------------"+    logDebugNoOrigin $ "Rank LHS: " <> describeShow (H.rank lhsM)+    logDebugNoOrigin "--------------------------------------------------"+    let augA = if H.rows rhsM == 0 || H.cols rhsM == 0 then lhsM else H.fromBlocks [[lhsM, rhsM]]+    logDebugNoOrigin $ "Rank Augmented: " <> describeShow (H.rank augA)+    logDebugNoOrigin "--------------------------------------------------\nGenUnitAssignments:"+    let unitAssignments = genUnitAssignments cons+    logDebugNoOrigin . describe . unlines $ map (\ (u1s, u2) -> "  ***UnitAssignment: " ++ show u1s ++ " === " ++ show (flattenUnits u2) ++ "\n") unitAssignments+    logDebugNoOrigin "--------------------------------------------------"+    let unitAssignments = BackendSBV.genUnitAssignments cons+    logDebugNoOrigin . describe . unlines $ map (\ (u1s, u2) -> "  ***UnitAssignmentSBV: " ++ show u1s ++ " === " ++ show (flattenUnits u2)) unitAssignments+    logDebugNoOrigin "--------------------------------------------------"++--------------------------------------------------++-- convenience+puName :: F.ProgramUnit UA -> F.Name+puName pu+  | F.Named n <- FA.puName pu = n+  | otherwise                 = "_nameless"++puSrcName :: F.ProgramUnit UA -> F.Name+puSrcName pu+  | F.Named n <- FA.puSrcName pu = n+  | otherwise                    = "_nameless"++--------------------------------------------------++-- | Intrinics that take arbitrary number of arguments. Entry in table+-- 'intrinsicUnits' will contain a single item in the argument list,+-- corresponding to the template used for all arguments.+specialCaseArbitraryArgs :: S.Set F.Name+specialCaseArbitraryArgs = S.fromList [ "max", "max0", "amax1", "dmax1", "amax0", "max1"+                                      , "min", "min0", "amin1", "dmin1", "amin0", "min1" ]++-- | Intrinsics table: name => (return-unit, parameter-units). See also 'specialCaseArbitraryArgs'.+intrinsicUnits :: M.Map F.Name (UnitInfo, [UnitInfo])+intrinsicUnits =+  M.fromList+    [ ("transfer", (UnitParamEAPAbs ("'b", "'b"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+    , ("abs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("iabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("dabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("cabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("aimag", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("aint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("dint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("anint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("dnint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("cmplx", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("conjg", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("dble", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("dim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+    , ("idim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+    , ("ddim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+    , ("dprod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("ceiling", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("floor", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("int", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("ifix", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("idint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("maxval", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("minval", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("max", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))   -- special case: arbitrary # of parameters+    , ("min", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))   -- special case: arbitrary # of parameters+    , ("min0", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))  -- special case: arbitrary # of parameters+    , ("amin1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+    , ("dmin1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+    , ("amin0", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+    , ("min1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))  -- special case: arbitrary # of parameters+    , ("mod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+    , ("modulo", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+    , ("amod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+    , ("dmod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+    , ("nint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("real", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("float", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("sngl", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+    , ("sign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+    , ("isign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+    , ("dsign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+    , ("present", (UnitParamEAPAbs ("'a", "'a"), [UnitlessVar]))+    , ("sqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2]))+    , ("dsqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2]))+    , ("csqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2]))+    , ("exp", (UnitlessVar, [UnitlessVar]))+    , ("dexp", (UnitlessVar, [UnitlessVar]))+    , ("cexp", (UnitlessVar, [UnitlessVar]))+    , ("alog", (UnitlessVar, [UnitlessVar]))+    , ("dlog", (UnitlessVar, [UnitlessVar]))+    , ("clog", (UnitlessVar, [UnitlessVar]))+    , ("alog10", (UnitlessVar, [UnitlessVar]))+    , ("dlog10", (UnitlessVar, [UnitlessVar]))+    , ("sin", (UnitlessVar, [UnitlessVar]))+    , ("dsin", (UnitlessVar, [UnitlessVar]))+    , ("csin", (UnitlessVar, [UnitlessVar]))+    , ("cos", (UnitlessVar, [UnitlessVar]))+    , ("dcos", (UnitlessVar, [UnitlessVar]))+    , ("ccos", (UnitlessVar, [UnitlessVar]))+    , ("tan", (UnitlessVar, [UnitlessVar]))+    , ("dtan", (UnitlessVar, [UnitlessVar]))+    , ("asin", (UnitlessVar, [UnitlessVar]))+    , ("dasin", (UnitlessVar, [UnitlessVar]))+    , ("acos", (UnitlessVar, [UnitlessVar]))+    , ("dacos", (UnitlessVar, [UnitlessVar]))+    , ("atan", (UnitlessVar, [UnitlessVar]))+    , ("datan", (UnitlessVar, [UnitlessVar]))+    , ("atan2", (UnitlessVar, [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+    , ("datan2", (UnitlessVar, [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+    , ("sinh", (UnitlessVar, [UnitlessVar]))+    , ("dsinh", (UnitlessVar, [UnitlessVar]))+    , ("cosh", (UnitlessVar, [UnitlessVar]))+    , ("dcosh", (UnitlessVar, [UnitlessVar]))+    , ("tanh", (UnitlessVar, [UnitlessVar]))+    , ("dtanh", (UnitlessVar, [UnitlessVar]))+    , ("iand", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+    ]++-- Others: reshape, merge need special handling++-- | Compile a program to a 'ModFile' containing units information.+compileUnits :: UnitOpts -> ModFiles -> F.ProgramFile Annotation -> IO ModFile+compileUnits uo mfs pf = do+  let (pf', _, _) = withCombinedEnvironment mfs . fmap UA.mkUnitAnnotation $ pf++  let analysis = runReaderT (runInference runCompileUnits) $+        UnitEnv+        { unitOpts = uo+        , unitProgramFile = pf+        }++  report <- runAnalysisT (F.pfGetFilename pf) (logOutputNone True) LogError mfs analysis++  case report ^? arResult . _ARSuccess . _1 of+    Just cu -> return (genUnitsModFile pf' cu)+    Nothing -> fail "compileUnits: units analysis failed"
+ src/Camfort/Specification/Units/Analysis/Consistent.hs view
@@ -0,0 +1,210 @@+{- |+Module      :  Camfort.Specification.Units.Analysis.Consistent+Description :  Analysis to verify units are consistent.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++{-# LANGUAGE ExistentialQuantification #-}++module Camfort.Specification.Units.Analysis.Consistent+  ( ConsistencyError+  , ConsistencyReport(Consistent, Inconsistent)+  , checkUnits+  ) where++import           Control.Monad.State (get)+import           Control.Monad.Reader (asks)+import           Data.Data+import           Data.Generics.Uniplate.Operations+import           Data.List (partition, find, group, sort)+import qualified Data.Map.Strict as M+import           Data.Maybe (maybeToList, maybe)+import           Data.Function (on)++import           Camfort.Analysis (ExitCodeOfReport(..), Describe(..))+import           Camfort.Analysis.Annotations+import           Camfort.Specification.Units.Analysis (UnitAnalysis, runInference)+import qualified Camfort.Specification.Units.Annotation as UA+import           Camfort.Specification.Units.Environment+import           Camfort.Specification.Units.InferenceBackendSBV (inconsistentConstraints)+import qualified Camfort.Specification.Units.InferenceBackend as MatrixBackend+import           Camfort.Specification.Units.Monad+import           Camfort.Specification.Units.MonadTypes+import qualified Camfort.Specification.Units.BackendTypes as B++import qualified Language.Fortran.AST           as F+import qualified Language.Fortran.Util.Position as FU++-- | A report that summarises unit consistency.+data ConsistencyReport+    -- | All units were consistent.+  = forall a. Consistent (F.ProgramFile a) Int+    -- | An inconsistency was found in units of the program.+  | Inconsistent ConsistencyError++instance Show ConsistencyReport where+  show (Consistent pf nVars) = concat ["\n", fname, ": Consistent ", show nVars, " variables checked."]+    where fname = F.pfGetFilename pf+  show (Inconsistent e) = show e++instance ExitCodeOfReport ConsistencyReport where+  exitCodeOf (Consistent {}) = 0+  exitCodeOf (Inconsistent _) = 1++instance Describe ConsistencyReport++data ConsistencyError =+  Inconsistency (F.ProgramFile UA) Constraints++instance Show ConsistencyError where+  show (Inconsistency pf cons) = concat [ "\n", fname, ": Inconsistent:\n", reportErrors ]+    where+      fname = F.pfGetFilename pf+      reportErrors = unlines [ maybe "" showSS ss ++ str | (ss, str) <- reports ]+        where+          reports = map head . group . sort . map reportError . filter relevantConstraints $ cons+          showSS  = (++ ": ") . (" - at "++) . showSpanStart++          relevantConstraints c = not (isPolymorphic0 c) && not (isReflexive c)++          isPolymorphic0 (ConEq UnitParamLitAbs{} _) = True+          isPolymorphic0 (ConEq _ UnitParamLitAbs{}) = True+          isPolymorphic0 _                         = False++          isReflexive (ConEq u1 u2) = u1 == u2+          isReflexive _ = error "isReflexive without ConEq"++      reportError con = (errSpan, pprintConstr . orient . unrename . shift . simplify $ con)+        where+          errSpan = findCon con+          orient (ConEq u v) | 0 `elem` [unitPower u, unitPower v] = balanceConEq ((< 0) . unitPower) (ConEq u v)+          orient (ConEq u (UnitVar v)) = ConEq (UnitVar v) u+          orient (ConEq u (UnitParamVarUse v)) = ConEq (UnitParamVarUse v) u+          orient (ConEq u v)+            | all ((< 0) . unitPower) $ lhs ++ rhs = orient $ ConEq (foldUnits (negateCons lhs)) (foldUnits (negateCons rhs))+            where+              lhs = flattenUnits u+              rhs = flattenUnits v+          orient c = c++          partitionUnits f u = (foldUnits a, foldUnits b)+            where (a, b) = partition f (flattenUnits u)+          unitPower (UnitPow u k) = unitPower u * k+          unitPower UnitlessLit = 0+          unitPower UnitlessVar = 0+          unitPower _ = 1++          -- When reporting inconsistent constraints, shift all the+          -- UnitNames (e.g. m, kg) and Polymorphic Units (e.g. 'a,+          -- 'b) to the right-hand-side, and other things to the left.+          shift = shiftConEq isUnitRHS++          -- Units that should appear on the right-hand-side of the matrix during solving+          isUnitRHS (UnitPow (UnitName _) _)        = True+          isUnitRHS (UnitPow (UnitParamEAPAbs _) _) = True+          isUnitRHS _                               = False++          simplify = B.dimToConstraint . B.constraintToDim++      findCon :: Constraint -> Maybe FU.SrcSpan+      findCon con = lookupWith (eq con) constraints+        where -- constraintToDim normalises as it builds the Dim, so we can use dimParamEq directly.+              eq c1 c2 = or [ B.constraintToDim c1 `B.dimParamEq` B.constraintToDim c2' | c2' <- universeBi c2 ]+      constraints = [ (c, srcSpan)+                    | x <- universeBi pf :: [F.Expression UA]+                    , let srcSpan = FU.getSpan x+                    , c <- maybeToList (UA.getConstraint x)+                    ] ++++                    [ (c, srcSpan)+                    | x <- universeBi pf :: [F.Statement UA]+                    , let srcSpan = FU.getSpan x+                    , c <- maybeToList (UA.getConstraint x)+                    ] ++++                    [ (c, srcSpan)+                    | x <- universeBi pf :: [F.Argument UA]+                    , let srcSpan = FU.getSpan x+                    , c <- maybeToList (UA.getConstraint x)+                    ] ++++                    [ (c, srcSpan)+                    | x <- universeBi pf :: [F.Declarator UA]+                    , let srcSpan = FU.getSpan x+                    , c <- maybeToList (UA.getConstraint x)+                    ] ++++                    -- Why reverse? So that PUFunction and PUSubroutine appear+                    -- first in the list, before PUModule.+                    reverse [ (c, srcSpan)+                    | x <- universeBi pf :: [F.ProgramUnit UA]+                    , let srcSpan = FU.getSpan x+                    , c <- maybeToList (UA.getConstraint x)+                    ]++instance Describe ConsistencyError++{-| Check units-of-measure for a program -}+checkUnits :: UnitAnalysis ConsistencyReport+checkUnits = do+  pf <- asks unitProgramFile+  (eCons, state) <- runInference runInconsistentConstraints+    -- number of 'real' variables checked, e.g. not parametric+  let+    nVars = M.size . M.filter (not . isParametricUnit) $ usVarUnitMap state+    pfUA :: F.ProgramFile UA+    pfUA = usProgramFile state -- the program file after units analysis is done++  pure $ case eCons of+           Nothing     -> Consistent pf nVars+           (Just cons) -> Inconsistent $ Inconsistency pfUA cons+  where+    isParametricUnit u = case u of UnitParamPosAbs {} -> True; UnitParamPosUse {} -> True+                                   UnitParamVarAbs {} -> True; UnitParamVarUse {} -> True+                                   _ -> False++lookupWith :: (a -> Bool) -> [(a,b)] -> Maybe b+lookupWith f = fmap snd . find (f . fst)++-- | Return a possible list of unsolvable constraints.+runInconsistentConstraints :: UnitSolver (Maybe Constraints)+runInconsistentConstraints = do+  cons <- usConstraints `fmap` get+  pure $ inconsistentConstraints cons++-- clear out the unique names in the UnitInfos.+unrename :: Data a => a -> a+unrename = transformBi $ \ x -> case x of+  UnitVar (_, s)                      -> UnitVar (s, s)+  UnitParamVarAbs ((_, f), (_, s))    -> UnitParamVarAbs ((f, f), (s, s))+  UnitParamVarUse ((_, f), (_, s), i) -> UnitParamVarUse ((f, f), (s, s), i)+  UnitParamEAPAbs (_, s)              -> UnitParamEAPAbs (s, s)+  UnitParamEAPUse ((_, s), i)         -> UnitParamEAPUse ((s, s), i)+  u                                   -> u++-- | Show only the start position of the 'SrcSpan'.+showSpanStart :: FU.SrcSpan -> String+showSpanStart (FU.SrcSpan l _) = show l++-- | Shift terms to the right if predicate f is satisfied and to the left otherwise.+shiftConEq :: (UnitInfo -> Bool) -> Constraint -> Constraint+shiftConEq f (ConEq l r) = ConEq (foldUnits (lhsOk ++ negateCons rhsShift)) (foldUnits (rhsOk ++ negateCons lhsShift))+  where+    (lhsOk, lhsShift) = partition (not . f) (flattenUnits l)+    (rhsOk, rhsShift) = partition f (flattenUnits r)+shiftConEq f (ConConj cs) = ConConj $ map (shiftConEq f) cs++-- | Balance equations by shifting terms that satisfy predicate f+balanceConEq f (ConEq l r) = ConEq (foldUnits (lhsOk ++ negateCons rhsShift)) (foldUnits (rhsOk ++ negateCons lhsShift))+  where+    (lhsShift, lhsOk) = partition f (flattenUnits l)+    (rhsShift, rhsOk) = partition f (flattenUnits r)+balanceConEq f (ConConj cs) = ConConj $ map (balanceConEq f) cs++negateCons = map (\ x -> case x of+                     UnitPow u k -> UnitPow u (-k)+                     u -> UnitPow u (-1))
+ src/Camfort/Specification/Units/Analysis/Criticals.hs view
@@ -0,0 +1,119 @@+{- |+Module      :  Camfort.Specification.Units.Analysis.Criticals+Description :  Critical-units analysis.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental++This module defines an analysis for finding the 'critical' variables in a program.+These critical variables form a set of variables that, when given unit annotations,+can be used to infer the unit types of all other variables in the program.+-}++module Camfort.Specification.Units.Analysis.Criticals+  ( inferCriticalVariables+  ) where++import           Control.Monad.State (get)+import           Control.Monad.Reader (asks, lift)+import           Data.Generics.Uniplate.Operations+import qualified Data.Map.Strict       as M+import           Data.Maybe (fromMaybe)++import Camfort.Analysis+import Camfort.Analysis.Annotations+import Camfort.Analysis.ModFile (withCombinedModuleMap)+import Camfort.Specification.Units.InferenceBackendSBV (criticalVariables)++-- Provides the types and data accessors used in this module+import           Camfort.Specification.Units.Analysis (UnitAnalysis, runInference)+import qualified Camfort.Specification.Units.Annotation as UA+import           Camfort.Specification.Units.Environment+import           Camfort.Specification.Units.Monad+import           Camfort.Specification.Units.MonadTypes++import qualified Language.Fortran.AST               as F+import qualified Language.Fortran.Analysis          as FA+import qualified Language.Fortran.Analysis.Renaming as FAR+import           Language.Fortran.Util.ModFile+import qualified Language.Fortran.Util.Position     as FU++-- | An inference of variables that must be provided with+-- unit annotations before units for all variables can be+-- resolved.+data Criticals = Criticals+  {+    -- | 'ProgramFile' analysis was performed upon.+    criticalsPf           :: F.ProgramFile Annotation+    -- | The inferred critical variables.+  , criticalsVariables    :: [UnitInfo]+    -- | Map of all declarations.+  , criticalsDeclarations :: M.Map F.Name (DeclContext, FU.SrcSpan)+    -- | Map of unique names.+  , criticalsUniqMap      :: M.Map F.Name F.Name+    -- | Location of criticals.+  , criticalsFromWhere    :: M.Map F.Name FilePath+  }++instance ExitCodeOfReport Criticals where+  exitCodeOf _ = 0++instance Show Criticals where+  show crits =+    case vars of+      []   -> concat ["\n", fname, ": No additional annotations are necessary.\n"]+      _    -> concat ["\n", fname, ": ", show numVars+                     , " variable declarations suggested to be given a specification:\n"+                     , unlines [ "    " ++ declReport d | d <- M.toList dmapSlice ]]+      where+        fname        = F.pfGetFilename . criticalsPf $ crits+        dmap         = criticalsDeclarations           crits+        uniqnameMap  = criticalsUniqMap                crits+        fromWhereMap = criticalsFromWhere              crits+        vars         = criticalsVariables              crits+        unitVarName (UnitVar (v, _))                 = v+        unitVarName (UnitParamVarUse (_, (v, _), _)) = v+        unitVarName _                                = "<bad>"+        varNames  = map unitVarName vars+        dmapSlice = M.filterWithKey (\ k _ -> k `elem` varNames) dmap+        numVars   = M.size dmapSlice+        declReport (v, (_, ss)) = vfilename ++ " (" ++ showSpanStart ss ++ ")    " ++ fromMaybe v (M.lookup v uniqnameMap)+          where vfilename = fromMaybe fname $ M.lookup v fromWhereMap+                showSpanStart (FU.SrcSpan l _) = show l++instance Describe Criticals++-- | Return a list of critical variables as UnitInfo list (most likely+-- to be of the UnitVar constructor).+runCriticalVariables :: UnitSolver [UnitInfo]+runCriticalVariables = do+  cons <- usConstraints `fmap` get+  return $ criticalVariables cons++-- | Infer one possible set of critical variables for a program.+inferCriticalVariables :: UnitAnalysis Criticals+inferCriticalVariables = do+  pf <- asks unitProgramFile+  mfs <- lift analysisModFiles+  (eVars, _) <- runInference runCriticalVariables+  let+    -- Use the module map derived from all of the included Camfort Mod files.+    (pfRenamed, mmap) = withCombinedModuleMap mfs . FA.initAnalysis . fmap UA.mkUnitAnnotation $ pf+    -- unique name -> src name across modules++    -- Map of all declarations+    dmap = extractDeclMap pfRenamed `M.union` combinedDeclMap mfs+    uniqnameMap = M.fromList [+                (FA.varName e, FA.srcName e) |+                e@(F.ExpValue _ _ F.ValVariable{}) <- universeBi pfRenamed :: [F.Expression UA]+                -- going to ignore intrinsics here+              ] `M.union` (M.unions . map (M.fromList . map (\ (a, (b, _)) -> (b, a)) . M.toList) $ M.elems mmap)+    fromWhereMap = genUniqNameToFilenameMap mfs+  pure Criticals { criticalsPf           = pf+                 , criticalsVariables    = eVars+                 , criticalsDeclarations = dmap+                 , criticalsUniqMap      = uniqnameMap+                 , criticalsFromWhere    = fromWhereMap+                 }
+ src/Camfort/Specification/Units/Analysis/Infer.hs view
@@ -0,0 +1,121 @@+{- |+Module      :  Camfort.Specification.Units.Analysis.Infer+Description :  Analysis for inferring units.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}++module Camfort.Specification.Units.Analysis.Infer+  ( InferenceReport+  , InferenceResult(..)+  , getInferred+  , inferUnits+  ) where++import           Data.Data (Data)+import           Data.Generics.Uniplate.Operations+  (universeBi)+import           Data.List (sort)+import qualified Data.Map.Strict as M+import           Data.Maybe (mapMaybe, maybeToList)+import           GHC.Generics (Generic)+import qualified Data.ByteString as B++import qualified Language.Fortran.AST           as F+import qualified Language.Fortran.Analysis      as FA+import qualified Language.Fortran.Util.Position as FU++import Camfort.Analysis (ExitCodeOfReport(..), Describe(..))+import Camfort.Analysis.Annotations (Annotation)+import Camfort.Specification.Units.Analysis+  (UnitAnalysis, puName, puSrcName, runInference)+import Camfort.Specification.Units.Analysis.Consistent+  (ConsistencyError, ConsistencyReport(..), checkUnits)+import Camfort.Specification.Units.Environment+-- import Camfort.Specification.Units.InferenceBackendSBV (inferVariables)+import Camfort.Specification.Units.InferenceBackend (inferVariables,+                                                     chooseImplicitNames)+import Camfort.Specification.Units.Monad++import Camfort.Helpers (FileOrDir, Filename)++data ExpInfo = ExpInfo+  { eiSrcSpan :: FU.SrcSpan+  , eiVName   :: F.Name+  , eiSName   :: F.Name+  } deriving (Show, Eq, Ord, Typeable, Data, Generic)++-- | Report from unit inference.+data InferenceReport+  = InferenceReport (F.ProgramFile UA) [(VV, UnitInfo)]++data InferenceResult+  = Inferred InferenceReport+  | InfInconsistent ConsistencyError++instance ExitCodeOfReport InferenceResult where+  exitCodeOf (Inferred _) = 0+  exitCodeOf (InfInconsistent _) = 1++instance Show InferenceReport where+  show (InferenceReport pf vars) =+    concat ["\n", fname, ":\n", unlines [ expReport ei | ei <- expInfo ]]+    where+      expReport (ei, u) = "  " ++ showSrcSpan (eiSrcSpan ei) ++ " unit " ++ show u ++ " :: " ++ eiSName ei+      showSrcSpan :: FU.SrcSpan -> String+      showSrcSpan (FU.SrcSpan l _) = show l+      fname = F.pfGetFilename pf+      expInfo = [ (ei, u) | ei <- declVariableNames+                          , u <- maybeToList ((eiVName ei, eiSName ei) `lookup` vars) ]+      -- | List of declared variables (including both decl statements & function returns, defaulting to first)+      declVariableNames :: [ExpInfo]+      declVariableNames = sort . M.elems $ M.unionWith (curry fst) declInfo puInfo+        where+          declInfo = M.fromList [ (eiVName ei, ei) | ei <- declVariableNamesDecl ]+          puInfo   = M.fromList [ (eiVName ei, ei) | ei <- declVariableNamesPU ]+      declVariableNamesDecl :: [ExpInfo]+      declVariableNamesDecl = flip mapMaybe (universeBi pf :: [F.Declarator UA]) $ \ d -> case d of+        F.DeclVariable _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _   -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))+        F.DeclArray    _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))+        _                                                             -> Nothing+      declVariableNamesPU :: [ExpInfo]+      declVariableNamesPU = flip mapMaybe (universeBi pf :: [F.ProgramUnit UA]) $ \ pu -> case pu of+        F.PUFunction _ ss _ _ _ _ (Just v@(F.ExpValue _ _ (F.ValVariable _))) _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))+        F.PUFunction _ ss _ _ _ _ Nothing _ _                                     -> Just (ExpInfo ss (puName pu) (puSrcName pu))+        _                                                                         -> Nothing++instance Show InferenceResult where+  show (Inferred report) = show report+  show (InfInconsistent err) = show err++instance Describe InferenceReport+instance Describe InferenceResult++getInferred :: InferenceReport -> [(VV, UnitInfo)]+getInferred (InferenceReport _ vars) = vars++-- | Check and infer units-of-measure for a program+--+-- This produces an output of all the unit information for a program.+inferUnits :: UnitAnalysis InferenceResult+inferUnits = do+  (eVars, state) <- runInference (chooseImplicitNames <$> runInferVariables)+  let pfUA = usProgramFile state -- the program file after units analysis is done+  case eVars of+    [] -> do+      consistency <- checkUnits+      pure $ case consistency of+        Consistent{}     -> Inferred (InferenceReport pfUA eVars)+        Inconsistent err -> InfInconsistent err+    _ -> pure . Inferred $ InferenceReport pfUA eVars++-- | Return a list of variable names mapped to their corresponding+-- unit that was inferred.+runInferVariables :: UnitSolver [(VV, UnitInfo)]+runInferVariables = inferVariables <$> getConstraints
+ src/Camfort/Specification/Units/Annotation.hs view
@@ -0,0 +1,119 @@+{- |+Module      :  Camfort.Specification.Units.Annotation+Description :  Annotation with unit information.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental++Defines the 'UnitAnnotation' datatype, which is used for annotating a+'ProgramFile' with units information.+-}++{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Camfort.Specification.Units.Annotation+  (+    -- * Annotation Type+    UA+  , mkUnitAnnotation+  , prevAnnotation+  , unitBlock+  , unitConstraint+  , unitInfo+  , unitPU+  , unitSpec+    -- * Helpers+  , cleanLinks+  , getConstraint+  , getUnitInfo+  , maybeSetUnitConstraintF2+  , maybeSetUnitInfo+  , maybeSetUnitInfoF2+  , setConstraint+  , setUnitInfo+  ) where++import Data.Data (Data, Typeable)+import Data.Generics.Uniplate.Operations (transformBi)++import qualified Language.Fortran.Analysis as FA+import qualified Language.Fortran.AST      as F++import qualified Camfort.Analysis.Annotations             as Ann+import           Camfort.Analysis.CommentAnnotator+  (ASTEmbeddable(..), Linkable(..))+import qualified Camfort.Specification.Units.Environment  as E+import qualified Camfort.Specification.Units.Parser.Types as P++-- The annotation on the AST used for solving units.+data UnitAnnotation a = UnitAnnotation {+    prevAnnotation :: a,+    unitSpec       :: Maybe P.UnitStatement,+    unitConstraint :: Maybe E.Constraint,+    unitInfo       :: Maybe E.UnitInfo,+    unitBlock      :: Maybe (F.Block (FA.Analysis (UnitAnnotation a))), -- ^ linked variable declaration+    unitPU         :: Maybe (F.ProgramUnit (FA.Analysis (UnitAnnotation a))) -- ^ linked program unit+  } deriving (Data, Typeable, Show)++mkUnitAnnotation :: a -> UnitAnnotation a+mkUnitAnnotation a = UnitAnnotation a Nothing Nothing Nothing Nothing Nothing++-- Convenience name for a common annotation type.+type UA = FA.Analysis (UnitAnnotation Ann.A)++-- Instances for embedding parsed specifications into the AST+instance ASTEmbeddable UA P.UnitStatement where+  annotateWithAST ann ast =+    Ann.onPrev (\ann' -> ann' { unitSpec = Just ast }) ann++-- Link annotation comments to declaration statements+instance Linkable UA where+  link ann (b@(F.BlStatement _ _ _ F.StDeclaration {})) =+      Ann.onPrev (\ann' -> ann' { unitBlock = Just b }) ann+  link ann _ = ann+  linkPU ann pu@F.PUFunction{} =+      Ann.onPrev (\ann' -> ann' { unitPU = Just pu }) ann+  linkPU ann pu@F.PUSubroutine{} =+      Ann.onPrev (\ann' -> ann' { unitPU = Just pu }) ann+  linkPU ann _ = ann++-- | Extract the unit info from a given annotated piece of AST.+getUnitInfo :: F.Annotated f => f UA -> Maybe E.UnitInfo+getUnitInfo = unitInfo . FA.prevAnnotation . F.getAnnotation++-- | Extract the constraint from a given annotated piece of AST.+getConstraint :: F.Annotated f => f UA -> Maybe E.Constraint+getConstraint = unitConstraint . FA.prevAnnotation . F.getAnnotation++-- | Set the UnitInfo field on a piece of AST.+setUnitInfo :: F.Annotated f => E.UnitInfo -> f UA -> f UA+setUnitInfo info = F.modifyAnnotation (Ann.onPrev (\ ua -> ua { unitInfo = Just info }))++-- | Set the Constraint field on a piece of AST.+setConstraint :: F.Annotated f => E.Constraint -> f UA -> f UA+setConstraint (E.ConConj []) = id+setConstraint c              =+  F.modifyAnnotation (Ann.onPrev (\ ua -> ua { unitConstraint = Just c }))++--------------------------------------------------++-- Various helper functions for setting the UnitInfo or Constraint of a piece of AST+maybeSetUnitInfo :: F.Annotated f => Maybe E.UnitInfo -> f UA -> f UA+maybeSetUnitInfo u e  = maybe e (`setUnitInfo` e) u++maybeSetUnitInfoF2 :: F.Annotated f => (a -> b -> E.UnitInfo) -> Maybe a -> Maybe b -> f UA -> f UA+maybeSetUnitInfoF2 f u1 u2 e = maybe e (`setUnitInfo` e) (f <$> u1 <*> u2)++maybeSetUnitConstraintF2 :: F.Annotated f => (a -> b -> E.Constraint) -> Maybe a -> Maybe b -> f UA -> f UA+maybeSetUnitConstraintF2 f u1 u2 e = maybe e (`setConstraint` e) (f <$> u1 <*> u2)++cleanLinks :: F.ProgramFile UA -> F.ProgramFile UA+cleanLinks = transformBi+  (\a -> a { unitPU    = Nothing+           , unitBlock = Nothing+           , unitSpec  = Nothing+           } :: UnitAnnotation Ann.A)
+ src/Camfort/Specification/Units/BackendTypes.hs view
@@ -0,0 +1,234 @@+{-+   Copyright 2017, Matthew Danish, Dominic Orchard, Andrew Rice, Mistral Contrastin++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.+-}++{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}++module Camfort.Specification.Units.BackendTypes+  ( UnitSet, Dim, Sub, identDim, isIdentDim, dimFromUnitInfo, dimFromUnitInfos, dimToUnitInfo, dimToUnitInfos+  , subFromList, subToList, identSub, applySub, composeSubs, prop_composition, freeDimVars, dimSimplify+  , dimToConstraint, constraintToDim, dimMultiply, dimRaisePow, dimParamEq, dimParamEqCon, normaliseDim, dimFromList )+where++import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Camfort.Specification.Units.Environment (UnitInfo(..), Constraint(..), flattenUnits, foldUnits, unitParamEq)+import Data.List (partition, foldl', foldl1', sortBy, maximumBy)+import Data.Ord (comparing)+import Data.Maybe (fromMaybe)++-- | Set of UnitInfos+type UnitSet = S.Set UnitInfo++-- | Represents a dimension: collection of units raised to a power,+-- multiplied together. Implemented as a map of unit -> power.+type Dim = M.Map UnitInfo Integer++-- | Represents a substitution: map of unit to be replaced ->+-- dimension to replace it with.+type Sub = M.Map UnitInfo Dim++-- Maintain invariant of Dim whereby all units raised to the zeroth+-- power are eliminated from the map.+removeZeroes :: Dim -> Dim+removeZeroes = M.filterWithKey f+  where+    f _ 0           = False+    f UnitlessVar _ = False+    f UnitlessLit _ = False+    f _ _           = True++-- Handy function to strip away the UnitPow & return the essence.+getUnitPow :: UnitInfo -> (UnitInfo, Integer)+getUnitPow (UnitPow u p) = (u', floor p * p')+  where (u', p') = getUnitPow u+getUnitPow u = (u, 1)++-- | The identity Dim: 1.+identDim :: Dim+identDim = M.empty++-- | Test for identity.+isIdentDim :: Dim -> Bool+isIdentDim = M.null . removeZeroes++-- | Convert from list of implicitly multipled units into a Dim.+dimFromUnitInfos :: [UnitInfo] -> Dim+dimFromUnitInfos = dimFromList . map getUnitPow++-- | Convert a UnitInfo to a Dim.+dimFromUnitInfo :: UnitInfo -> Dim+dimFromUnitInfo = dimFromUnitInfos . flattenUnits++-- | Convert a Dim into an implicitly multipled list of units.+dimToUnitInfos :: Dim -> [UnitInfo]+dimToUnitInfos = map (\ (u, p) -> UnitPow u (fromInteger p)) . M.toList++-- | Convert a Dim into a UnitInfo.+dimToUnitInfo :: Dim -> UnitInfo+dimToUnitInfo = foldUnits . dimToUnitInfos++-- | Convert a Constraint into a Dim where lhs/rhs is implicitly equal+-- to 1. Also normalise the powers by dividing by the gcd and making+-- the largest absolute value power be positive.+constraintToDim :: Constraint -> Dim+constraintToDim (ConEq lhs rhs) = normaliseDim (dimFromUnitInfo lhs `dimMultiply` dimRaisePow (-1) (dimFromUnitInfo rhs))+constraintToDim (ConConj cons)  = foldl' dimMultiply identDim $ map constraintToDim cons++-- | Divide the powers of a dimension by their collective GCD.+normaliseDim :: Dim -> Dim+normaliseDim dim+  | M.null dim = dim+  | otherwise  = M.map (`div` divisor) dim+  where+    divisor = (maxPow `div` abs(maxPow)) * gcds (M.elems dim)+    maxPow  = maximumBy (comparing abs) (M.elems dim)++    gcds []  = 1+    gcds [x] = x+    gcds xs  = foldl1' gcd xs++-- | Multiply two Dims+dimMultiply :: Dim -> Dim -> Dim+dimMultiply d1 d2 = removeZeroes $ M.unionWith (+) d1 d2++-- | Raise the dimension to the given power+dimRaisePow :: Integer -> Dim -> Dim+dimRaisePow 0 d = identDim+dimRaisePow k d = M.map (* k) d++-- | Compare two Dims, not minding the difference between+-- UnitParam*Abs and UnitParam*Use versions of the polymorphic+-- constructors. Varies from a 'constraint parametric equality'+-- operator because it doesn't assume that dimRaisePow can be used+-- arbitrarily.+dimParamEq :: Dim -> Dim -> Bool+dimParamEq d1 d2 = dimParamEq' (M.toList d1) (M.toList d2)++dimParamEq' :: [(UnitInfo, Integer)] -> [(UnitInfo, Integer)] -> Bool+dimParamEq' [] []             = True+dimParamEq' [] _              = False+dimParamEq' ((u1, p1):d1') d2 = case partition (unitParamEq u1 . fst) d2 of+  ((u2, p2):d2', d2'') -> dimParamEq' (rem1 ++ d1') (rem2 ++ d2' ++ d2'')+    where+      (rem1, rem2) | p1 == p2 = ([], [])+                   | p1 < p2  = ([], [(u2, p2 - p1)])+                   | p1 > p2  = ([(u1, p1 - p2)], [])++  _                    -> False++-- | Similar to dimParamEq but assume that dimRaisePow can be+-- arbitrarily applied to each of the parameters, because they now+-- represent the unit equation 'd = 1'. In practice this means+-- computing the GCD of the powers and dividing.+dimParamEqCon :: Dim -> Dim -> Bool+dimParamEqCon d1 d2 = normaliseDim d1 `dimParamEq` normaliseDim d2++-- | Create a constraint that the given Dim is equal to the identity unit.+dimToConstraint :: Dim -> Constraint+dimToConstraint d = ConEq (dimToUnitInfo positives) (dimToUnitInfo (M.map (* (-1)) negatives))+  where+    (negatives, positives) = M.partition (< 0) d++-- | Convert a list of units paired with their corresponding power into a Dim.+dimFromList :: [(UnitInfo, Integer)] -> Dim+dimFromList = removeZeroes . M.fromListWith (+)++-- | Convert a list of units paired with their corresponding+-- substitution (as a Dim) into a Sub. Note that this is equivalent to+-- repeatedly composing substitutions, so earlier substitutions will+-- affect later ones.+subFromList :: [(UnitInfo, Dim)] -> Sub+subFromList = foldl' composeSubs identSub . map (uncurry M.singleton)++-- | Convert a Sub into an association-list format of unit mapped to unit.+subToList :: Sub -> [(UnitInfo, UnitInfo)]+subToList = map (fmap dimToUnitInfo) . M.toList++-- | Identity substitution (empty).+identSub :: Sub+identSub = M.empty++-- | Identity substitution filled out with some identity entries for a+-- certain set of units (useful for when two substitutions have+-- different sets of keys).+identSubWith :: [UnitInfo] -> Sub+identSubWith = M.fromList . map (\ u -> (u, dimFromList [(u, 1)]))++-- | Apply a substitution to a dimension.+applySub :: Sub -> Dim -> Dim+applySub sub dim =+  removeZeroes $ M.unionsWith (+) [ M.map (*p) (M.singleton ui 1 `fromMaybe` M.lookup ui sub) | (ui, p) <- M.toList dim ]++-- | Compose two substitutions.+composeSubs :: Sub -> Sub -> Sub+composeSubs sub1 sub2 = M.map (applySub sub1) (M.unionWith (curry snd) ident1 sub2)+  where+    ident1 = identSubWith (M.keys sub1)++-- | Test the composition property: f (g x) == (f . g) x+prop_composition :: Dim -> Sub -> Sub -> Bool+prop_composition d s1 s2 = applySub s1 (applySub s2 d) == applySub (composeSubs s1 s2) d++-- | Extract a list of 'free dimension variables' from a given Dim.+freeDimVars :: Dim -> [UnitInfo]+freeDimVars = filter isVar . M.keys+  where+    isVar (UnitParamPosAbs {}) = True+    isVar (UnitParamPosUse {}) = True+    isVar (UnitParamVarAbs {}) = True+    isVar (UnitParamVarUse {}) = True+    isVar (UnitParamLitAbs {}) = True+    isVar (UnitParamLitUse {}) = True+    isVar (UnitLiteral {})     = True+    isVar (UnitVar {})         = True+    isVar _                    = False++-- | The 'dimSimplify' algorithm as shown in Kennedy's technical report Fig 3.4.+dimSimplify :: UnitSet -> Dim -> Sub+dimSimplify excludes dim+  | null valids = identSub++  | (u, x):_ <- valids, x < 0+  , sub1     <- M.singleton u (M.singleton u (-1))+  , sub2     <- dimSimplify excludes (applySub sub1 dim) = composeSubs sub2 sub1++  | (u, x):[] <- valids = M.singleton u (dimFromList ((u, 1):[(v, -div y x) | (v, y) <- invals]))++  | (u, x):_ <- valids+  , sub1     <- M.singleton u (dimFromList ((u, 1):[(v, -div y x) | (v, y) <- M.toList dim, v /= u]))+  , sub2     <- dimSimplify excludes (applySub sub1 dim) = composeSubs sub2 sub1++  where+    valids   = sortBy (comparing (abs . snd)) . filter ((`S.notMember` excludes) . fst) $ M.toList dim+    validSet = S.fromList (map fst valids)+    invals   = filter ((`S.notMember` validSet) . fst) $ M.toList dim++testVar x = UnitVar (x, x)++u0 = testVar "u0"+u1 = testVar "u1"+u2 = testVar "u2"+u3 = testVar "u3"+u4 = testVar "u4"++dim1 = dimFromList [(u1, 6), (u2, 15), (u3, -7), (u4, 12)]+dim2 = dimFromList [(u1, 2), (u2, 15), (u3, -9)]++test1 = applySub (dimSimplify (S.fromList [u3,u4]) dim1) dim1 == dimFromList [(u2, 3), (u3, 2)]++test2 =  (dimSimplify (S.fromList [u0]) (dimFromList [(u0, 1), (u1, -2)]))
src/Camfort/Specification/Units/Environment.hs view
@@ -23,36 +23,37 @@     -- * Datatypes and Aliases     Constraint(..)   , Constraints-  , UnitAnnotation(..)   , UnitInfo(..)+  , isMonomorphic, isUnitless   , VV, PP     -- * Helpers   , conParamEq+  , unitParamEq   , doubleToRationalSubset-  , mkUnitAnnotation   , pprintConstr   , pprintUnitInfo   , toUnitInfo+  , foldUnits+  , flattenUnits+  , simplifyUnits+  , colSort, SortFn     -- * Modules (instances)   , module Data.Data   ) where -import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Analysis as FA+import           Data.Binary+import           Data.Char+import           Data.Data+import           Data.List+import           Data.Ratio+import           GHC.Generics (Generic)+import           Text.Printf+import           Control.Arrow (first, second) +import qualified Language.Fortran.AST as F import qualified Camfort.Specification.Units.Parser.Types as P--import Data.Char-import Data.Data-import Data.List-import Data.Ratio-import Data.Binary-import GHC.Generics (Generic)--import Camfort.Helpers (SourceText)-import qualified Data.ByteString.Char8 as B--import Text.Printf+import Data.Generics.Uniplate.Operations (rewrite)+import qualified Data.Map.Strict as M  -- | A (unique name, source name) variable type VV = (F.Name, F.Name)@@ -72,6 +73,7 @@   | UnitParamLitUse (UniqueId, Int)       -- a particular instantiation of a polymorphic literal   | UnitParamEAPAbs VV                    -- an abstract Explicitly Annotated Polymorphic unit variable   | UnitParamEAPUse (VV, Int)             -- a particular instantiation of an Explicitly Annotated Polymorphic unit variable+  | UnitParamImpAbs String                -- implicitly inferred polymorphic units, uniquely identified   | UnitLiteral Int                       -- literal with undetermined but uniquely identified units   | UnitlessLit                           -- a unitless literal   | UnitlessVar                           -- a unitless variable@@ -83,6 +85,70 @@   | UnitRecord [(String, UnitInfo)]       -- 'record'-type of units   deriving (Eq, Ord, Data, Typeable, Generic) +-- | True iff u is monomorphic (has no parametric polymorphic pieces)+isMonomorphic u = case u of+  UnitName _      -> True+  UnitAlias _     -> True+  UnitVar _       -> True+  UnitLiteral _   -> True+  UnitlessVar     -> True+  UnitlessLit     -> True+  UnitRecord recs -> all (isMonomorphic . snd) recs+  UnitMul u1 u2   -> isMonomorphic u1 && isMonomorphic u2+  UnitPow u _     -> isMonomorphic u+  _               -> False++-- | True iff argument matches one of the unitless constructors+isUnitless UnitlessVar = True+isUnitless UnitlessLit = True+isUnitless _           = False++type SortFn = UnitInfo -> UnitInfo -> Ordering+colSort :: UnitInfo -> UnitInfo -> Ordering+colSort (UnitLiteral i) (UnitLiteral j)         = compare i j+colSort (UnitLiteral _) _                       = LT+colSort _ (UnitLiteral _)                       = GT+colSort (UnitParamPosAbs x) (UnitParamPosAbs y) = compare x y+colSort (UnitParamPosAbs _) _                   = GT+colSort _ (UnitParamPosAbs _)                   = LT+colSort x y                                     = compare x y++simplifyUnits :: UnitInfo -> UnitInfo+simplifyUnits = rewrite rw+  where+    rw (UnitMul (UnitMul u1 u2) u3)                          = Just $ UnitMul u1 (UnitMul u2 u3)+    rw (UnitMul u1 u2) | u1 == u2                            = Just $ UnitPow u1 2+    rw (UnitPow (UnitPow u1 p1) p2)                          = Just $ UnitPow u1 (p1 * p2)+    rw (UnitMul (UnitPow u1 p1) (UnitPow u2 p2)) | u1 == u2  = Just $ UnitPow u1 (p1 + p2)+    rw (UnitPow UnitlessLit _)                               = Just UnitlessLit+    rw (UnitPow UnitlessVar _)                               = Just UnitlessVar+    rw (UnitPow _ p) | p `approxEq` 0                        = Just UnitlessLit+    rw (UnitMul UnitlessLit u)                               = Just u+    rw (UnitMul u UnitlessLit)                               = Just u+    rw (UnitMul UnitlessVar u)                               = Just u+    rw (UnitMul u UnitlessVar)                               = Just u+    rw _                                                     = Nothing++flattenUnits :: UnitInfo -> [UnitInfo]+flattenUnits = map (uncurry UnitPow) . M.toList+             . M.filterWithKey (\ u _ -> u /= UnitlessLit && u /= UnitlessVar)+             . M.filter (not . approxEq 0)+             . M.fromListWith (+)+             . map (first simplifyUnits)+             . flatten+  where+    flatten (UnitMul u1 u2) = flatten u1 ++ flatten u2+    flatten (UnitPow u p)   = map (second (p*)) $ flatten u+    flatten u               = [(u, 1)]++foldUnits units+  | null units = UnitlessVar+  | otherwise  = foldl1 UnitMul units++approxEq a b = abs (b - a) < epsilon+epsilon = 0.001 -- arbitrary++ instance Binary UnitInfo  instance Show UnitInfo where@@ -95,12 +161,13 @@     UnitParamLitUse (i, j)              -> printf "#<ParamLitUse litId=%d callId=%d]>" i j     UnitParamEAPAbs (v, _)              -> v     UnitParamEAPUse ((v, _), i)         -> printf "#<ParamEAPUse %s callId=%d]>" v i+    UnitParamImpAbs id                  -> printf "#<ParamImpAbs %s>" id     UnitLiteral i                       -> printf "#<Literal id=%d>" i     UnitlessLit                         -> "1"     UnitlessVar                         -> "1"     UnitName name                       -> name-    UnitAlias name                      -> name-    UnitVar (_, vName)                  -> printf "unit_of(%s)" vName+    UnitAlias name                      -> name -- FIXME: forbid polymorphism in aliases+    UnitVar (vName, _)                  -> printf "#<Var %s>" vName     UnitRecord recs                     -> "record (" ++ intercalate ", " (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")"     UnitMul u1 (UnitPow u2 k)       | k < 0                           -> maybeParen u1 ++ " / " ++ maybeParen (UnitPow u2 (-k))@@ -169,6 +236,7 @@   show (ConConj cs) = intercalate " && " (map show cs)  isUnresolvedUnit (UnitVar _)         = True+isUnresolvedUnit (UnitLiteral _)     = True isUnresolvedUnit (UnitParamVarUse _) = True isUnresolvedUnit (UnitParamVarAbs _) = True isUnresolvedUnit (UnitParamPosUse _) = True@@ -176,6 +244,7 @@ isUnresolvedUnit (UnitParamLitUse _) = True isUnresolvedUnit (UnitParamLitAbs _) = True isUnresolvedUnit (UnitParamEAPAbs _) = True+isUnresolvedUnit (UnitParamImpAbs _) = True isUnresolvedUnit (UnitParamEAPUse _) = True isUnresolvedUnit (UnitPow u _)       = isUnresolvedUnit u isUnresolvedUnit (UnitMul u1 u2)     = isUnresolvedUnit u1 || isUnresolvedUnit u2@@ -199,7 +268,7 @@       "' should be equal"   | isResolvedUnit u1 = "'" ++ pprintUnitInfo u2 ++ "' should have unit '" ++ pprintUnitInfo u1 ++ "'"   | isResolvedUnit u2 = "'" ++ pprintUnitInfo u1 ++ "' should have unit '" ++ pprintUnitInfo u2 ++ "'"-pprintConstr (ConEq u1 u2) = "'" ++ pprintUnitInfo u1 ++ "' should have the same units as '" ++ pprintUnitInfo u2 ++ "'"+  | otherwise = "'" ++ pprintUnitInfo u1 ++ "' should have the same units as '" ++ pprintUnitInfo u2 ++ "'" pprintConstr (ConConj cs)  = intercalate "\n\t and " (fmap pprintConstr cs)  pprintUnitInfo :: UnitInfo -> String@@ -208,7 +277,35 @@ pprintUnitInfo (UnitParamPosUse ((_, fname), 0, _)) = printf "result of %s" fname pprintUnitInfo (UnitParamPosUse ((_, fname), i, _)) = printf "parameter %d to %s" i fname pprintUnitInfo (UnitParamEAPUse ((v, _), _))        = printf "explicitly annotated polymorphic unit %s" v-pprintUnitInfo (UnitLiteral _)                      = "literal"+pprintUnitInfo (UnitLiteral _)                      = "literal number"+pprintUnitInfo (UnitMul u1 u2)                      = pprintUnitInfo u1 ++ " * " ++ pprintUnitInfo u2+pprintUnitInfo (UnitPow u k) | k `approxEq` 0       = "1"+                             | otherwise            =+    case doubleToRationalSubset k of+          Just r+            | e <- showRational r+            , e /= "1"  -> printf "%s**%s" (maybeParen u) e+            | otherwise -> pprintUnitInfo u+          Nothing -> error $+                      printf "Irrational unit exponent: %s**%f" (maybeParen u) k+  where+    showRational r+      | r < 0     = printf "(%s)" (showRational' r)+      | otherwise = showRational' r+    showRational' r+      | denominator r == 1 = show (numerator r)+      | otherwise = printf "(%d / %d)" (numerator r) (denominator r)++    maybeParen x+      | all isAlphaNum s = s+      | otherwise        = "(" ++ s ++ ")"+      where s = pprintUnitInfo x+    maybeParenS x+      | all isUnitMulOk s = s+      | otherwise         = "(" ++ s ++ ")"+      where s = pprintUnitInfo x+    isUnitMulOk c = isSpace c || isAlphaNum c || c `elem` "*."+ pprintUnitInfo ui                                   = show ui  --------------------------------------------------@@ -230,29 +327,13 @@ unitParamEq (UnitParamVarUse (f', i', _)) (UnitParamVarAbs (f, i))      = (f, i) == (f', i') unitParamEq (UnitParamPosAbs (f, i))      (UnitParamPosUse (f', i', _)) = (f, i) == (f', i') unitParamEq (UnitParamPosUse (f', i', _)) (UnitParamPosAbs (f, i))      = (f, i) == (f', i')+unitParamEq (UnitParamImpAbs v)           (UnitParamImpAbs v')          = v == v' unitParamEq (UnitParamEAPAbs v)           (UnitParamEAPUse (v', _))     = v == v' unitParamEq (UnitParamEAPUse (v', _))     (UnitParamEAPAbs v)           = v == v' unitParamEq (UnitMul u1 u2)               (UnitMul u1' u2')             = unitParamEq u1 u1' && unitParamEq u2 u2' ||                                                                           unitParamEq u1 u2' && unitParamEq u2 u1' unitParamEq (UnitPow u p)                 (UnitPow u' p')               = unitParamEq u u' && p == p' unitParamEq u1 u2 = u1 == u2-------------------------------------------------------- The annotation on the AST used for solving units.-data UnitAnnotation a = UnitAnnotation {-    prevAnnotation :: a,-    unitSpec       :: Maybe P.UnitStatement,-    unitConstraint :: Maybe Constraint,-    unitInfo       :: Maybe UnitInfo,-    unitBlock      :: Maybe (F.Block (FA.Analysis (UnitAnnotation a))), -- ^ linked variable declaration-    unitPU         :: Maybe (F.ProgramUnit (FA.Analysis (UnitAnnotation a))) -- ^ linked program unit-  } deriving (Data, Typeable, Show)--mkUnitAnnotation :: a -> UnitAnnotation a-mkUnitAnnotation a = UnitAnnotation a Nothing Nothing Nothing Nothing Nothing----------------------------------------------------  -- | Convert parser units to UnitInfo toUnitInfo   :: P.UnitOfMeasure -> UnitInfo
src/Camfort/Specification/Units/InferenceBackend.hs view
@@ -22,62 +22,49 @@ {-# LANGUAGE ScopedTypeVariables #-}  module Camfort.Specification.Units.InferenceBackend-  ( inconsistentConstraints, criticalVariables, inferVariables+  ( chooseImplicitNames+  , criticalVariables+  , inconsistentConstraints+  , inferVariables   -- mainly for debugging and testing:-  , shiftTerms, flattenConstraints, flattenUnits, constraintsToMatrix, constraintsToMatrices-  , rref, isInconsistentRREF, genUnitAssignments )-where+  , shiftTerms+  , flattenConstraints+  , flattenUnits+  , constraintsToMatrix+  , constraintsToMatrices+  , rref+  , genUnitAssignments+  , genUnitAssignments'+  ) where -import Data.Tuple (swap)-import Data.Maybe (maybeToList)-import Data.List ((\\), findIndex, partition, sortBy, group, tails)-import Data.Generics.Uniplate.Operations (rewrite)-import Control.Monad-import Control.Monad.ST-import Control.Arrow (first, second)-import qualified Data.Map.Strict as M+import           Prelude hiding ((<>))+import           Control.Monad+import           Control.Monad.ST import qualified Data.Array as A--import Camfort.Specification.Units.Environment--import Numeric.LinearAlgebra (-    atIndex, (<>), rank, (?), rows, cols,-    takeColumns, dropRows, subMatrix, diag, fromBlocks,-    ident,+import           Data.Generics.Uniplate.Operations+  (transformBi, universeBi)+import           Data.List+  ((\\), findIndex, inits, nub, partition, sortBy, group, tails)+import           Data.Ord+import qualified Data.Map.Strict as M+import           Data.Maybe (fromMaybe, mapMaybe)+import           Data.Tuple (swap)+import           Numeric.LinearAlgebra+  ( atIndex, (<>), (><)+  , rank, (?)+  , rows, cols+  , subMatrix, diag+  , fromBlocks, ident   ) import qualified Numeric.LinearAlgebra as H-import Numeric.LinearAlgebra.Devel (-    newMatrix, readMatrix, writeMatrix, runSTMatrix, freezeMatrix, STMatrix+import           Numeric.LinearAlgebra.Devel+  ( newMatrix, readMatrix+  , writeMatrix, runSTMatrix+  , freezeMatrix, STMatrix   ) -------------------------------------------------------- | Returns just the list of constraints that were identified as--- being possible candidates for inconsistency, if there is a problem.-inconsistentConstraints :: Constraints -> Maybe Constraints-inconsistentConstraints [] = Nothing-inconsistentConstraints cons-  | null inconsists = Nothing-  | otherwise       = Just [ con | (con, i) <- zip cons [0..], i `elem` inconsists ]-  where-    (_, _, inconsists, _, _) = constraintsToMatrices cons-------------------------------------------------------- | Identifies the variables that need to be annotated in order for--- inference or checking to work.-criticalVariables :: Constraints -> [UnitInfo]-criticalVariables [] = []-criticalVariables cons = filter (not . isUnitRHS) $ map (colA A.!) criticalIndices-  where-    (unsolvedM, _, colA) = constraintsToMatrix cons-    solvedM                       = rref unsolvedM-    uncriticalIndices             = concatMap (maybeToList . findIndex (/= 0)) $ H.toLists solvedM-    criticalIndices               = A.indices colA \\ uncriticalIndices-    isUnitRHS (UnitName _)       = True; isUnitRHS _ = False----------------------------------------------------+import Camfort.Specification.Units.Environment+import qualified Camfort.Specification.Units.InferenceBackendFlint as Flint  -- | Returns list of formerly-undetermined variables and their units. inferVariables :: Constraints -> [(VV, UnitInfo)]@@ -90,61 +77,76 @@       [ (var, units) | ([UnitPow (UnitVar var)                 k], units) <- unitAssignments, k `approxEq` 1 ] ++       [ (var, units) | ([UnitPow (UnitParamVarAbs (_, var)) k], units)    <- unitAssignments, k `approxEq` 1 ] +-- detect inconsistency if concrete units are assigned an implicit+-- abstract unit variable with coefficients not equal+detectInconsistency :: [([UnitInfo], UnitInfo)] -> [([UnitInfo], UnitInfo)]+detectInconsistency unitAssignments = [ fmap foldUnits a | a@([UnitPow (UnitParamImpAbs _) k1], rhs) <- ua'+                                                         , UnitPow _ k2 <- rhs+                                                         , k1 /= k2 ]+  where+    ua' = map (shiftTerms . fmap flattenUnits) unitAssignments+ -- | Raw units-assignment pairs. genUnitAssignments :: [Constraint] -> [([UnitInfo], UnitInfo)] genUnitAssignments cons-  | null inconsists = unitAssignments-  | otherwise       = []+  | null (detectInconsistency ua) = ua+  | otherwise                     = []   where-    (unsolvedM, inconsists, colA) = constraintsToMatrix cons-    solvedM                       = rref unsolvedM-    cols                          = A.elems colA+    ua = genUnitAssignments' colSort cons +genUnitAssignments' :: SortFn -> [Constraint] -> [([UnitInfo], UnitInfo)]+genUnitAssignments' _ [] = []+genUnitAssignments' sortfn cons+  | null colList                                      = []+  | null inconsists                                   = unitAssignments+  | otherwise                                         = []+  where+    (lhsM, rhsM, inconsists, lhsColA, rhsColA) = constraintsToMatrices' sortfn cons+    unsolvedM | rows rhsM == 0 || cols rhsM == 0 = lhsM+              | rows lhsM == 0 || cols lhsM == 0 = rhsM+              | otherwise                        = fromBlocks [[lhsM, rhsM]]++    (solvedM, newColIndices)      = Flint.normHNF unsolvedM+    -- solvedM can have additional columns and rows from normHNF;+    -- cosolvedM corresponds to the original lhsM.+    cosolvedM                     = subMatrix (0, 0) (rows solvedM, cols lhsM) solvedM+    cosolvedMrhs                  = subMatrix (0, cols lhsM) (rows solvedM, cols solvedM - cols lhsM) solvedM++    -- generate a colList with both the original columns and new ones generated+    -- if a new column generated was derived from the right-hand side then negate it+    numLhsCols                    = 1 + snd (A.bounds lhsColA)+    colList                       = map (1,) (A.elems lhsColA ++ A.elems rhsColA) ++ map genC newColIndices+    genC n | n >= numLhsCols      = (-k, UnitParamImpAbs (show u))+           | otherwise            = (k, UnitParamImpAbs (show u))+      where (k, u) = colList !! n     -- Convert the rows of the solved matrix into flattened unit     -- expressions in the form of "unit ** k".-    unitPows                      = map (concatMap flattenUnits . zipWith UnitPow cols) (H.toLists solvedM)+    unitPow (k, u) x              = UnitPow u (k * x)+    unitPows                      = map (concatMap flattenUnits . zipWith unitPow colList) (H.toLists solvedM)      -- Variables to the left, unit names to the right side of the equation.-    unitAssignments               = map (fmap (foldUnits . map negatePosAbs) . partition (not . isUnitRHS)) unitPows+    unitAssignments               = map (fmap (foldUnits . map negatePosAbs) . checkSanity . partition (not . isUnitRHS)) unitPows     isUnitRHS (UnitPow (UnitName _) _)        = True     isUnitRHS (UnitPow (UnitParamEAPAbs _) _) = True     -- Because this version of isUnitRHS different from     -- constraintsToMatrix interpretation, we need to ensure that any     -- moved ParamPosAbs units are negated, because they are     -- effectively being shifted across the equal-sign:+    isUnitRHS (UnitPow (UnitParamImpAbs _) _) = True+    isUnitRHS (UnitPow (UnitParamPosAbs (_, 0)) _) = False     isUnitRHS (UnitPow (UnitParamPosAbs _) _) = True     isUnitRHS _                               = False -    foldUnits units-      | null units = UnitlessVar-      | otherwise  = foldl1 UnitMul units+checkSanity :: ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])+checkSanity (u1@[UnitPow (UnitVar _) _], u2)+  | or $ [ True | UnitParamPosAbs (_, i) <- universeBi u2 ]+      ++ [ True | UnitParamImpAbs _      <- universeBi u2 ] = (u1++u2,[])+checkSanity (u1@[UnitPow (UnitParamVarAbs (f, _)) _], u2)+  | or [ True | UnitParamPosAbs (f', i) <- universeBi u2, f' /= f ] = (u1++u2,[])+checkSanity c = c  -------------------------------------------------- -simplifyUnits :: UnitInfo -> UnitInfo-simplifyUnits = rewrite rw-  where-    rw (UnitMul (UnitMul u1 u2) u3)                          = Just $ UnitMul u1 (UnitMul u2 u3)-    rw (UnitMul u1 u2) | u1 == u2                            = Just $ UnitPow u1 2-    rw (UnitPow (UnitPow u1 p1) p2)                          = Just $ UnitPow u1 (p1 * p2)-    rw (UnitMul (UnitPow u1 p1) (UnitPow u2 p2)) | u1 == u2  = Just $ UnitPow u1 (p1 + p2)-    rw (UnitPow _ p) | p `approxEq` 0                        = Just UnitlessLit-    rw (UnitMul UnitlessLit u)                               = Just u-    rw (UnitMul u UnitlessLit)                               = Just u-    rw _                                                     = Nothing--flattenUnits :: UnitInfo -> [UnitInfo]-flattenUnits = map (uncurry UnitPow) . M.toList-             . M.filterWithKey (\ u _ -> u /= UnitlessLit)-             . M.filter (not . approxEq 0)-             . M.fromListWith (+)-             . map (first simplifyUnits)-             . flatten-  where-    flatten (UnitMul u1 u2) = flatten u1 ++ flatten u2-    flatten (UnitPow u p)   = map (second (p*)) $ flatten u-    flatten u               = [(u, 1)]- approxEq a b = abs (b - a) < epsilon epsilon = 0.001 -- arbitrary @@ -153,22 +155,29 @@ -- Convert a set of constraints into a matrix of co-efficients, and a -- reverse mapping of column numbers to units. constraintsToMatrix :: Constraints -> (H.Matrix Double, [Int], A.Array Int UnitInfo)-constraintsToMatrix cons = (augM, inconsists, A.listArray (0, length colElems - 1) colElems)+constraintsToMatrix cons+  | all null lhs = (H.ident 0, [], A.listArray (0, -1) [])+  | otherwise = (augM, inconsists, A.listArray (0, length colElems - 1) colElems)   where     -- convert each constraint into the form (lhs, rhs)-    consPairs       = flattenConstraints cons+    consPairs       = filter (uncurry (/=)) $ flattenConstraints cons     -- ensure terms are on the correct side of the equal sign     shiftedCons     = map shiftTerms consPairs     lhs             = map fst shiftedCons     rhs             = map snd shiftedCons-    (lhsM, lhsCols) = flattenedToMatrix lhs-    (rhsM, rhsCols) = flattenedToMatrix rhs+    (lhsM, lhsCols) = flattenedToMatrix colSort lhs+    (rhsM, rhsCols) = flattenedToMatrix colSort rhs     colElems        = A.elems lhsCols ++ A.elems rhsCols-    augM            = if rows rhsM == 0 || cols rhsM == 0 then lhsM else fromBlocks [[lhsM, rhsM]]+    augM            = if rows rhsM == 0 || cols rhsM == 0 then lhsM else if rows lhsM == 0 || cols lhsM == 0 then rhsM else fromBlocks [[lhsM, rhsM]]     inconsists      = findInconsistentRows lhsM augM  constraintsToMatrices :: Constraints -> (H.Matrix Double, H.Matrix Double, [Int], A.Array Int UnitInfo, A.Array Int UnitInfo)-constraintsToMatrices cons = (lhsM, rhsM, inconsists, lhsCols, rhsCols)+constraintsToMatrices cons = constraintsToMatrices' colSort cons++constraintsToMatrices' :: SortFn -> Constraints -> (H.Matrix Double, H.Matrix Double, [Int], A.Array Int UnitInfo, A.Array Int UnitInfo)+constraintsToMatrices' sortfn cons+  | all null lhs = (H.ident 0, H.ident 0, [], A.listArray (0, -1) [], A.listArray (0, -1) [])+  | otherwise = (lhsM, rhsM, inconsists, lhsCols, rhsCols)   where     -- convert each constraint into the form (lhs, rhs)     consPairs       = filter (uncurry (/=)) $ flattenConstraints cons@@ -176,14 +185,14 @@     shiftedCons     = map shiftTerms consPairs     lhs             = map fst shiftedCons     rhs             = map snd shiftedCons-    (lhsM, lhsCols) = flattenedToMatrix lhs-    (rhsM, rhsCols) = flattenedToMatrix rhs-    augM            = if rows rhsM == 0 || cols rhsM == 0 then lhsM else fromBlocks [[lhsM, rhsM]]+    (lhsM, lhsCols) = flattenedToMatrix sortfn lhs+    (rhsM, rhsCols) = flattenedToMatrix sortfn rhs+    augM            = if rows rhsM == 0 || cols rhsM == 0 then lhsM else if rows lhsM == 0 || cols lhsM == 0 then rhsM else fromBlocks [[lhsM, rhsM]]     inconsists      = findInconsistentRows lhsM augM  -- [[UnitInfo]] is a list of flattened constraints-flattenedToMatrix :: [[UnitInfo]] -> (H.Matrix Double, A.Array Int UnitInfo)-flattenedToMatrix cons = (m, A.array (0, numCols - 1) (map swap uniqUnits))+flattenedToMatrix :: SortFn -> [[UnitInfo]] -> (H.Matrix Double, A.Array Int UnitInfo)+flattenedToMatrix sortfn cons = (m, A.array (0, numCols - 1) (map swap uniqUnits))   where     m = runSTMatrix $ do           m <- newMatrix 0 numRows numCols@@ -196,7 +205,7 @@                 _        -> return ()           return m     -- identify and enumerate every unit uniquely-    uniqUnits = flip zip [0..] . map head . group . sortBy colSort $ [ u | UnitPow u _ <- concat cons ]+    uniqUnits = flip zip [0..] . map head . group . sortBy sortfn $ [ u | UnitPow u _ <- concat cons ]     -- map units to their unique column number     colMap    = M.fromList uniqUnits     numRows   = length cons@@ -205,16 +214,9 @@ negateCons = map (\ (UnitPow u k) -> UnitPow u (-k))  negatePosAbs (UnitPow (UnitParamPosAbs x) k) = UnitPow (UnitParamPosAbs x) (-k)+negatePosAbs (UnitPow (UnitParamImpAbs v) k) = UnitPow (UnitParamImpAbs v) (-k) negatePosAbs u                               = u -colSort (UnitLiteral i) (UnitLiteral j)         = compare i j-colSort (UnitLiteral _) _                       = LT-colSort _ (UnitLiteral _)                       = GT-colSort (UnitParamPosAbs x) (UnitParamPosAbs y) = compare x y-colSort (UnitParamPosAbs _) _                   = GT-colSort _ (UnitParamPosAbs _)                   = LT-colSort x y                                     = compare x y- --------------------------------------------------  -- Units that should appear on the right-hand-side of the matrix during solving@@ -236,13 +238,11 @@ -------------------------------------------------- -- Matrix solving functions based on HMatrix --- | Returns True iff the given matrix in reduced row echelon form--- represents an inconsistent system of linear equations-isInconsistentRREF a = a @@> (rows a - 1, cols a - 1) == 1 && rank (takeColumns (cols a - 1) (dropRows (rows a - 1) a))== 0- -- | Returns given matrix transformed into Reduced Row Echelon Form rref :: H.Matrix Double -> H.Matrix Double rref a = snd $ rrefMatrices' a 0 0 []+  where+    -- (a', den, r) = Flint.rref a  -- worker function -- invariant: the matrix a is in rref except within the submatrix (j-k,j) to (n,n)@@ -325,6 +325,7 @@     -- Rouché–Capelli theorem is that if the rank of the coefficient     -- matrix is not equal to the rank of the augmented matrix then     -- the system of linear equations is inconsistent.+    tryRows _ _ []      = True     tryRows coA augA ns = (rank coA' == rank augA')       where         coA'  = extractRows ns coA@@ -332,3 +333,47 @@  extractRows = flip (?) -- hmatrix 0.17 changed interface m @@> i = m `atIndex` i++-- | Create unique names for all of the inferred implicit polymorphic+-- unit variables.+chooseImplicitNames :: [(VV, UnitInfo)] -> [(VV, UnitInfo)]+chooseImplicitNames vars = replaceImplicitNames (genImplicitNamesMap vars) vars++genImplicitNamesMap :: Data a => a -> M.Map UnitInfo UnitInfo+genImplicitNamesMap x = M.fromList [ (absU, UnitParamEAPAbs (newN, newN)) | (absU, newN) <- zip absUnits newNames ]+  where+    absUnits = nub [ u | u@(UnitParamPosAbs _)             <- universeBi x ] +++               nub [ u | u@(UnitParamImpAbs _)             <- universeBi x ]+    eapNames = nub $ [ n | u@(UnitParamEAPAbs (_, n))      <- universeBi x ] +++                     [ n | u@(UnitParamEAPUse ((_, n), _)) <- universeBi x ]+    newNames = filter (`notElem` eapNames) . map ('\'':) $ nameGen+    nameGen  = concatMap sequence . tail . inits $ repeat ['a'..'z']++replaceImplicitNames :: Data a => M.Map UnitInfo UnitInfo -> a -> a+replaceImplicitNames implicitMap = transformBi replace+  where+    replace u@(UnitParamPosAbs _) = fromMaybe u $ M.lookup u implicitMap+    replace u@(UnitParamImpAbs _) = fromMaybe u $ M.lookup u implicitMap+    replace u                     = u++-- | Identifies the variables that need to be annotated in order for+-- inference or checking to work.+criticalVariables :: Constraints -> [UnitInfo]+criticalVariables [] = []+criticalVariables cons = filter (not . isUnitRHS) $ map (colA A.!) criticalIndices+  where+    (unsolvedM, _, colA)          = constraintsToMatrix cons+    solvedM                       = rref unsolvedM+    uncriticalIndices             = mapMaybe (findIndex (/= 0)) $ H.toLists solvedM+    criticalIndices               = A.indices colA \\ uncriticalIndices+    isUnitRHS (UnitName _)        = True; isUnitRHS _ = False++-- | Returns just the list of constraints that were identified as+-- being possible candidates for inconsistency, if there is a problem.+inconsistentConstraints :: Constraints -> Maybe Constraints+inconsistentConstraints [] = Nothing+inconsistentConstraints cons+  | null inconsists = Nothing+  | otherwise       = Just [ con | (con, i) <- zip cons [0..], i `elem` inconsists ]+  where+    (_, _, inconsists, _, _) = constraintsToMatrices cons
+ src/Camfort/Specification/Units/InferenceBackendFlint.hs view
@@ -0,0 +1,465 @@+{-+   Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.+-}++{-+  Units of measure extension to Fortran: backend+-}++{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module Camfort.Specification.Units.InferenceBackendFlint where++import System.IO.Unsafe (unsafePerformIO)+import Numeric.LinearAlgebra+  ( atIndex, (<>), (><)+  , rank, (?)+  , rows, cols+  , subMatrix, diag+  , fromBlocks, ident+  )+import qualified Numeric.LinearAlgebra as H++import Control.Monad++import Data.List (findIndex, partition, foldl')++import Foreign+import Foreign.Ptr+import Foreign.C.Types+import Debug.Trace (trace, traceM, traceShowM)++foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_init" fmpz_mat_init :: Ptr FMPZMat -> CLong -> CLong -> IO ()+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_set" fmpz_mat_set :: Ptr FMPZMat -> Ptr FMPZMat -> IO ()+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_entry" fmpz_mat_entry :: Ptr FMPZMat -> CLong -> CLong -> IO (Ptr CLong)+foreign import ccall unsafe "flint/fmpz.h fmpz_set_si" fmpz_set_si :: Ptr CLong -> CLong -> IO ()+foreign import ccall unsafe "flint/fmpz.h fmpz_get_si" fmpz_get_si :: Ptr CLong -> IO CLong+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_clear" fmpz_mat_clear :: Ptr FMPZMat -> IO ()+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_print_pretty" fmpz_mat_print_pretty :: Ptr FMPZMat -> IO ()+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_mul" fmpz_mat_mul :: Ptr FMPZMat -> Ptr FMPZMat -> Ptr FMPZMat -> IO ()++-- fmpz_mat_window_init(fmpz_mat_t window, const fmpz_mat_t mat, slong r1, slong c1, slong r2, slong c2)+--+-- Initializes the matrix window to be an r2 - r1 by c2 - c1 submatrix+-- of mat whose (0,0) entry is the (r1, c1) entry of mat. The memory+-- for the elements of window is shared with mat.+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_window_init" fmpz_mat_window_init :: Ptr FMPZMat -> Ptr FMPZMat -> CLong -> CLong -> CLong -> CLong -> IO ()++-- Frees the window (leaving underlying matrix alone).+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_window_clear" fmpz_mat_window_clear :: Ptr FMPZMat -> IO ()++-- r <- fmp_mat_rref B den A+--+-- Uses fraction-free Gauss-Jordan elimination to set (B, den) to the+-- reduced row echelon form of A and returns the rank of A. Aliasing+-- of A and B is allowed. r is rank of A.+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_rref" fmpz_mat_rref :: Ptr FMPZMat -> Ptr CLong -> Ptr FMPZMat -> IO CLong++-- r <- fmp_mat_inv B den A+--+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_inv" fmpz_mat_inv :: Ptr FMPZMat -> Ptr CLong -> Ptr FMPZMat -> IO CLong++-- fmpz_mat_hnf H A+--+-- H is the Hermite Normal Form of A.+foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_hnf" fmpz_mat_hnf :: Ptr FMPZMat -> Ptr FMPZMat -> IO ()++foreign import ccall unsafe "flint/fmpz_mat.h fmpz_mat_rank" fmpz_mat_rank :: Ptr FMPZMat -> IO CLong++data FMPZMat++instance Storable FMPZMat where+  sizeOf _ = 4 * sizeOf (undefined :: CLong)+  alignment _ = alignment (undefined :: CLong)+  peek _ = undefined+  poke _ = undefined++testFlint = do+  traceM "***********************8 testFlint 8***********************"+  alloca $ \ a -> do+    alloca $ \ b -> do+      alloca $ \ den -> do+        let n = 10+        fmpz_mat_init a n n+        fmpz_mat_init b n n+        forM_ [0..n-1] $ \ i -> do+          forM_ [0..n-1] $ \ j -> do+            e <- fmpz_mat_entry a i j+            fmpz_set_si e (2 * i + j)++        -- fmpz_mat_mul b a a+        r <- fmpz_mat_rref b den a+        fmpz_mat_print_pretty a+        fmpz_mat_print_pretty b+        d <- peek den+        traceM $ "r = " ++ show r ++ " den = " ++ show d+        fmpz_mat_hnf b a+        fmpz_mat_print_pretty b+        fmpz_mat_clear a+        fmpz_mat_clear b+++rref :: H.Matrix Double -> (H.Matrix Double, Int, Int)+rref m = unsafePerformIO $ do+  alloca $ \ outputM -> do+    alloca $ \ inputM -> do+      alloca $ \ den -> do+        let numRows = fromIntegral $ rows m+        let numCols = fromIntegral $ cols m+        fmpz_mat_init outputM numRows numCols+        fmpz_mat_init inputM numRows numCols+        forM_ [0..numRows-1] $ \ i -> do+          forM_ [0..numCols-1] $ \ j -> do+            e <- fmpz_mat_entry inputM i j+            fmpz_set_si e (floor (m `atIndex` (fromIntegral i, fromIntegral j)))+        r <- fmpz_mat_rref outputM den inputM+        d <- peek den++        -- DEBUG:+        -- fmpz_mat_print_pretty outputM+        -- traceM $ "r = " ++ show r ++ " den = " ++ show d+        --++        lists <- forM [0..numRows-1] $ \ i -> do+          forM [0..numCols-1] $ \ j -> do+            e <- fmpz_mat_entry outputM i j+            fromIntegral `fmap` fmpz_get_si e+        let m' = H.fromLists lists+        fmpz_mat_clear inputM+        fmpz_mat_clear outputM+        return (m', fromIntegral d, fromIntegral r)++hnf :: H.Matrix Double -> H.Matrix Double+hnf m = unsafePerformIO $ do+  alloca $ \ outputM -> do+    alloca $ \ inputM -> do+      let numRows = fromIntegral $ rows m+      let numCols = fromIntegral $ cols m+      fmpz_mat_init outputM numRows numCols+      fmpz_mat_init inputM numRows numCols+      forM_ [0..numRows-1] $ \ i -> do+        forM_ [0..numCols-1] $ \ j -> do+          e <- fmpz_mat_entry inputM i j+          fmpz_set_si e (floor (m `atIndex` (fromIntegral i, fromIntegral j)))+      fmpz_mat_hnf outputM inputM+      r <- fmpz_mat_rank outputM++      -- DEBUG:+      -- fmpz_mat_print_pretty outputM+      -- traceM $ "rank = " ++ show r+      --++      lists <- forM [0..fromIntegral r-1] $ \ i -> do+        forM [0..numCols-1] $ \ j -> do+          e <- fmpz_mat_entry outputM i j+          fromIntegral `fmap` fmpz_get_si e+      let m' = H.fromLists lists+      fmpz_mat_clear inputM+      fmpz_mat_clear outputM+      let Just (m'', _) = inv m'+      return m'++inv :: H.Matrix Double -> Maybe (H.Matrix Double, Int)+inv m = unsafePerformIO $ do+  alloca $ \ outputM -> do+    alloca $ \ inputM -> do+      alloca $ \ den -> do+        let numRows = fromIntegral $ rows m+        let numCols = fromIntegral $ cols m+        fmpz_mat_init outputM numRows numCols+        fmpz_mat_init inputM numRows numCols+        forM_ [0..numRows-1] $ \ i -> do+          forM_ [0..numCols-1] $ \ j -> do+            e <- fmpz_mat_entry inputM i j+            fmpz_set_si e (floor (m `atIndex` (fromIntegral i, fromIntegral j)))+        r <- fmpz_mat_inv outputM den inputM+        d <- peek den++        -- DEBUG:+        fmpz_mat_print_pretty outputM+        traceM $ "r = " ++ show r ++ " den = " ++ show d+        --++        lists <- forM [0..numRows-1] $ \ i -> do+          forM [0..numCols-1] $ \ j -> do+            e <- fmpz_mat_entry outputM i j+            fromIntegral `fmap` fmpz_get_si e+        let m' = H.fromLists lists+        fmpz_mat_clear inputM+        fmpz_mat_clear outputM+        if r == 1 then+          return $ Just (m', fromIntegral d)+        else+          return Nothing++withMatrix :: H.Matrix Double -> ((CLong, CLong, Ptr FMPZMat) -> IO b) -> IO b+withMatrix m f = do+  alloca $ \ outputM -> do+    let numRows = fromIntegral $ rows m+    let numCols = fromIntegral $ cols m+    fmpz_mat_init outputM numRows numCols+    forM_ [0 .. numRows - 1] $ \ i ->+      forM_ [0 .. numCols - 1] $ \ j -> do+        e <- fmpz_mat_entry outputM i j+        fmpz_set_si e (floor (m `atIndex` (fromIntegral i, fromIntegral j)) :: CLong)+    x <- f (numRows, numCols, outputM)+    fmpz_mat_clear outputM+    return x++withBlankMatrix :: CLong -> CLong -> (Ptr FMPZMat -> IO b) -> IO b+withBlankMatrix numRows numCols f = do+  alloca $ \ outputM -> do+    fmpz_mat_init outputM (fromIntegral numRows) (fromIntegral numCols)+    x <- f outputM+    fmpz_mat_clear outputM+    return x++withWindow :: Ptr FMPZMat -> CLong -> CLong -> CLong -> CLong -> (Ptr FMPZMat -> IO b) -> IO b+withWindow underM r1 c1 r2 c2 f = do+  alloca $ \ window -> do+    fmpz_mat_window_init window underM r1 c2 r2 c2+    x <- f window+    fmpz_mat_window_clear window+    return x++flintToHMatrix numRows numCols flintM = do+  lists <- forM [0..numRows-1] $ \ i -> do+    forM [0..numCols-1] $ \ j -> do+      e <- fmpz_mat_entry flintM i j+      fromIntegral `fmap` fmpz_get_si e+  return $ H.fromLists lists++pokeM flintM i j v = do+  e <- fmpz_mat_entry flintM i j+  fmpz_set_si e v++peekM flintM i j = do+  e <- fmpz_mat_entry flintM i j+  fmpz_get_si e++copyMatrix m1 m2 r1 c1 r2 c2 =+  forM_ [r1 .. r2-1] $ \ i ->+    forM_ [c1 .. c2-1] $ \ j ->+      peekM m2 i j >>= pokeM m1 i j+++-- 'windows' don't seem to work?+-- copyMatrix' m1 m2 r1 c1 r2 c2 =+--   withWindow m2 r1 c1 r2 c2 $ \ w2 ->+--     withWindow m1 r1 c1 r2 c2 $ \ w1 -> do+--       fmpz_mat_set w1 w2++--------------------------------------------------+-- 'normalising' Hermite Normal Form, for lack of a better name+--+-- The problem with HNF is that it will happily return a matrix where+-- the leading-coefficient diagonal contains integers > 1.+--+-- In some cases the leading-coefficient does not divide some of the+-- remaining numbers in the row.+--+-- This corresponds to the case where one of the solutions would be+-- fractional if we were dealing with rational matrices.+--+-- But we don't want fractional solutions. We need to bump the matrix+-- so that this situation does not arise.+--+-- This tends to happen due to implicit polymorphism.+--+-- We do this by adding another column that copies the column with the+-- problematic leading-coefficient.+--+-- We then set up a new row expressing the constraint that the old+-- column is equal to the new column, 1:1.+--+-- This prevents a 'fractional' solution.+--+-- Along the way we look for leading-coefficients > 1 that do divide+-- their entire row. Then we simply apply elementary row scaling to+-- the row so that the leading-coefficients is 1.+--+-- The result is a matrix where the leading-coefficients of all the+-- rows that matter are 1. It's not quite a 'reduced' form though+-- because it can be bigger than the original matrix.+--+-- As a result we also return a list of columns that were cloned this+-- way.+--+-- The resulting matrix can have non-zeroes above the+-- leading-coefficients in the same column, so I apply some elementary+-- row operations to fix that and bring things into RREF.+--+-- Running time is computation of Hermite Normal Form twice, plus+-- construction of a slightly larger matrix (possibly), plus scanning+-- through the matrix for leading-coefficients, and then again to+-- divide them out sometimes.++normHNF :: H.Matrix Double -> (H.Matrix Double, [Int])+normHNF m = (m', indices)+  where+    numCols = cols m+    indexLookup j | j < numCols = j+                  | otherwise = indices !! (j `mod` numCols)+    indices = map indexLookup $ concatMap snd rs1+    (rs1, (m',[]):rs2) = break (null . snd) results+    results = tail $ iterate (normHNF' . fst) (m, [])++normHNF' :: H.Matrix Double -> (H.Matrix Double, [Int])+normHNF' m = fmap (map fromIntegral) . unsafePerformIO $ withMatrix m normhnf++normhnf (numRows, numCols, inputM) = do+  withBlankMatrix numRows numCols $ \ outputM -> do+    fmpz_mat_hnf outputM inputM+    rank <- fmpz_mat_rank outputM+    -- scale the rows so that it is a RREF, returning the indices+    -- where leading-coefficients had to be scaled to 1.+    indices <- elemrowscale outputM rank numCols+    -- HNF allows non-zeroes above the leading-coefficients that+    -- were greater than 1, so also fix that to bring into RREF.+    elemrowadds outputM rank numCols indices++    -- column indices of leading co-efficients > 1+    lcoefs <- filter ((> 1) . head . snd) <$> forM [0 .. rank-1] (\ i -> do+      cs <- zip [0..] `fmap` sequence [ peekM outputM i j | j <- [0 .. numCols-1] ]+      let (_, (j, lcoef):rest) = span ((== 0) . snd) cs+      return ((i, j), lcoef:map snd rest))++    -- split the identified rows into two categories: those that can+    -- be divided out by the leading co-efficient, and those that+    -- cannot.+    let (multCands, consCands) = partition (\ (_, lcoef:rest) -> all ((== 0) . (`rem` lcoef)) rest) lcoefs++    -- apply elementary row scaling+    forM_ multCands $ \ ((i, j), lcoef:_) ->+      forM_ [j..numCols - 1] $ \ j' -> do+        x <- peekM outputM i j'+        pokeM outputM i j' $ x `div` lcoef++    -- identify columns that need additional constraints generated and+    -- their associated value d, which is the value of the non-leading+    -- co-efficient divided by the GCD of the row.+    let genColCons ((_, j), lcoef:rest) = (j, minNLcoef `div` gcd lcoef minNLcoef)+          where+            restABS   = map abs rest+            minNLcoef = minimum (filter (/= 0) restABS)++    let consCols = map genColCons consCands++    -- generate operations that poke 1.0 and -d into columns of the+    -- given row (matrix parameter supplied later); d is the value of+    -- the non-leading co-efficient that isn't divisible by the+    -- leading-coefficient, divided by the GCD of the row.+    let ops = [ \ flintM i -> do pokeM flintM i j 1+                                 pokeM flintM i (numCols + k) (-d)+              | ((j, d), k) <- zip consCols [0..] ]+    let numOps = fromIntegral (length ops)+    let numRows' = numOps + rank+    let numCols' = numOps + numCols++    withBlankMatrix numRows' numCols' $ \ outputM' -> do+      -- create larger matrix containing outputM as submatrix+      copyMatrix outputM' outputM 0 0 rank numCols++      -- apply the operations on the extra space to write the+      -- additional rows and columns providing the additional+      -- constraints+      forM (zip [rank..] ops) $ \ (i, op) -> op outputM' i++      -- re-run HNF+      withBlankMatrix numRows' numCols' $ \ outputM'' -> do+        fmpz_mat_hnf outputM'' outputM'+        rank' <- fmpz_mat_rank outputM''+        -- scale the rows so that it is a RREF, returning the indices+        -- where leading-coefficients had to be scaled to 1.+        indices <- elemrowscale outputM'' rank' numCols'+        -- HNF allows non-zeroes above the leading-coefficients that+        -- were greater than 1, so also fix that to bring into RREF.+        elemrowadds outputM'' rank' numCols' indices+        -- convert back to HMatrix form+        h <- flintToHMatrix rank' numCols' outputM''+        return (h, map fst consCols)++-- find leading-coefficients that are greater than 1 and scale those+-- rows accordingly to reach RREF+--+-- precondition: matrix outputM is in HNF+elemrowscale outputM rank numCols = do+  -- column indices of leading co-efficients > 1+  lcoefs <- filter ((> 1) . head . snd) <$> forM [0 .. rank-1] (\ i -> do+    cs <- zip [0..] `fmap` sequence [ peekM outputM i j | j <- [0 .. numCols-1] ]+    let (_, (j, lcoef):rest) = span ((== 0) . snd) cs+    return ((i, j), lcoef:map snd rest))++  let multCands = filter (\ (_, lcoef:rest) -> all ((== 0) . (`rem` lcoef)) rest) lcoefs++  -- apply elementary row scaling+  forM multCands $ \ ((i, j), lcoef:_) -> do+    forM_ [j..numCols - 1] $ \ j' -> do+      x <- peekM outputM i j'+      pokeM outputM i j' $ x `div` lcoef+    return (i, j)++-- use indices to guide elementary row additions to reach RREF+--+-- precondition: matrix outputM is in HNF save for work done by+-- elemrowscale, and indices is a list of coordinates where we have+-- just scaled the leading-coefficient to 1 and now we must look to+-- see if there are any non-zeroes in the column above the+-- leading-coefficient, because that is allowed by HNF.+elemrowadds outputM rank numCols indices = do+  -- look for non-zero members of the columns above the+  -- leading-coefficient and wipe them out.+  forM_ indices $ \ (lcI, lcJ) -> do+    let j = lcJ+    forM_ [0..lcI-1] $ \ i -> do+      -- (i, j) ranges over the elements of the column above leading+      -- co-efficient (lcI, lcJ).+      x <- peekM outputM i j+      if x == 0 then+        pure () -- nothing to do at row i+      else do+        -- (i, j) is non-zero and row i must be cancelled x times+        let sf = x -- scaling factor = non-zero magnitude+        forM_ [lcJ..numCols-1] $ \ j' -> do+          -- (i,   j') ranges over the row where we discovered a non-zero+          -- (lcI, j') ranges over the row with the leading co-efficient+          x1 <- peekM outputM i j'+          x2 <- peekM outputM lcI j'+          -- add lower row scaled by sf to upper row+          pokeM outputM i j' (x1 - x2 * sf)++--------------------------------------------------++m1 = (8><6)+ [ 1.0, 0.0, 0.0, -1.0,  0.0,  0.0+ , 0.0, 1.0, 0.0,  0.0, -1.0,  0.0+ , 0.0, 0.0, 1.0,  0.0,  0.0, -1.0+ , 1.0, 0.0, 0.0, -1.0,  0.0,  0.0+ , 0.0, 1.0, 0.0,  0.0, -1.0,  0.0+ , 0.0, 0.0, 1.0,  0.0,  0.0, -1.0+ , 0.0, 0.0, 0.0,  1.0, -4.0,  0.0+ , 0.0, 0.0, 0.0,  0.0,  4.0, -3.0 ] :: H.Matrix Double++m2 = (8><6)+ [ 1.0, 0.0, 0.0, -1.0,  0.0,  0.0+ , 0.0, 1.0, 0.0,  0.0, -1.0,  0.0+ , 0.0, 0.0, 1.0,  0.0,  0.0, -1.0+ , 1.0, 0.0, 0.0, -1.0,  0.0,  0.0+ , 0.0, 1.0, 0.0,  0.0, -1.0,  0.0+ , 0.0, 0.0, 1.0,  0.0,  0.0, -1.0+ , 0.0, 0.0, 0.0,  1.0, -6.0,  0.0+ , 0.0, 0.0, 0.0,  0.0,  6.0, -4.0 ] :: H.Matrix Double
+ src/Camfort/Specification/Units/InferenceBackendSBV.hs view
@@ -0,0 +1,408 @@+{-+   Copyright 2017, Matthew Danish, Vilem Liepelt, Dominic Orchard, Andrew Rice, Mistral Contrastin++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.+-}++{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Camfort.Specification.Units.InferenceBackendSBV+  ( inconsistentConstraints, criticalVariables, inferVariables, genUnitAssignments )+where++import Data.Char+import Data.Tuple (swap)+import Data.Maybe (maybeToList, catMaybes, fromMaybe)+import Data.List ((\\), isPrefixOf, findIndex, partition, sortBy, group, groupBy, tails, transpose, nub, intercalate, foldl')+import Data.Generics.Uniplate.Operations (rewrite, transformBi)+import Debug.Trace (trace, traceShowM, traceM)+import Control.Monad+import Control.Monad.ST+import Control.Arrow (first, second)+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Array as A+import System.IO.Unsafe (unsafePerformIO)+import Data.SBV -- ( transcript, SatResult(..), SMTResult(Unknown), Symbolic, SBool, SInteger, SBV+                -- , satWith, z3, getModelDictionary, fromCW, true, namedConstraint, (.==)+                -- , sInteger, literal, bAnd, Predicate, getModelValue, setOption )+  hiding (engine)+import Data.SBV.Control+import Data.Ord (comparing)+import Data.Function (on)++import Camfort.Specification.Units.Environment+import qualified Camfort.Specification.Units.InferenceBackend as MatrixBackend+import Camfort.Specification.Units.BackendTypes++import Numeric.LinearAlgebra (+    atIndex, (<>), rank, (?), rows, cols,+    takeColumns, dropRows, subMatrix, diag, fromBlocks,+    ident,+  )+import qualified Numeric.LinearAlgebra as H+import Numeric.LinearAlgebra.Devel (+    newMatrix, readMatrix, writeMatrix, runSTMatrix, freezeMatrix, STMatrix+  )+++--------------------------------------------------++-- | Identifies the variables that need to be annotated in order for+-- inference or checking to work.+criticalVariables :: Constraints -> [UnitInfo]+criticalVariables cons = case engine cons of+  Left (core, labeledCons) -> []+  Right (_, suggests) -> suggests++-- | Returns just the list of constraints that were identified as+-- being possible candidates for inconsistency, if there is a problem.+inconsistentConstraints :: Constraints -> Maybe Constraints+inconsistentConstraints [] = Nothing+inconsistentConstraints cons = case engine cons of+  -- assuming that SBV provides a list of label names in its unsat 'core'+  Left (core, labeledCons) -> Just . normalise . map fst . catMaybes . map (flip lookup labeledCons) $ core+  Right (_, _) -> Nothing+  where+    normalise = map (dimToConstraint . constraintToDim)++-- | Returns list of formerly-undetermined variables and their units.+inferVariables :: Constraints -> [(VV, UnitInfo)]+inferVariables cons = solvedVars+  where+    -- We are only interested in reporting the solutions to variables.+    solvedVars = [ (vv, unit) | v@(UnitVar vv, unit) <- unitAssignments ] +++                 [ (vv, unit) | v@(UnitParamVarAbs (_, vv), unit) <- unitAssignments ]+    unitAssignments = genUnitAssignments cons++--------------------------------------------------++approxEq a b = abs (b - a) < epsilon+epsilon = 0.001 -- arbitrary++--------------------------------------------------++negateCons = map (\ (UnitPow u k) -> UnitPow u (-k))++negatePosAbs (UnitPow (UnitParamPosAbs x) k) = UnitPow (UnitParamPosAbs x) (-k)+negatePosAbs u                               = u++--------------------------------------------------++-- Units that should appear on the right-hand-side of the equations during solving+isUnitRHS :: UnitInfo -> Bool+isUnitRHS (UnitPow (UnitName _) _)        = True+isUnitRHS (UnitPow (UnitParamEAPAbs _) _) = True+isUnitRHS _                               = False++type ShiftedConstraint = ([UnitInfo], [UnitInfo])+type ShiftedConstraints = [ShiftedConstraint]++-- | Shift UnitNames/EAPAbs poly units to the RHS, and all else to the LHS.+shiftTerms :: (UnitInfo -> Bool) -> ([UnitInfo], [UnitInfo]) -> ShiftedConstraint+shiftTerms isUnitRHS (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift)+  where+    (lhsOk, lhsShift)           = partition (not . isUnitRHS) lhs+    (rhsOk, rhsShift)           = partition isUnitRHS rhs++-- | Translate all constraints into a LHS, RHS side of units.+flattenConstraints :: Constraints         -> [([UnitInfo], [UnitInfo])]+flattenConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2))++--------------------------------------------------++type Z3 a   = Symbolic a+type Symbol = SInteger++type UnitZ3Map = M.Map (UnitInfo, UnitInfo) Symbol++type LhsUnit         = UnitInfo+type RhsUnit         = UnitInfo+type NameUnitInfoMap = M.Map String (LhsUnit, RhsUnit)+type NameSIntegerMap = M.Map String SInteger++gatherRhsUnitInfoNames :: [[UnitInfo]] -> [(String, RhsUnit)]+gatherRhsUnitInfoNames rhses+  | null rhsNames = [("bogus", UnitName "bogus")]+  | otherwise     = rhsNames++  where+    rhsNames = concatMap eachRow rhses++    eachRow  = map eachCol++    eachCol (UnitPow u _) = (show u, u)+    eachCol u             = (show u, u)++gatherLhsUnitInfoNames :: (String, RhsUnit) -> [[UnitInfo]] -> [(String, (LhsUnit, RhsUnit))]+gatherLhsUnitInfoNames (rhsName, rhsUnit) = concatMap eachRow+  where+    eachRow                               = map eachCol++    eachCol (UnitPow u _) = (show u ++ "_" ++ rhsName, (u, rhsUnit))+    eachCol u             = (show u ++ "_" ++ rhsName, (u, rhsUnit))++gatherNameUnitInfoMap :: [([UnitInfo], [UnitInfo])] -> NameUnitInfoMap+gatherNameUnitInfoMap shiftedCons = M.fromListWith (curry fst) lhsNames+  where+    lhsNames                      = concatMap (flip gatherLhsUnitInfoNames lhsRows) rhsNames+    lhsRows                       = map fst shiftedCons++    rhsNames = gatherRhsUnitInfoNames rhsRows+    rhsRows = map snd shiftedCons++-- | Map of RHS Names to initial powers (0). Forms the basis of the+-- solution for every unit variable.+type BasisMap = M.Map String Integer++genBasisMap :: ShiftedConstraints -> BasisMap+genBasisMap shiftedCons = baseRhsMap+  where+    rhsNames :: [(String, UnitInfo)]+    rhsNames = gatherRhsUnitInfoNames (map snd shiftedCons)++    -- start off with every RHS mapped to a power of zero.+    baseRhsMap = M.fromList [ (name, 0) | (name, _) <- rhsNames ]++genUnitAssignments :: Constraints -> [(UnitInfo, UnitInfo)]+genUnitAssignments cons = case engine cons of+  Left (core, labeledCons) -> []+  Right (sub, _) -> subToList sub++basicOptimisations :: Constraints -> Constraints+basicOptimisations cons = cons'+  where+    cons' = filter (not . identicalSides) cons+    identicalSides (ConEq lhs rhs) = lhs == rhs+    identicalSides _               = False++type EngineResult = Either ([String], [(String, AugConstraint)]) (Sub, [UnitInfo])++-- main working function+engine :: Constraints -> EngineResult+engine cons = unsafePerformIO $ do+  let shiftedCons :: ShiftedConstraints+      shiftedCons = map (shiftTerms isUnitRHS) . flattenConstraints $ basicOptimisations cons++  let nameUIMap = gatherNameUnitInfoMap shiftedCons++  let genVar :: String -> Symbolic (String, SInteger)+      genVar name = (name,) <$> sInteger name++  -- basis of the solution, a.k.a. the primitive units specified by the user+  let basisMap = genBasisMap shiftedCons++  let pred :: Symbolic EngineResult+      pred = do+        setOption $ ProduceUnsatCores True+        -- pregenerate all of the necessary existentials+        nameSIntMap <- M.fromList <$> mapM genVar (M.keys nameUIMap)++        -- temporary arrangement for now to identify constraints+        let encCons = encodeConstraints basisMap nameUIMap nameSIntMap shiftedCons+        labeledCons <- forM (zip [1..] encCons) $ \ (i, (sbool, augCon)) -> do+          namedConstraint ("c"++show i) sbool+          return ("c"++show i, augCon)++        query $ do+          -- obtain at least 1 name, value mapping for each variable if consistent+          e_nvMap <- computeInitialNVMap nameSIntMap+          case e_nvMap of+            Left core -> return $ Left (core, labeledCons) -- inconsistent+            Right nvMap -> do+              -- interpret the suggested values as a list of substitutions+              assignSubs <- interpret nameUIMap nvMap++              -- convert to Dim format+              let dims = map (\ (lhs, rhs) -> (dimFromUnitInfos (lhs ++ negateCons rhs))) shiftedCons++              -- apply known substitutions from solver+              let dims' = filter (not . isIdentDim) $ map (applySub assignSubs) dims++              -- convert to Constraint format+              let polyCons = map dimToConstraint dims'++              -- feed back into old solver to figure out polymorphic equations+              let polyAssigns = MatrixBackend.genUnitAssignments polyCons++              -- convert polymorphic assignments into substitution format+              let polySubs = subFromList [ (u, dimFromUnitInfo units)+                                         | ([UnitPow u@(UnitParamVarAbs _) k], units) <- polyAssigns+                                         , k `approxEq` 1 ]++              let criticals = MatrixBackend.criticalVariables polyCons++              -- for now we'll suggest all underdetermined units but+              -- this should be cut down by considering the+              -- relationships between variables, much like we would+              -- do for polymorphic vars.+              let suggests = [ v | v@(UnitVar {}) <- criticals ] +++                             [ v | v@(UnitParamVarUse {}) <- criticals ]++              return . Right . (,suggests) $ composeSubs polySubs assignSubs++  runSMTWith z3 { transcript = Just "backend-sbv.smt2" } -- SMT-LIB dump+             pred++-- Assumes unitinfo was already simplified & flattened: extracts a+-- name and power+getUnitNamePow :: UnitInfo -> (String, Integer)+getUnitNamePow (UnitPow u p) = (uName, floor p * p')+  where (uName, p') = getUnitNamePow u+getUnitNamePow u = (show u, 1)++-- augmented constraint also includes the "RHS name"+type AugConstraint = (Constraint, String)++encodeConstraints :: BasisMap -> NameUnitInfoMap -> NameSIntegerMap -> ShiftedConstraints -> [(SBool, AugConstraint)]+encodeConstraints basisMap nameUIMap nameSIntMap shiftedCons = do+  let getLhsSymbol :: String -> UnitInfo -> (Symbol, Integer)+      getLhsSymbol rhsName (UnitPow u p) = (uSym, floor p * p')+        where (uSym, p') = getLhsSymbol rhsName u+      getLhsSymbol rhsName u = (s, 1)+        where n = show u ++ "_" ++ rhsName+              s = error ("missing variable for " ++ n) `fromMaybe` M.lookup n nameSIntMap++  -- for each RHS name and corresponding power build an equation of the form:+  --   lhs1_RHS * pow1 + lhs2_RHS * pow2 + ... + lhsN_RHS powN = pow_RHS+  let eachRhs :: Constraint -> [UnitInfo] -> (String, Integer) -> Maybe (SBool, AugConstraint)+      eachRhs con lhs (rhsName, rhsPow)+        | null lhsTerms = Just (0 .== literal rhsPow, (con, rhsName))+        | otherwise     = Just (sum lhsTerms .== literal rhsPow, (con, rhsName))+        where+          -- lhsTerms = [lhs1_RHS * pow1, lhs2_RHS * pow2, ..., lhsN_RHS powN]+          lhsTerms :: [SInteger]+          lhsTerms = [ lhsSym * literal lhsPow | lhs_i <- lhs+                                               , let (lhsSym, lhsPow) = getLhsSymbol rhsName lhs_i ]+          msg = intercalate " + " [ lhsName ++ "(" ++ rhsName ++ ") * " ++ show lhsPow+                                  | lhs_i <- lhs+                                  , let (lhsName, lhsPow) = getUnitNamePow lhs_i ] +++                " == " ++ rhsName ++ " * " ++ show rhsPow++  -- for each constraint having a set of LHS terms and a set of RHS terms:+  let eachConstraint :: ([UnitInfo], [UnitInfo]) -> [(SBool, AugConstraint)]+      eachConstraint (lhs, rhs) = res+        where+          con       = ConEq (foldUnits lhs) (foldUnits rhs)+          msg       = "eachConstraint " ++ show (lhs, rhs) ++ " = " ++ show res+          res       = catMaybes . map (eachRhs con lhs) $ rhsPowers+          -- map every RHS to its corresponding power (including 0 for those not mentioned)+          rhsPowers = M.toList . M.unionWith (+) basisMap . M.fromListWith (+) . map getUnitNamePow $ rhs++  concatMap eachConstraint shiftedCons++showConstraints :: BasisMap -> ShiftedConstraints -> [String]+showConstraints basisMap = map mkMsg+  where+--    mkMsg ([], rhs) = ""+    mkMsg (lhs, rhs) = intercalate "\n" . filter (not . null) $ map (perRhs lhs) rhsPowers+      where+        rhsPowers = M.toList . M.unionWith (+) basisMap . M.fromListWith (+) . map getUnitNamePow $ rhs++    perRhs lhs (rhsName, rhsPow) = msg+      where+        msg = intercalate " + " [ lhsName ++ "(" ++ rhsName ++ ") * " ++ show lhsPow+                                | lhs_i <- lhs+                                , let (lhsName, lhsPow) = getUnitNamePow lhs_i ] +++              " == " ++ rhsName ++ " * " ++ show rhsPow+++data ValueInfo+  = VISet [Integer]+  | VISuggest+  | VIParametric Integer+  deriving (Show, Eq, Ord)++type NameValueInfoMap = M.Map String ValueInfo++computeInitialNVMap :: NameSIntegerMap -> Query (Either [String] NameValueInfoMap)+computeInitialNVMap nameSIntMap = do+  cs <- checkSat+  case cs of+    Unsat -> Left <$> getUnsatCore+    Sat -> do+      nvMap <- extractSIntValues nameSIntMap+      push 1+      disallowValues nameSIntMap nvMap+      cs <- checkSat+      case cs of+        Sat -> do+          nvMap' <- extractSIntValues nameSIntMap+          let nvMap'' = M.unionWith nvUnion nvMap nvMap'+          pop 1+          return $ Right nvMap''+        _   -> do+          pop 1+          return $ Right nvMap+    _ -> error "unknown"++identifyMultipleVISet :: NameUnitInfoMap -> NameValueInfoMap -> [UnitInfo]+identifyMultipleVISet nameUIMap = nub . map fst . catMaybes . map (`M.lookup` nameUIMap) . M.keys . M.filter isMultipleVISet++isMultipleVISet (VISet (_:_:_)) = True+isMultipleVISet _               = False++nvUnion (VISet xs) (VISet ys) = VISet . nub $ xs ++ ys+nvUnion x y = error $ "nvUnion on (" ++ show x ++ ", " ++ show y ++ ")"++extractSIntValues :: NameSIntegerMap -> Query NameValueInfoMap+extractSIntValues = (M.fromList <$>) . mapM convert . M.toList+  where convert (name, sInt) = ((name,) . VISet . (:[])) <$> getValue sInt++disallowValues :: NameSIntegerMap -> NameValueInfoMap -> Query ()+disallowValues nameSIntMap nvMap = constrain . bOr . catMaybes $ map mkNotEq (M.toList nvMap)+  where+    mkNotEq (name, VISet vs@(_:_))+      | Just sInt <- M.lookup name nameSIntMap = Just . bAnd $ map ((sInt ./=) . literal) vs+    mkNotEq _                                = Nothing++disallowCurrentValues :: NameSIntegerMap -> Query ()+disallowCurrentValues nameSIntMap = extractSIntValues nameSIntMap >>= disallowValues nameSIntMap++-- Interpret results.++-- The nameUIMap stores the mapping between each SInteger name and+-- its corresponding (lhsU, rhsU). Therefore we sort and group each+-- entry by its lhsU, and then check the solved integer value of the+-- SInteger name. That solved integer value corresponds to rhsU raised+-- to that power. Take all of the rhsUs, raised to their respective+-- powers, and combine them into a single UnitMul for each lhsU.++interpret :: NameUnitInfoMap -> NameValueInfoMap -> Query Sub+interpret nameUIMap nvMap = do+  let lhsU = fst . snd+  let unitGroups = groupBy ((==) `on` lhsU) . sortBy (comparing lhsU) $ M.toList nameUIMap++  -- unitGroups =+  --   [ [(name1_1, (lhs1, rhs1)), (name1_2, (lhs1, rhs2)), ...]+  --   , [(name2_1, (lhs2, rhs1)), (name2_2, (lhs2, rhs2)), ...]+  --   , ...]++  let eachName :: (String, (LhsUnit, RhsUnit)) -> Query (Maybe UnitInfo)+      eachName (lhsName, (lhsU, rhsU)) = do+        case M.lookup lhsName nvMap of+          Just (VISet [0]) -> return . Just $ UnitlessVar+          Just (VISet [x]) -> return . Just $ UnitPow rhsU (fromInteger x)+          _                -> return Nothing++  -- each group corresponds to a LHS variable+  let eachGroup :: [(String, (LhsUnit, RhsUnit))] -> Query (Maybe (LhsUnit, Dim))+      eachGroup unitGroup = do+        let (_, (lhsU, _)):_ = unitGroup -- grouped by lhsU, so pick out one of them+        rawUnits <- catMaybes <$> mapM eachName unitGroup+        case rawUnits of+          [] -> return Nothing+          _  -> return $ Just (lhsU, dimFromUnitInfos rawUnits)++  (subFromList . catMaybes) <$> mapM eachGroup unitGroups
− src/Camfort/Specification/Units/InferenceFrontend.hs 
@@ -1,990 +0,0 @@-{--   Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish--   Licensed under the Apache License, Version 2.0 (the "License");-   you may not use this file except in compliance with the License.-   You may obtain a copy of the License at--       http://www.apache.org/licenses/LICENSE-2.0--   Unless required by applicable law or agreed to in writing, software-   distributed under the License is distributed on an "AS IS" BASIS,-   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.-   See the License for the specific language governing permissions and-   limitations under the License.--}--{--  Units of measure extension to Fortran: frontend--}--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PatternGuards #-}--module Camfort.Specification.Units.InferenceFrontend-  ( initInference, runCriticalVariables, runInferVariables, runCompileUnits, runInconsistentConstraints, getConstraint-  , puName, puSrcName )-where--import Data.Data (Data)-import Data.List (nub, intercalate, partition)-import qualified Data.Map.Strict as M-import qualified Data.IntMap.Strict as IM-import qualified Data.Set as S-import Data.Maybe (isJust, fromMaybe)-import Data.Generics.Uniplate.Operations-import Control.Monad-import Control.Monad.State.Strict-import Control.Monad.Writer.Strict-import Control.Monad.RWS.Strict--import qualified Language.Fortran.AST as F-import Language.Fortran.Parser.Utils (readReal, readInteger)-import Language.Fortran.Util.Position (getSpan)-import Language.Fortran.Util.ModFile-import qualified Language.Fortran.Analysis as FA-import Language.Fortran.Analysis (varName, srcName)--import Camfort.Analysis.CommentAnnotator (annotateComments)-import Camfort.Analysis.Annotations-import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.Monad-import Camfort.Specification.Units.InferenceBackend-import Camfort.Specification.Units.Parser (unitParser)-import qualified Camfort.Specification.Units.Parser.Types as P--import qualified Debug.Trace as D-import qualified Numeric.LinearAlgebra as H -- for debugging-------------------------------------------------------- | Prepare to run an inference function.-initInference :: UnitSolver ()-initInference = do-  pf <- gets usProgramFile--  -- Parse unit annotations found in comments and link to their-  -- corresponding statements in the AST.-  let (linkedPF, parserReport) =-        runWriter $ annotateComments unitParser-        (\srcSpan err -> tell $ "Error " ++ show srcSpan ++ ": " ++ show err) pf-  modifyProgramFile $ const linkedPF--  -- The following insert* functions examine the AST and insert-  -- mappings into the tables stored in the UnitState.--  -- First, find all given unit annotations and insert them into our-  -- mappings.  Also obtain all unit alias definitions.-  insertGivenUnits--  -- For function or subroutine parameters (or return variables) that-  -- are not given explicit units, give them a parametric polymorphic-  -- unit.-  insertParametricUnits--  -- Any other variables get assigned a unique undetermined unit named-  -- after the variable. This assumes that all variables have unique-  -- names, which the renaming module already has assured.-  insertUndeterminedUnits--  -- Now take the information that we have gathered and annotate the-  -- variable expressions within the AST with it.-  annotateAllVariables--  -- Annotate the literals within the program based upon the-  -- Literals-mode option.-  annotateLiterals--  -- With the variable expressions annotated, we now propagate the-  -- information throughout the AST, giving units to as many-  -- expressions as possible, and also constraints wherever-  -- appropriate.-  propagateUnits--  -- Gather up all of the constraints that we identified in the AST.-  -- These constraints will include parametric polymorphic units that-  -- have not yet been instantiated into their particular uses.-  abstractCons <- extractConstraints-  dumpConsM "***abstractCons" abstractCons--  -- Eliminate all parametric polymorphic units by copying them for-  -- each specific use cases and substituting a unique call-site-  -- identifier that distinguishes each use-case from the others.-  cons <- applyTemplates abstractCons-  dumpConsM "***concreteCons" cons--  -- Remove any traces of CommentAnnotator, since the annotations can-  -- cause generic operations traversing the AST to get confused.-  modifyProgramFile cleanLinks--  modify $ \ s -> s { usConstraints = cons }--  debugLogging--cleanLinks :: F.ProgramFile UA -> F.ProgramFile UA-cleanLinks = transformBi (\ a -> a { unitPU = Nothing, unitBlock = Nothing, unitSpec = Nothing } :: UnitAnnotation A)------------------------------------------------------- Inference functions---- | Return a list of critical variables as UnitInfo list (most likely--- to be of the UnitVar constructor).-runCriticalVariables :: UnitSolver [UnitInfo]-runCriticalVariables = do-  cons <- usConstraints `fmap` get-  return $ criticalVariables cons---- | Return a list of variable names mapped to their corresponding--- unit that was inferred.-runInferVariables :: UnitSolver [(VV, UnitInfo)]-runInferVariables = do-  cons <- usConstraints `fmap` get-  return $ inferVariables cons---- | Return a possible list of unsolvable constraints.-runInconsistentConstraints :: UnitSolver (Maybe Constraints)-runInconsistentConstraints = do-  cons <- usConstraints `fmap` get-  return $ inconsistentConstraints cons---- | Produce information for a "units-mod" file.-runCompileUnits :: UnitSolver CompiledUnits-runCompileUnits = do-  cons <- usConstraints `fmap` get--  -- Sketching some ideas about solving the unit equation for each-  -- parameter of each function.-  let unitAssigns = map (fmap flattenUnits) $ genUnitAssignments cons-  let mulCons x = map (\ (UnitPow u k) -> UnitPow u (x * k))-  let negateCons = mulCons (-1)-  let epsilon = 0.001 -- arbitrary-  let approxEq a b = abs (b - a) < epsilon-  let uninvert ([UnitPow u k], rhs) | not (k `approxEq` 1) = ([UnitPow u 1], mulCons (1 / k) rhs)-      uninvert (lhs, rhs)                                  = (lhs, rhs)-  let shiftTerms name pos (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift)-        where-          (lhsOk, lhsShift) = partition isLHS lhs-          (rhsOk, rhsShift) = partition (not . isLHS) rhs-          isLHS (UnitParamPosAbs (n, i)) | n == name && i == pos = True-          isLHS (UnitPow u _) = isLHS u-          isLHS _ = False--  let nameParams = M.fromList [ (NPKParam name pos, rhs) | assign <- unitAssigns-                                                         , UnitParamPosAbs (name, pos) <- universeBi assign-                                                         , let (_, rhs) = uninvert $ shiftTerms name pos assign ]---  let variables = M.fromList [ (NPKVariable var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssigns-                                                        , k `approxEq` 1 ]--  tmap <- gets usTemplateMap-  return $ CompiledUnits { cuTemplateMap = tmap, cuNameParamMap = nameParams `M.union` variables }-------------------------------------------------------- | Seek out any parameters to functions or subroutines that do not--- already have units, and insert parametric units for them into the--- map of variables to UnitInfo.-insertParametricUnits :: UnitSolver ()-insertParametricUnits = gets usProgramFile >>= (mapM_ paramPU . universeBi)-  where-    paramPU pu = do-      forM_ (indexedParams pu) $ \ (i, param) -> do-        -- Insert a parametric unit if the variable does not already have a unit.-        modifyVarUnitMap $ M.insertWith (curry snd) param (UnitParamPosAbs (fname, i))-      where-        fname = (puName pu, puSrcName pu)---- | Return the list of parameters paired with its positional index.-indexedParams :: F.ProgramUnit UA -> [(Int, VV)]-indexedParams pu-  | F.PUFunction _ _ _ _ _ (Just paList) (Just r) _ _ <- pu = zip [0..] $ map toVV (r : F.aStrip paList)-  | F.PUFunction _ _ _ _ _ (Just paList) _ _ _        <- pu = zip [0..] $ (fname, sfname) : map toVV (F.aStrip paList)-  | F.PUSubroutine _ _ _ _ (Just paList) _ _          <- pu = zip [1..] $ map toVV (F.aStrip paList)-  | otherwise                                               = []-  where-    fname  = puName pu-    sfname = puSrcName pu-    toVV e = (varName e, srcName e)-------------------------------------------------------- | Any remaining variables with unknown units are given unit UnitVar--- with a unique name (in this case, taken from the unique name of the--- variable as provided by the Renamer), or UnitParamVarAbs if the--- variables are inside of a function or subroutine.-insertUndeterminedUnits :: UnitSolver ()-insertUndeterminedUnits = do-  pf   <- gets usProgramFile-  dmap <- (M.union (extractDeclMap pf) . combinedDeclMap . M.elems) `fmap` asks uoModFiles-  forM_ (universeBi pf :: [F.ProgramUnit UA]) $ \ pu ->-    modifyPUBlocksM (transformBiM (insertUndeterminedUnitVar dmap)) pu---- Specifically handle variables-insertUndeterminedUnitVar :: DeclMap -> F.Expression UA -> UnitSolver (F.Expression UA)-insertUndeterminedUnitVar dmap v@(F.ExpValue _ _ (F.ValVariable _)) = do-  let vname = varName v-  let sname = srcName v-  let unit  = toUnitVar dmap (vname, sname)-  modifyVarUnitMap $ M.insertWith (curry snd) (varName v, srcName v) unit-  return v-insertUndeterminedUnitVar _ e = return e---- Choose UnitVar or UnitParamVarAbs depending upon how the variable was declared.-toUnitVar :: DeclMap -> VV -> UnitInfo-toUnitVar dmap (vname, sname) = unit-  where-    unit = case fst `fmap` M.lookup vname dmap of-      Just (DCFunction (F.Named fvname, F.Named fsname))   -> UnitParamVarAbs ((fvname, fsname), (vname, sname))-      Just (DCSubroutine (F.Named fvname, F.Named fsname)) -> UnitParamVarAbs ((fvname, fsname), (vname, sname))-      _                                                    -> UnitVar (vname, sname)-------------------------------------------------------- | Convert explicit polymorphic annotations such as (UnitName "'a")--- into UnitParamEAPAbs with a 'context-unique-name' given by the--- ProgramUnitName combined with the supplied unit name.-transformExplicitPolymorphism :: Maybe F.ProgramUnitName -> UnitInfo -> UnitInfo-transformExplicitPolymorphism (Just (F.Named f)) (UnitName a@('\'':_)) = UnitParamEAPAbs (a, f ++ "_" ++ a)-transformExplicitPolymorphism _ u                                      = u---- | Any units provided by the programmer through comment annotations--- will be incorporated into the VarUnitMap.-insertGivenUnits :: UnitSolver ()-insertGivenUnits = do-  pf <- gets usProgramFile-  mapM_ checkPU (universeBi pf)-  where-    -- Look through each Program Unit for the comments-    checkPU :: F.ProgramUnit UA -> UnitSolver ()-    checkPU (F.PUComment a _ _)-      -- Look at unit assignment between function return variable and spec.-      | Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec-      , Just pu                                      <- mPU = insertPUUnitAssigns (toUnitInfo unitsAST) pu vars-      -- Add a new unit alias.-      | Just (P.UnitAlias name unitsAST) <- mSpec = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST))-      | otherwise                                 = return ()-      where-        mSpec = unitSpec (FA.prevAnnotation a)-        mPU   = unitPU (FA.prevAnnotation a)-    -- Other type of ProgramUnit (e.g. one with a body of blocks)-    checkPU pu = mapM_ (checkBlockComment (getName pu)) [ b | b@(F.BlComment {}) <- universeBi (F.programUnitBody pu) ]-      where-        getName pu = case pu of-          F.PUFunction {}   -> Just $ F.getName pu-          F.PUSubroutine {} -> Just $ F.getName pu-          _                 -> Nothing--    -- Look through each comment that has some kind of unit annotation within it.-    checkBlockComment :: Maybe F.ProgramUnitName -> F.Block UA -> UnitSolver ()-    checkBlockComment pname (F.BlComment a _ _)-      -- Look at unit assignment between variable and spec.-      | Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec-      , Just b                                       <- mBlock = insertBlockUnitAssigns pname (toUnitInfo unitsAST) b vars-      -- Add a new unit alias.-      | Just (P.UnitAlias name unitsAST) <- mSpec  = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST))-      | otherwise                                  = return ()-      where-        mSpec  = unitSpec (FA.prevAnnotation a)-        mBlock = unitBlock (FA.prevAnnotation a)--    -- Figure out the unique names of the referenced variables and-    -- then insert unit info under each of those names.-    insertBlockUnitAssigns :: Maybe F.ProgramUnitName -> UnitInfo -> F.Block UA -> [String] -> UnitSolver ()-    insertBlockUnitAssigns pname info (F.BlStatement _ _ _ (F.StDeclaration _ _ _ _ decls)) varRealNames = do-      -- figure out the 'unique name' of the varRealName that was found in the comment-      -- FIXME: account for module renaming-      -- FIXME: might be more efficient to allow access to variable renaming environ at this program point-      let info' = transform (transformExplicitPolymorphism pname) info-      let m = M.fromList [ ((varName e, srcName e), info')-                         | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi decls :: [F.Expression UA]-                         , varRealName <- varRealNames-                         , varRealName == srcName e ]-      modifyVarUnitMap $ M.unionWith const m-      modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m--    -- Insert unit annotation for function return variable-    insertPUUnitAssigns :: UnitInfo -> F.ProgramUnit UA -> [String] -> UnitSolver ()-    insertPUUnitAssigns info pu@(F.PUFunction _ _ _ _ _ _ mret _ _) varRealNames-      | (retUniq, retSrc) <- case mret of Just ret -> (FA.varName ret, FA.srcName ret)-                                          Nothing  -> (puName pu, puSrcName pu)-      , retSrc `elem` varRealNames = do-          let pname = Just $ F.getName pu-          let info' = transform (transformExplicitPolymorphism pname) info-          let m = M.fromList [ ((retUniq, retSrc), info') ]-          modifyVarUnitMap $ M.unionWith const m-          modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m-------------------------------------------------------- | Take the unit information from the VarUnitMap and use it to--- annotate every variable expression in the AST.-annotateAllVariables :: UnitSolver ()-annotateAllVariables = modifyProgramFileM $ \ pf -> do-  varUnitMap <- usVarUnitMap `fmap` get-  let annotateExp e@(F.ExpValue _ _ (F.ValVariable _))-        | Just info <- M.lookup (varName e, srcName e) varUnitMap = setUnitInfo info e-      -- may need to annotate intrinsics separately-      annotateExp e = e-  return $ transformBi annotateExp pf-------------------------------------------------------- | Give units to literals based upon the rules of the Literals mode.------ LitUnitless: All literals are unitless.--- LitPoly:     All literals are polymorphic.--- LitMixed:    The literal "0" or "0.0" is fully parametric polymorphic.---              All other literals are monomorphic, possibly unitless.-annotateLiterals :: UnitSolver ()-annotateLiterals = modifyProgramFileM (transformBiM annotateLiteralsPU)--annotateLiteralsPU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)-annotateLiteralsPU pu = do-  mode <- asks uoLiterals-  case mode of-    LitUnitless -> modifyPUBlocksM (transformBiM expUnitless) pu-    LitPoly     -> modifyPUBlocksM (transformBiM (withLiterals genParamLit)) pu-    LitMixed    -> modifyPUBlocksM (transformBiM expMixed) pu-  where-    -- Follow the LitMixed rules.-    expMixed e = case e of-      F.ExpValue _ _ (F.ValInteger i) | readInteger i == Just 0 -> withLiterals genParamLit e-                                      | isPolyCtxt              -> expUnitless e-                                      | otherwise               -> withLiterals genUnitLiteral e-      F.ExpValue _ _ (F.ValReal i) | readReal i == Just 0       -> withLiterals genParamLit e-                                   | isPolyCtxt                 -> expUnitless e-                                   | otherwise                  -> withLiterals genUnitLiteral e-      _                                                         -> return e--    -- Set all literals to unitless.-    expUnitless e-      | isLiteral e = return $ setUnitInfo UnitlessLit e-      | otherwise   = return e--    -- Set all literals to the result of given monadic computation.-    withLiterals m e-      | isLiteral e = flip setUnitInfo e `fmap` m-      | otherwise   = return e--    isPolyCtxt = case pu of F.PUFunction {} -> True; F.PUSubroutine {} -> True; _ -> False---- | Is it a literal, literally?-isLiteral :: F.Expression UA -> Bool-isLiteral (F.ExpValue _ _ (F.ValReal _))    = True-isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True-isLiteral _                                 = False---- | Is expression a literal and is it zero?-isLiteralNonZero :: F.Expression UA -> Bool-isLiteralNonZero (F.ExpValue _ _ (F.ValInteger i)) = readInteger i /= Just 0-isLiteralNonZero (F.ExpValue _ _ (F.ValReal i))    = readReal i    /= Just 0-isLiteralNonZero _                                 = False-------------------------------------------------------- | Convert all parametric templates into actual uses, via substitution.-applyTemplates :: Constraints -> UnitSolver Constraints--- postcondition: returned constraints lack all Parametric constructors-applyTemplates cons = do-  dumpConsM "applyTemplates" cons-  -- Get a list of the instances of parametric polymorphism from the constraints.-  let instances = nub [ (name, i) | UnitParamPosUse ((name, _), _, i) <- universeBi cons ]--  -- Also generate a list of 'dummy' instances to ensure that every-  -- 'toplevel' function and subroutine is thoroughly expanded and-  -- analysed, even if it is not used in the current ProgramFile. (It-  -- might be part of a library module, for instance).-  pf <- gets usProgramFile-  dummies <- forM (topLevelFuncsAndSubs pf) $ \ pu -> do-    id <- genCallId-    return (puName pu, id)--  whenDebug $ do-    D.traceM ("instances: " ++ show instances ++ "\n")-    D.traceM ("dummies: " ++ show dummies ++ "\n")--  -- Work through the instances, expanding their templates, and-  -- substituting the callId into the abstract parameters.-  concreteCons <- liftM2 (++) (foldM (substInstance False []) [] instances)-                              (foldM (substInstance True []) [] dummies)-  dumpConsM "applyTemplates: concreteCons" concreteCons--  -- Also include aliases in the final set of constraints, where-  -- aliases are implemented by simply asserting that they are equal-  -- to their definition.-  aliasMap <- usUnitAliasMap `fmap` get-  let aliases = [ ConEq (UnitAlias name) def | (name, def) <- M.toList aliasMap ]-  let transAlias (UnitName a) | a `M.member` aliasMap = UnitAlias a-      transAlias u                                    = u--  dumpConsM "aliases" aliases-  return . transformBi transAlias $ cons ++ concreteCons ++ aliases---- | Look up the Parametric templates for a given function or--- subroutine, and do the substitutions. Process any additional--- polymorphic calls that are uncovered, unless they are recursive--- calls that have already been seen in the current call stack.-substInstance :: Bool -> [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints-substInstance isDummy callStack output (name, callId) = do-  tmap <- gets usTemplateMap--  -- Look up the templates associated with the given function or-  -- subroutine name. And then transform the templates by generating-  -- new callIds for any constraints created by function or subroutine-  -- calls contained within the templates.-  ---  -- The reason for this is because functions called by functions can-  -- be used in a parametric polymorphic way.--  -- npc <- nameParamConstraints name -- In case it is an imported function, use this.-  let npc = [] -- disabled for now-  template <- transformBiM callIdRemap $ npc `fromMaybe` M.lookup name tmap-  dumpConsM ("substInstance " ++ show isDummy ++ " " ++ show callStack ++ " " ++ show (name, callId) ++ " template lookup") template--  -- Reset the usCallIdRemap field so that it is ready for the next-  -- set of templates.-  modify $ \ s -> s { usCallIdRemap = IM.empty }--  -- If any new instances are discovered, also process them, unless recursive.-  let instances = nub [ (name, i) | UnitParamPosUse ((name, _), _, i) <- universeBi template ]-  template' <- if name `elem` callStack then-                 -- Detected recursion: we do not support polymorphic-unit recursion,-                 -- ergo all subsequent recursive calls are assumed to have the same-                 -- unit-assignments as the first call.-                 return []-               else-                 foldM (substInstance False (name:callStack)) [] instances--  dumpConsM ("instantiating " ++ show (name, callId) ++ ": (output ++ template) is") (output ++ template)-  dumpConsM ("instantiating " ++ show (name, callId) ++ ": (template') is") (template')--  -- Get constraints for any imported variables-  let filterForVars (NPKVariable _) _ = True; filterForVars _ _ = False-  nmap <- M.filterWithKey filterForVars `fmap` gets usNameParamMap-  let importedVariables = [ ConEq (UnitVar vv) (foldUnits units) | (NPKVariable vv, units) <- M.toList nmap ]--  -- Convert abstract parametric units into concrete ones.--  let output' = -- Do not instantiate explicitly annotated polymorphic-                -- variables from current context when looking at dummy (name, callId)-                (if isDummy then output ++ template-                            else instantiate callId (output ++ template)) ++--                -- Only instantiate explicitly annotated polymorphic-                -- variables from nested function/subroutine calls.-                instantiate callId template' ++--                -- any imported variables-                importedVariables--  dumpConsM ("final output for " ++ show (name, callId)) output'--  return output'--foldUnits units-  | null units = UnitlessVar-  | otherwise  = foldl1 UnitMul units---- | Generate constraints from a NameParamMap entry.-nameParamConstraints :: F.Name -> UnitSolver Constraints-nameParamConstraints fname = do-  let filterForName (NPKParam (n, _) _) _ = n == fname-      filterForName _ _                   = False-  nlst <- (M.toList . M.filterWithKey filterForName) `fmap` gets usNameParamMap-  return [ ConEq (UnitParamPosAbs (n, pos)) (foldUnits units) | (NPKParam n pos, units) <- nlst ]---- | If given a usage of a parametric unit, rewrite the callId field--- to follow an existing mapping in the usCallIdRemap state field, or--- generate a new callId and add it to the usCallIdRemap state field.-callIdRemap :: UnitInfo -> UnitSolver UnitInfo-callIdRemap info = modifyCallIdRemapM $ \ idMap -> case info of-    UnitParamPosUse (n, p, i)-      | Just i' <- IM.lookup i idMap -> return (UnitParamPosUse (n, p, i'), idMap)-      | otherwise                    -> genCallId >>= \ i' ->-                                          return (UnitParamPosUse (n, p, i'), IM.insert i i' idMap)-    UnitParamVarUse (n, v, i)-      | Just i' <- IM.lookup i idMap -> return (UnitParamVarUse (n, v, i'), idMap)-      | otherwise                    -> genCallId >>= \ i' ->-                                          return (UnitParamVarUse (n, v, i'), IM.insert i i' idMap)-    UnitParamLitUse (l, i)-      | Just i' <- IM.lookup i idMap -> return (UnitParamLitUse (l, i'), idMap)-      | otherwise                    -> genCallId >>= \ i' ->-                                          return (UnitParamLitUse (l, i'), IM.insert i i' idMap)-    UnitParamEAPUse (v, i)-      | Just i' <- IM.lookup i idMap -> return (UnitParamEAPUse (v, i'), idMap)-      | otherwise                    -> genCallId >>= \ i' ->-                                          return (UnitParamEAPUse (v, i'), IM.insert i i' idMap)--    _                                -> return (info, idMap)----- | Convert a parametric template into a particular use.-instantiate :: Data a => Int -> a -> a-instantiate callId = transformBi $ \ info -> case info of-  UnitParamPosAbs (name, position) -> UnitParamPosUse (name, position, callId)-  UnitParamLitAbs litId            -> UnitParamLitUse (litId, callId)-  UnitParamVarAbs (fname, vname)   -> UnitParamVarUse (fname, vname, callId)-  UnitParamEAPAbs vname            -> UnitParamEAPUse (vname, callId)-  _                                -> info---- | Return a list of ProgramUnits that might be considered 'toplevel'--- in the ProgramFile, e.g., possible exports. These must be analysed--- independently of whether they are actually used in the same file,--- because other files might use them.-topLevelFuncsAndSubs :: F.ProgramFile a -> [F.ProgramUnit a]-topLevelFuncsAndSubs (F.ProgramFile _ pus) = topLevel =<< pus-  where-    topLevel (F.PUModule _ _ _ _ (Just contains)) = topLevel =<< contains-    topLevel (F.PUMain _ _ _ _ (Just contains))   = topLevel =<< contains-    topLevel f@(F.PUFunction {})                  = return f-    topLevel s@(F.PUSubroutine {})                = return s-    topLevel _                                    = []-------------------------------------------------------- | Gather all constraints from the main blocks of the AST, as well as from the varUnitMap-extractConstraints :: UnitSolver Constraints-extractConstraints = do-  pf         <- gets usProgramFile-  dmap       <- (M.union (extractDeclMap pf) . combinedDeclMap . M.elems) `fmap` asks uoModFiles-  varUnitMap <- gets usVarUnitMap-  return $ [ con | b <- mainBlocks pf, con@(ConEq {}) <- universeBi b ] ++-           [ ConEq (toUnitVar dmap v) u | (v, u) <- M.toList varUnitMap ]---- | A list of blocks considered to be part of the 'main' program.-mainBlocks :: F.ProgramFile UA -> [F.Block UA]-mainBlocks = concatMap getBlocks . universeBi-  where-    getBlocks (F.PUMain _ _ _ bs _)   = bs-    getBlocks (F.PUModule _ _ _ bs _) = bs-    getBlocks _                       = []-------------------------------------------------------- | Decorate the AST with unit info.-propagateUnits :: UnitSolver ()--- precondition: all variables have already been annotated-propagateUnits = modifyProgramFileM $ transformBiM propagatePU        <=<-                                      transformBiM propagateStatement <=<-                                      transformBiM propagateExp--propagateExp :: F.Expression UA -> UnitSolver (F.Expression UA)-propagateExp e = fmap uoLiterals ask >>= \ lm -> case e of-  F.ExpValue _ _ _                       -> return e -- all values should already be annotated-  F.ExpBinary _ _ F.Multiplication e1 e2 -> setF2 UnitMul (getUnitInfoMul lm e1) (getUnitInfoMul lm e2)-  F.ExpBinary _ _ F.Division e1 e2       -> setF2 UnitMul (getUnitInfoMul lm e1) (flip UnitPow (-1) `fmap` (getUnitInfoMul lm e2))-  F.ExpBinary _ _ F.Exponentiation e1 e2 -> setF2 UnitPow (getUnitInfo e1) (constantExpression e2)-  F.ExpBinary _ _ o e1 e2 | isOp AddOp o -> setF2C ConEq  (getUnitInfo e1) (getUnitInfo e2)-                          | isOp RelOp o -> setF2C ConEq  (getUnitInfo e1) (getUnitInfo e2)-  F.ExpFunctionCall {}                   -> propagateFunctionCall e-  F.ExpSubscript _ _ e1 _                -> return $ maybeSetUnitInfo (getUnitInfo e1) e-  F.ExpUnary _ _ _ e1                    -> return $ maybeSetUnitInfo (getUnitInfo e1) e-  _                                      -> do-    whenDebug . tell $ "propagateExp: " ++ show (getSpan e) ++ " unhandled: " ++ show e-    return e-  where-    -- Shorter names for convenience functions.-    setF2 f u1 u2  = return $ maybeSetUnitInfoF2 f u1 u2 e-    -- Remember, not only set a constraint, but also give a unit!-    setF2C f u1 u2 = return . maybeSetUnitInfo u1 $ maybeSetUnitConstraintF2 f u1 u2 e--propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA)-propagateFunctionCall (F.ExpFunctionCall a s f Nothing)                     = do-  (info, _) <- callHelper f []-  let cons = intrinsicHelper info f []-  return . setConstraint (ConConj cons) . setUnitInfo info $ F.ExpFunctionCall a s f Nothing-propagateFunctionCall (F.ExpFunctionCall a s f (Just (F.AList a' s' args))) = do-  (info, args') <- callHelper f args-  let cons = intrinsicHelper info f args'-  return . setConstraint (ConConj cons) . setUnitInfo info $ F.ExpFunctionCall a s f (Just (F.AList a' s' args'))--propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA)-propagateStatement stmt = case stmt of-  F.StExpressionAssign _ _ e1 e2               -> literalAssignmentSpecialCase e1 e2 stmt-  F.StCall a s sub (Just (F.AList a' s' args)) -> do-    (info, args') <- callHelper sub args-    let cons = intrinsicHelper info sub args'-    return . setConstraint (ConConj cons) $ F.StCall a s sub (Just (F.AList a' s' args'))-  F.StDeclaration {}                           -> transformBiM propagateDeclarator stmt-  _                                            -> return stmt--propagateDeclarator :: F.Declarator UA -> UnitSolver (F.Declarator UA)-propagateDeclarator decl = case decl of-  F.DeclVariable _ _ e1 _ (Just e2) -> literalAssignmentSpecialCase e1 e2 decl-  F.DeclArray _ _ e1 _ _ (Just e2)  -> literalAssignmentSpecialCase e1 e2 decl-  _                                 -> return decl---- Allow literal assignment to overload the non-polymorphic--- unit-assignment of the non-zero literal.-literalAssignmentSpecialCase e1 e2 ast-  | u2@(Just (UnitLiteral _)) <- getUnitInfo e2 = do-    return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) u2 ast-  | isLiteralNonZero e2                         = do-    u2 <- genUnitLiteral-    return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (Just u2) ast-  | otherwise                                   = do-    -- otherwise express the constraint between LHS and RHS of assignment.-    return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) ast--propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)-propagatePU pu = do-  let name     = puName pu-  let sname    = puSrcName pu-  let nn       = (name, sname)-  let bodyCons = [ con | con@(ConEq {}) <- universeBi pu ] -- Constraints within the PU.--  varMap <- gets usVarUnitMap--  -- If any of the function/subroutine parameters was given an-  -- explicit unit annotation, then create a constraint between that-  -- explicit unit and the UnitParamPosAbs corresponding to the-  -- parameter. This way all other uses of the parameter get linked to-  -- the explicit unit annotation as well.-  givenCons <- forM (indexedParams pu) $ \ (i, param) -> do-    case M.lookup param varMap of-      Just (UnitParamPosAbs {}) -> return . ConEq (UnitParamVarAbs (nn, param)) $ UnitParamPosAbs (nn, i)-      Just u                    -> return . ConEq u $ UnitParamPosAbs (nn, i)-      _                         -> return . ConEq (UnitParamVarAbs (nn, param)) $ UnitParamPosAbs (nn, i)--  let cons = givenCons ++ bodyCons-  case pu of F.PUFunction {}   -> modifyTemplateMap (M.insert name cons)-             F.PUSubroutine {} -> modifyTemplateMap (M.insert name cons)-             _                 -> return ()--  -- Set the unitInfo field of a function program unit to be the same-  -- as the unitInfo of its result.-  let pu' = case (pu, indexedParams pu) of-              (F.PUFunction {}, (0, res):_) -> setUnitInfo (UnitParamPosAbs (nn, 0) `fromMaybe` M.lookup res varMap) pu-              _                             -> pu--  return (setConstraint (ConConj cons) pu')-------------------------------------------------------- | Coalesce various function and subroutine call common code.-callHelper :: F.Expression UA -> [F.Argument UA] -> UnitSolver (UnitInfo, [F.Argument UA])-callHelper nexp args = do-  let name = (varName nexp, srcName nexp)-  callId <- genCallId -- every call-site gets its own unique identifier-  let eachArg i arg@(F.Argument _ _ _ e)-        -- add site-specific parametric constraints to each argument-        | Just u <- getUnitInfo e = setConstraint (ConEq u (UnitParamPosUse (name, i, callId))) arg-        | otherwise               = arg-  let args' = zipWith eachArg [1..] args-  -- build a site-specific parametric unit for use on a return variable, if any-  let info = UnitParamPosUse (name, 0, callId)-  return (info, args')---- FIXME: use this function to create a list of constraints on intrinsic call-sites...-intrinsicHelper (UnitParamPosUse (_, _, callId)) f@(F.ExpValue _ _ (F.ValIntrinsic _)) args-  | Just (retU, argUs) <- M.lookup sname intrinsicUnits = zipWith eachArg [0..numArgs] (retU:argUs)-  where-    numArgs     = length args-    sname       = srcName f-    vname       = varName f-    eachArg i u = ConEq (UnitParamPosUse ((vname, sname), i, callId)) (instantiate callId u)-intrinsicHelper _ _ _ = []---- | Generate a unique identifier for a call-site.-genCallId :: UnitSolver Int-genCallId = do-  st <- get-  let callId = usCallIds st-  put $ st { usCallIds = callId + 1 }-  return callId---- | Generate a unique identifier for a literal encountered in the code.-genUnitLiteral :: UnitSolver UnitInfo-genUnitLiteral = do-  s <- get-  let i = usLitNums s-  put $ s { usLitNums = i + 1 }-  return $ UnitLiteral i---- | Generate a unique identifier for a polymorphic literal encountered in the code.-genParamLit :: UnitSolver UnitInfo-genParamLit = do-  s <- get-  let i = usLitNums s-  put $ s { usLitNums = i + 1 }-  return $ UnitParamLitAbs i-------------------------------------------------------- | Extract the unit info from a given annotated piece of AST.-getUnitInfo :: F.Annotated f => f UA -> Maybe UnitInfo-getUnitInfo = unitInfo . FA.prevAnnotation . F.getAnnotation---- | Extract the constraint from a given annotated piece of AST.-getConstraint :: F.Annotated f => f UA -> Maybe Constraint-getConstraint = unitConstraint . FA.prevAnnotation . F.getAnnotation---- | Extract the unit info from a given annotated piece of AST, within--- the context of a multiplication expression, and given a particular--- mode for handling literals.------ The point is that the unit-assignment of a literal constant can--- vary depending upon whether it is being multiplied by a variable--- with units, and possibly by global options that assume one way or--- the other.-getUnitInfoMul :: LiteralsOpt -> F.Expression UA -> Maybe UnitInfo-getUnitInfoMul LitPoly e          = getUnitInfo e-getUnitInfoMul _ e-  | isJust (constantExpression e) = Just UnitlessLit-  | otherwise                     = getUnitInfo e---- | Set the UnitInfo field on a piece of AST.-setUnitInfo :: F.Annotated f => UnitInfo -> f UA -> f UA-setUnitInfo info = F.modifyAnnotation (onPrev (\ ua -> ua { unitInfo = Just info }))---- | Set the Constraint field on a piece of AST.-setConstraint :: F.Annotated f => Constraint -> f UA -> f UA-setConstraint (ConConj []) = id-setConstraint c            = F.modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c }))-------------------------------------------------------- Various helper functions for setting the UnitInfo or Constraint of a piece of AST-maybeSetUnitInfo :: F.Annotated f => Maybe UnitInfo -> f UA -> f UA-maybeSetUnitInfo Nothing e  = e-maybeSetUnitInfo (Just u) e = setUnitInfo u e--maybeSetUnitInfoF2 :: F.Annotated f => (a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f UA -> f UA-maybeSetUnitInfoF2 f (Just u1) (Just u2) e = setUnitInfo (f u1 u2) e-maybeSetUnitInfoF2 _ _ _ e                 = e--maybeSetUnitConstraintF2 :: F.Annotated f => (a -> b -> Constraint) -> Maybe a -> Maybe b -> f UA -> f UA-maybeSetUnitConstraintF2 f (Just u1) (Just u2) e = setConstraint (f u1 u2) e-maybeSetUnitConstraintF2 _ _ _ e                 = e---- Operate only on the blocks of a program unit, not the contained sub-programunits.-modifyPUBlocksM :: Monad m => ([F.Block a] -> m [F.Block a]) -> F.ProgramUnit a -> m (F.ProgramUnit a)-modifyPUBlocksM f pu = case pu of-  F.PUMain a s n b pus                    -> flip fmap (f b) $ \ b' -> F.PUMain a s n b' pus-  F.PUModule a s n b pus                  -> flip fmap (f b) $ \ b' -> F.PUModule a s n b' pus-  F.PUSubroutine a s r n p b subs         -> flip fmap (f b) $ \ b' -> F.PUSubroutine a s r n p b' subs-  F.PUFunction   a s r rec n p res b subs -> flip fmap (f b) $ \ b' -> F.PUFunction a s r rec n p res b' subs-  F.PUBlockData  a s n b                  -> flip fmap (f b) $ \ b' -> F.PUBlockData  a s n b'-  F.PUComment {}                          -> return pu -- no blocks-------------------------------------------------------- Fortran semantics for interpretation of constant expressions--- involving numeric literals.-data FNum = FReal Double | FInt Integer-fnumToDouble (FReal x) = x-fnumToDouble (FInt x)  = fromIntegral x--fAdd, fSub, fMul, fDiv :: FNum -> FNum -> FNum-fAdd (FReal x) fy      = FReal $ x + fnumToDouble fy-fAdd fx (FReal y)      = FReal $ fnumToDouble fx + y-fAdd (FInt x) (FInt y) = FInt  $ x + y-fSub (FReal x) fy      = FReal $ x - fnumToDouble fy-fSub fx (FReal y)      = FReal $ fnumToDouble fx - y-fSub (FInt x) (FInt y) = FInt  $ x - y-fMul (FReal x) fy      = FReal $ x * fnumToDouble fy-fMul fx (FReal y)      = FReal $ fnumToDouble fx * y-fMul (FInt x) (FInt y) = FInt  $ x * y-fDiv (FReal x) fy      = FReal $ x / fnumToDouble fy-fDiv fx (FReal y)      = FReal $ fnumToDouble fx / y-fDiv (FInt x) (FInt y) = FInt  $ x `quot` y  -- Haskell quot truncates towards zero, like Fortran-fPow (FReal x) fy      = FReal $ x ** fnumToDouble fy-fPow fx (FReal y)      = FReal $ fnumToDouble fx ** y-fPow (FInt x) (FInt y)-  | y >= 0             = FInt  $ x ^ y-  | otherwise          = FReal $ fromIntegral x ^^ y--fDivMaybe mx my-  | Just y <- my,-    fnumToDouble y == 0.0 = Nothing-  | otherwise             = liftM2 fDiv mx my---- | Statically computes if the expression is a constant value.-constantExpression :: F.Expression a -> Maybe Double-constantExpression e = fnumToDouble `fmap` ce e-  where-    ce e = case e of-      (F.ExpValue _ _ (F.ValInteger i))        -> FInt `fmap` readInteger i-      (F.ExpValue _ _ (F.ValReal r))           -> FReal `fmap` readReal r-      (F.ExpBinary _ _ F.Addition e1 e2)       -> liftM2 fAdd (ce e1) (ce e2)-      (F.ExpBinary _ _ F.Subtraction e1 e2)    -> liftM2 fSub (ce e1) (ce e2)-      (F.ExpBinary _ _ F.Multiplication e1 e2) -> liftM2 fMul (ce e1) (ce e2)-      (F.ExpBinary _ _ F.Division e1 e2)       -> fDivMaybe (ce e1) (ce e2)-      (F.ExpBinary _ _ F.Exponentiation e1 e2) -> liftM2 fPow (ce e1) (ce e2)-      -- FIXME: expand...-      _                                        -> Nothing---- | Asks the question: is the operator within the given category?-isOp :: BinOpKind -> F.BinaryOp -> Bool-isOp cat = (== cat) . binOpKind--data BinOpKind = AddOp | MulOp | DivOp | PowerOp | LogicOp | RelOp deriving Eq-binOpKind :: F.BinaryOp -> BinOpKind-binOpKind F.Addition         = AddOp-binOpKind F.Subtraction      = AddOp-binOpKind F.Multiplication   = MulOp-binOpKind F.Division         = DivOp-binOpKind F.Exponentiation   = PowerOp-binOpKind F.Concatenation    = AddOp-binOpKind F.GT               = RelOp-binOpKind F.GTE              = RelOp-binOpKind F.LT               = RelOp-binOpKind F.LTE              = RelOp-binOpKind F.EQ               = RelOp-binOpKind F.NE               = RelOp-binOpKind F.Or               = LogicOp-binOpKind F.And              = LogicOp-binOpKind F.Equivalent       = RelOp-binOpKind F.NotEquivalent    = RelOp-binOpKind (F.BinCustom _)    = RelOp------------------------------------------------------dumpConsM str = whenDebug . D.traceM . unlines . ([replicate 50 '-', str ++ ":"]++) . (++[replicate 50 '^']) . map f-  where-    f (ConEq u1 u2)  = show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)-    f (ConConj cons) = intercalate " && " (map f cons)--debugLogging :: UnitSolver ()-debugLogging = whenDebug $ do-    (tell . unlines . map (\ (ConEq u1 u2) -> "  ***AbsConstraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2) ++ "\n")) =<< extractConstraints-    pf <- gets usProgramFile-    cons <- usConstraints `fmap` get-    vum <- usVarUnitMap `fmap` get-    tell . unlines $ [ "  " ++ show info ++ " :: " ++ n | ((n, _), info) <- M.toList vum ]-    tell "\n\n"-    uam <- usUnitAliasMap `fmap` get-    tell . unlines $ [ "  " ++ n ++ " = " ++ show info | (n, info) <- M.toList uam ]-    tell . unlines $ map (\ (ConEq u1 u2) -> "  ***Constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2) ++ "\n") cons-    tell $ show cons ++ "\n\n"-    forM_ (universeBi pf) $ \ pu -> case pu of-      F.PUFunction {}-        | Just (ConConj cons) <- getConstraint pu ->-          tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> "    constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons-      F.PUSubroutine {}-        | Just (ConConj cons) <- getConstraint pu ->-          tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> "    constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons-      _ -> return ()-    let (lhsM, rhsM, _, lhsColA, rhsColA) = constraintsToMatrices cons-    tell "\n--------------------------------------------------\nLHS Cols:\n"-    tell $ show lhsColA-    tell "\n--------------------------------------------------\nRHS Cols:\n"-    tell $ show rhsColA-    tell "\n--------------------------------------------------\nLHS M:\n"-    tell $ show lhsM-    tell "\n--------------------------------------------------\nRHS M:\n"-    tell $ show rhsM-    tell "\n--------------------------------------------------\nSolved (RREF) M:\n"-    let augM = if H.rows rhsM == 0 || H.cols rhsM == 0 then lhsM else H.fromBlocks [[lhsM, rhsM]]-    tell . show . rref $ augM-    -- tell "\n--------------------------------------------------\nSolved (SVD) M:\n"-    -- tell $ show (H.linearSolveSVD lhsM rhsM)-    -- tell "\n--------------------------------------------------\nSingular Values:\n"-    -- tell $ show (H.singularValues lhsM)-    tell "\n--------------------------------------------------\n"-    tell $ "Rank LHS: " ++ show (H.rank lhsM) ++ "\n"-    tell "\n--------------------------------------------------\n"-    let augA = if H.rows rhsM == 0 || H.cols rhsM == 0 then lhsM else H.fromBlocks [[lhsM, rhsM]]-    tell $ "Rank Augmented: " ++ show (H.rank augA) ++ "\n"-    tell "\n--------------------------------------------------\nGenUnitAssignments:\n"-    let unitAssignments = genUnitAssignments cons-    tell . unlines $ map (\ (u1s, u2) -> "  ***UnitAssignment: " ++ show u1s ++ " === " ++ show (flattenUnits u2) ++ "\n") unitAssignments-    tell "\n--------------------------------------------------\n"-------------------------------------------------------- convenience-puName :: F.ProgramUnit UA -> F.Name-puName pu-  | F.Named n <- FA.puName pu = n-  | otherwise                 = "_nameless"--puSrcName :: F.ProgramUnit UA -> F.Name-puSrcName pu-  | F.Named n <- FA.puSrcName pu = n-  | otherwise                    = "_nameless"-------------------------------------------------------- | name => (return-unit, parameter-units)-intrinsicUnits :: M.Map F.Name (UnitInfo, [UnitInfo])-intrinsicUnits =-  M.fromList-    [ ("abs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("iabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("dabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("cabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("aimag", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("aint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("dint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("anint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("dnint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("cmplx", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("conjg", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("dble", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("dim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))-    , ("idim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))-    , ("ddim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))-    , ("dprod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("ceiling", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("floor", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("int", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("ifix", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("idint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("max", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))   -- special case: arbitrary # of parameters-    , ("min", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))   -- special case: arbitrary # of parameters-    , ("min0", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))  -- special case: arbitrary # of parameters-    , ("amin1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters-    , ("dmin1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters-    , ("amin0", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters-    , ("min1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))  -- special case: arbitrary # of parameters-    , ("mod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))-    , ("modulo", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))-    , ("amod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))-    , ("dmod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))-    , ("nint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("real", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("float", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("sngl", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))-    , ("sign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))-    , ("isign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))-    , ("dsign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))-    , ("present", (UnitParamEAPAbs ("'a", "'a"), [UnitlessVar]))-    , ("sqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2]))-    , ("dsqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2]))-    , ("csqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2]))-    , ("exp", (UnitlessVar, [UnitlessVar]))-    , ("dexp", (UnitlessVar, [UnitlessVar]))-    , ("cexp", (UnitlessVar, [UnitlessVar]))-    , ("alog", (UnitlessVar, [UnitlessVar]))-    , ("dlog", (UnitlessVar, [UnitlessVar]))-    , ("clog", (UnitlessVar, [UnitlessVar]))-    , ("alog10", (UnitlessVar, [UnitlessVar]))-    , ("dlog10", (UnitlessVar, [UnitlessVar]))-    , ("sin", (UnitlessVar, [UnitlessVar]))-    , ("dsin", (UnitlessVar, [UnitlessVar]))-    , ("csin", (UnitlessVar, [UnitlessVar]))-    , ("cos", (UnitlessVar, [UnitlessVar]))-    , ("dcos", (UnitlessVar, [UnitlessVar]))-    , ("ccos", (UnitlessVar, [UnitlessVar]))-    , ("tan", (UnitlessVar, [UnitlessVar]))-    , ("dtan", (UnitlessVar, [UnitlessVar]))-    , ("asin", (UnitlessVar, [UnitlessVar]))-    , ("dasin", (UnitlessVar, [UnitlessVar]))-    , ("acos", (UnitlessVar, [UnitlessVar]))-    , ("dacos", (UnitlessVar, [UnitlessVar]))-    , ("atan", (UnitlessVar, [UnitlessVar]))-    , ("datan", (UnitlessVar, [UnitlessVar]))-    , ("atan2", (UnitlessVar, [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))-    , ("datan2", (UnitlessVar, [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))-    , ("sinh", (UnitlessVar, [UnitlessVar]))-    , ("dsinh", (UnitlessVar, [UnitlessVar]))-    , ("cosh", (UnitlessVar, [UnitlessVar]))-    , ("dcosh", (UnitlessVar, [UnitlessVar]))-    , ("tanh", (UnitlessVar, [UnitlessVar]))-    , ("dtanh", (UnitlessVar, [UnitlessVar]))-    , ("iand", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))-    ]---- Others: reshape, merge need special handling
+ src/Camfort/Specification/Units/ModFile.hs view
@@ -0,0 +1,125 @@+{- |+Module      :  Camfort.Specification.Units.ModFile+Description :  Helpers for working with units-relevant ModFiles.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}++module Camfort.Specification.Units.ModFile+  (+    genUnitsModFile+  , initializeModFiles+  , runCompileUnits+  ) where++import           Control.Monad.State (get, gets, lift)+import           Data.Binary (Binary, decodeOrFail, encode)+import qualified Data.ByteString.Lazy.Char8 as LB+import           Data.Data (Data)+import           Data.Generics.Uniplate.Operations (universeBi)+import           Data.List (partition)+import qualified Data.Map.Strict            as M+import           Data.Typeable (Typeable)+import           GHC.Generics (Generic)++import qualified Language.Fortran.AST as F+import           Language.Fortran.Util.ModFile++import Camfort.Analysis (analysisModFiles)+import Camfort.Specification.Units.Annotation (UA)+import Camfort.Specification.Units.Environment (Constraint(..), foldUnits, UnitInfo(..), colSort)+import Camfort.Specification.Units.InferenceBackend (flattenConstraints, flattenUnits, genUnitAssignments, genUnitAssignments')+import Camfort.Specification.Units.Monad++-- | The data-structure stored in 'fortran-src mod files'+data CompiledUnits = CompiledUnits+  { cuTemplateMap  :: TemplateMap+  , cuNameParamMap :: NameParamMap+  } deriving (Ord, Eq, Show, Data, Typeable, Generic)++instance Binary CompiledUnits++emptyCompiledUnits :: CompiledUnits+emptyCompiledUnits = CompiledUnits M.empty M.empty++combinedCompiledUnits :: ModFiles -> CompiledUnits+combinedCompiledUnits mfs = CompiledUnits { cuTemplateMap = M.unions tmaps+                                          , cuNameParamMap = M.unions nmaps }+  where+    cus = map mfCompiledUnits mfs+    tmaps = map cuTemplateMap cus+    nmaps = map cuNameParamMap cus++-- | Name of the labeled data within a ModFile containing unit-specific info.+unitsCompiledDataLabel :: String+unitsCompiledDataLabel = "units-compiled-data"++mfCompiledUnits :: ModFile -> CompiledUnits+mfCompiledUnits mf = case lookupModFileData unitsCompiledDataLabel mf of+  Nothing -> emptyCompiledUnits+  Just bs -> case decodeOrFail (LB.fromStrict bs) of+    Left _ -> emptyCompiledUnits+    Right (_, _, cu) -> cu++-- | Initialize units-relevant ModFile information.+initializeModFiles :: UnitSolver ()+initializeModFiles = do+  mfs <- lift . lift $ analysisModFiles+  let compiledUnits = combinedCompiledUnits mfs+  modifyTemplateMap  . const . cuTemplateMap  $ compiledUnits+  modifyNameParamMap . const . cuNameParamMap $ compiledUnits++-- | Produce information for a "units-mod" file.+runCompileUnits :: UnitSolver CompiledUnits+runCompileUnits = do+  cons <- usConstraints `fmap` get++  let unitAssigns = flattenConstraints cons+  let epsilon = 0.001 -- arbitrary+  let approxEq a b = abs (b - a) < epsilon++  let variables = M.fromList [ (NPKVariable var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssigns+                                                        , k `approxEq` 1 ]++  tmap <- M.map optimiseTemplate `fmap` gets usTemplateMap+  let npm = variables++  -- D.traceM $ "npm = " ++ unlines (map show (M.toList npm))+  -- D.traceM $ "tmap = \n" ++ unlines [ f ++ "\n" ++ unlines (map show cons) | (f, cons) <- M.toList tmap ]+  pure CompiledUnits { cuTemplateMap = tmap, cuNameParamMap = variables }++optimiseTemplate cons = map (\ (l, r) -> ConEq (foldUnits l) r) optimised+  where+    unitAssigns  = genUnitAssignments' (compileColSort) cons+    unitPows     = map (fmap flattenUnits) unitAssigns+    optimised    = filter cull $ map (fmap foldUnits . shiftTerms) unitPows++    cull (lhs, _) = or [ True | (UnitPow (UnitParamPosAbs _) _) <- universeBi lhs ]++    isUnitRHS (UnitPow (UnitName _) _)        = True+    isUnitRHS (UnitPow (UnitParamEAPAbs _) _) = True+    isUnitRHS (UnitPow (UnitParamImpAbs _) _) = True+    isUnitRHS (UnitPow (UnitParamPosAbs _) _) = False+    isUnitRHS _                               = False++    negateCons = map (\ (UnitPow u k) -> UnitPow u (-k))++    shiftTerms :: ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])+    shiftTerms (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift)+      where+        (lhsOk, lhsShift) = partition (not . isUnitRHS) lhs+        (rhsOk, rhsShift) = partition isUnitRHS rhs++    compileColSort = flip colSort++-- | Generate a new ModFile containing Units information.+genUnitsModFile :: F.ProgramFile UA -> CompiledUnits -> ModFile+genUnitsModFile pf cu = alterModFileData f unitsCompiledDataLabel $ genModFile pf+  where+    f _ = Just . LB.toStrict $ encode cu
src/Camfort/Specification/Units/Monad.hs view
@@ -20,147 +20,114 @@  {- | Defines the monad for the units-of-measure modules -} module Camfort.Specification.Units.Monad-  ( UA, VV, UnitSolver, UnitOpts(..), unitOpts0, UnitLogs, UnitState(..), LiteralsOpt(..), UnitException-  , whenDebug, modifyVarUnitMap, modifyGivenVarSet, modifyUnitAliasMap+  ( UA, VV, UnitSolver, UnitOpts(..), unitOpts0, UnitState, UnitEnv(..), LiteralsOpt(..)   , VarUnitMap, GivenVarSet, UnitAliasMap, TemplateMap, CallIdMap-  , modifyTemplateMap, modifyNameParamMap, modifyProgramFile, modifyProgramFileM, modifyCallIdRemapM-  , runUnitSolver, evalUnitSolver, execUnitSolver-  , CompiledUnits(..), NameParamMap, NameParamKey(..), emptyCompiledUnits )-where+  , NameParamMap, NameParamKey(..)+    -- ** State Helpers+  , freshId+    -- *** Getters+  , getConstraints+  , getNameParamMap+  , getProgramFile+  , getTemplateMap+  , getUnitAliasMap+  , getVarUnitMap+  , usCallIdRemap+  , usConstraints+  , usGivenVarSet+  , usNameParamMap+  , usProgramFile+  , usTemplateMap+  , usUnitAliasMap+  , usVarUnitMap+    -- *** Modifiers+  , modifyCallIdRemap+  , modifyCallIdRemapM+  , modifyConstraints+  , modifyGivenVarSet+  , modifyNameParamMap+  , modifyProgramFile+  , modifyProgramFileM+  , modifyTemplateMap+  , modifyUnitAliasMap+  , modifyVarUnitMap+    -- ** Runners+  , runUnitSolver+  , runUnitAnalysis+  ) where -import Control.Monad.RWS.Strict-import Control.Monad.Trans.Except+import Control.Monad.State.Strict+import Control.Monad.Reader import Data.Binary (Binary) import Data.Typeable (Typeable) import Data.Char (toLower) import Data.Data (Data) import Data.List (find, isPrefixOf) import GHC.Generics (Generic)-import qualified Data.Map.Strict as M-import qualified Data.IntMap.Strict as IM-import qualified Data.Set as S-import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.AST as F-import Language.Fortran.Util.ModFile-import Camfort.Specification.Units.Environment (UnitInfo, Constraints(..), VV, PP)-import Camfort.Analysis.Annotations (UA)----- | Some options about how to handle literals.-data LiteralsOpt-  = LitPoly     -- ^ All literals are polymorphic.-  | LitUnitless -- ^ All literals are unitless.-  | LitMixed    -- ^ The literal "0" or "0.0" is fully parametric-                -- polymorphic. All other literals are monomorphic,-                -- possibly unitless.-  deriving (Show, Eq, Ord, Data)+import Language.Fortran.Util.ModFile (ModFiles) -instance Read LiteralsOpt where-  readsPrec _ s = case find ((`isPrefixOf` map toLower s) . fst) ms of-                    Just (str, con) -> [(con, drop (length str) s)]-                    Nothing         -> []-    where-      ms = [ ("poly", LitPoly), ("unitless", LitUnitless), ("mixed", LitMixed)-           , ("litpoly", LitPoly), ("litunitless", LitUnitless), ("litmixed", LitMixed) ]+import Camfort.Analysis+import Camfort.Input+import Camfort.Analysis.Annotations (Annotation)+import Camfort.Specification.Units.Annotation (UA)+import Camfort.Specification.Units.Environment (UnitInfo, Constraints, VV, PP) --- | Options for the unit solver-data UnitOpts = UnitOpts-  { uoDebug          :: Bool                      -- ^ debugging mode?-  , uoLiterals       :: LiteralsOpt               -- ^ how to handle literals-  , uoModFiles       :: M.Map String ModFile      -- ^ map of included modules-  }-  deriving (Show, Data, Eq, Ord)+import Camfort.Specification.Units.MonadTypes  unitOpts0 :: UnitOpts-unitOpts0 = UnitOpts False LitMixed M.empty---- | Function/subroutine name -> associated, parametric polymorphic constraints-type TemplateMap = M.Map F.Name Constraints---- | Things that can be exported from modules-data NameParamKey-  = NPKParam PP Int     -- ^ Function/subroutine name, position of parameter-  | NPKVariable VV      -- ^ variable-  deriving (Ord, Eq, Show, Data, Typeable, Generic)--instance Binary NameParamKey---- | mapped to a list of units (to be multiplied together)-type NameParamMap = M.Map NameParamKey [UnitInfo]---- | The data-structure stored in 'fortran-src mod files'-data CompiledUnits = CompiledUnits { cuTemplateMap  :: TemplateMap-                                   , cuNameParamMap :: NameParamMap }-  deriving (Ord, Eq, Show, Data, Typeable, Generic)--instance Binary CompiledUnits--emptyCompiledUnits :: CompiledUnits-emptyCompiledUnits = CompiledUnits M.empty M.empty-------------------------------------------------------- | The monad-type UnitSolver a = ExceptT UnitException (RWS UnitOpts UnitLogs UnitState) a+unitOpts0 = UnitOpts LitMixed  -------------------------------------------------- --- Not in use, but might be useful someday.-type UnitException = ()----------------------------------------------------+unitState0 :: F.ProgramFile UA -> UnitState+unitState0 pf = UnitState { usProgramFile  = pf+                          , usVarUnitMap   = mempty+                          , usGivenVarSet  = mempty+                          , usUnitAliasMap = mempty+                          , usTemplateMap  = mempty+                          , usNameParamMap = mempty+                          , usNextUnique   = 0+                          , usCallIdRemap  = mempty+                          , usConstraints  = [] } --- Read-only options for the unit solver.+-- helper functions --- | Only run the argument if debugging mode enabled.-whenDebug :: UnitSolver () -> UnitSolver ()-whenDebug m = fmap uoDebug ask >>= \ d -> when d m+-- | Generate a number guaranteed to be unique in the current analysis.+freshId :: UnitSolver Int+freshId = do+  s <- get+  let i = usNextUnique s+  put $ s { usNextUnique = i + 1 }+  pure i ---------------------------------------------------+getConstraints :: UnitSolver Constraints+getConstraints = gets usConstraints --- Track some logging information in the monad.-type UnitLogs = String+getNameParamMap :: UnitSolver NameParamMap+getNameParamMap = gets usNameParamMap ---------------------------------------------------+getProgramFile :: UnitSolver (F.ProgramFile UA)+getProgramFile = gets usProgramFile --- | Variable => unit-type VarUnitMap   = M.Map VV UnitInfo--- | Set of variables given explicit unit annotations-type GivenVarSet  = S.Set F.Name--- | Alias name => definition-type UnitAliasMap = M.Map String UnitInfo--- | Map of CallId to CallId-type CallIdMap    = IM.IntMap Int+getTemplateMap :: UnitSolver TemplateMap+getTemplateMap = gets usTemplateMap --- | Working state for the monad-data UnitState = UnitState-  { usProgramFile  :: F.ProgramFile UA-  , usVarUnitMap   :: VarUnitMap-  , usGivenVarSet  :: GivenVarSet-  , usUnitAliasMap :: UnitAliasMap-  , usTemplateMap  :: TemplateMap-  , usNameParamMap :: NameParamMap-  , usLitNums      :: Int-  , usCallIds      :: Int-  , usCallIdRemap  :: CallIdMap-  , usConstraints  :: Constraints }-  deriving (Show, Data)+getUnitAliasMap :: UnitSolver UnitAliasMap+getUnitAliasMap = gets usUnitAliasMap -unitState0 pf = UnitState { usProgramFile  = pf-                          , usVarUnitMap   = M.empty-                          , usGivenVarSet  = S.empty-                          , usUnitAliasMap = M.empty-                          , usTemplateMap  = M.empty-                          , usNameParamMap = M.empty-                          , usLitNums      = 0-                          , usCallIds      = 0-                          , usCallIdRemap  = IM.empty-                          , usConstraints  = [] }+getVarUnitMap :: UnitSolver VarUnitMap+getVarUnitMap = gets usVarUnitMap --- helper functions modifyVarUnitMap :: (VarUnitMap -> VarUnitMap) -> UnitSolver () modifyVarUnitMap f = modify (\ s -> s { usVarUnitMap = f (usVarUnitMap s) }) +modifyCallIdRemap :: (CallIdMap -> CallIdMap) -> UnitSolver ()+modifyCallIdRemap f = modify (\ s -> s { usCallIdRemap = f (usCallIdRemap s) })++modifyConstraints :: (Constraints -> Constraints) -> UnitSolver ()+modifyConstraints f = modify (\ s -> s { usConstraints = f (usConstraints s) })+ modifyGivenVarSet :: (GivenVarSet -> GivenVarSet) -> UnitSolver () modifyGivenVarSet f = modify (\ s -> s { usGivenVarSet = f (usGivenVarSet s) }) @@ -186,19 +153,15 @@ modifyCallIdRemapM f = do   idMap <- gets usCallIdRemap   (x, idMap') <- f idMap-  modify (\ s -> s { usCallIdRemap = idMap' })+  modifyCallIdRemap (const idMap')   return x  -------------------------------------------------- --- | Run the unit solver monad.-runUnitSolver :: UnitOpts -> F.ProgramFile UA -> UnitSolver a -> (Either UnitException a, UnitState, UnitLogs)-runUnitSolver o pf m = runRWS (runExceptT m) o (unitState0 pf)--evalUnitSolver :: UnitOpts -> F.ProgramFile UA -> UnitSolver a -> (Either UnitException a, UnitLogs)-evalUnitSolver o pf m = (ea, l) where (ea, _, l) = runUnitSolver o pf m+-- | Runs the stateful part of the unit solver.+runUnitSolver :: F.ProgramFile UA -> UnitSolver a -> UnitAnalysis (a, UnitState)+runUnitSolver pf solver = do+  runStateT solver (unitState0 pf) -execUnitSolver :: UnitOpts -> F.ProgramFile UA -> UnitSolver a -> Either UnitException (UnitState, UnitLogs)-execUnitSolver o pf m = case runUnitSolver o pf m of-  (Left e, _, _)  -> Left e-  (Right _, s, l) -> Right (s, l)+runUnitAnalysis :: UnitEnv -> UnitAnalysis a -> AnalysisT () () IO a+runUnitAnalysis env = flip runReaderT env
+ src/Camfort/Specification/Units/MonadTypes.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}++module Camfort.Specification.Units.MonadTypes where++import           Control.Monad.Reader+import           Control.Monad.State.Strict+import           Data.Binary                             (Binary)+import           Data.Char                               (toLower)+import           Data.Data                               (Data)+import qualified Data.IntMap.Strict                      as IM+import           Data.List                               (find, isPrefixOf)+import qualified Data.Map.Strict                         as M+import qualified Data.Set                                as S+import           Data.Typeable                           (Typeable)+import           GHC.Generics                            (Generic)+import qualified Language.Fortran.AST                    as F+import           Language.Fortran.Util.ModFile           (ModFiles)++import           Camfort.Analysis+import           Camfort.Analysis.Annotations            (Annotation)+import           Camfort.Input+import           Camfort.Specification.Units.Annotation  (UA)+import           Camfort.Specification.Units.Environment (Constraints, PP,+                                                          UnitInfo, VV)++--------------------------------------------------------------------------------+--  Environment+--------------------------------------------------------------------------------++-- | Some options about how to handle literals.+data LiteralsOpt+  = LitPoly     -- ^ All literals are polymorphic.+  | LitUnitless -- ^ All literals are unitless.+  | LitMixed    -- ^ The literal "0" or "0.0" is fully parametric+                -- polymorphic. All other literals are monomorphic,+                -- possibly unitless.+  deriving (Show, Eq, Ord, Data)++instance Read LiteralsOpt where+  readsPrec _ s = case find ((`isPrefixOf` map toLower s) . fst) ms of+                    Just (str, con) -> [(con, drop (length str) s)]+                    Nothing         -> []+    where+      ms = [ ("poly", LitPoly), ("unitless", LitUnitless), ("mixed", LitMixed)+           , ("litpoly", LitPoly), ("litunitless", LitUnitless), ("litmixed", LitMixed) ]++-- | Options for the unit solver+data UnitOpts = UnitOpts+  { uoLiterals :: LiteralsOpt               -- ^ how to handle literals+  }+  deriving (Show, Data, Eq, Ord)++data UnitEnv = UnitEnv+  { unitOpts     :: UnitOpts+  , unitProgramFile :: F.ProgramFile Annotation+  }++--------------------------------------------------------------------------------+--  State+--------------------------------------------------------------------------------++-- | Function/subroutine name -> associated, parametric polymorphic constraints+type TemplateMap = M.Map F.Name Constraints++-- | Things that can be exported from modules+data NameParamKey+  = NPKParam PP Int     -- ^ Function/subroutine name, position of parameter+  | NPKVariable VV      -- ^ variable+  deriving (Ord, Eq, Show, Data, Typeable, Generic)++instance Binary NameParamKey++-- | mapped to a list of units (to be multiplied together)+type NameParamMap = M.Map NameParamKey [UnitInfo]++-- | Variable => unit+type VarUnitMap   = M.Map VV UnitInfo+-- | Set of variables given explicit unit annotations+type GivenVarSet  = S.Set F.Name+-- | Alias name => definition+type UnitAliasMap = M.Map String UnitInfo+-- | Map of CallId to CallId+type CallIdMap    = IM.IntMap Int++-- | Working state for the monad+data UnitState = UnitState+  { usProgramFile  :: F.ProgramFile UA+  , usVarUnitMap   :: VarUnitMap+  , usGivenVarSet  :: GivenVarSet+  , usUnitAliasMap :: UnitAliasMap+  , usTemplateMap  :: TemplateMap+  , usNameParamMap :: NameParamMap+  , usCallIdRemap  :: CallIdMap+    -- | Next number to returned by 'freshId'.+  , usNextUnique   :: Int+  , usConstraints  :: Constraints }+  deriving (Show, Data)++--------------------------------------------------------------------------------+--  Monads+--------------------------------------------------------------------------------++-- | Analysis with access to 'UnitEnv' information.+type UnitAnalysis = ReaderT UnitEnv (AnalysisT () () IO)++-- | UnitSolvers are analyses annotated with unit information.+type UnitSolver = StateT UnitState UnitAnalysis
src/Camfort/Specification/Units/Synthesis.hs view
@@ -29,10 +29,12 @@ import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Util.Position as FU -import Camfort.Analysis.Annotations hiding (Unitless)-import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.Monad-import Camfort.Specification.Units.InferenceFrontend (puName, puSrcName)+import           Camfort.Analysis.Annotations hiding (Unitless)+import           Camfort.Specification.Units.Analysis (puName, puSrcName)+import           Camfort.Specification.Units.Annotation (UA)+import qualified Camfort.Specification.Units.Annotation as UA+import           Camfort.Specification.Units.Environment+import           Camfort.Specification.Units.Monad  -- | Insert unit declarations into the ProgramFile as comments. runSynthesis :: Char -> [(VV, UnitInfo)] -> UnitSolver [(VV, UnitInfo)]@@ -59,8 +61,8 @@       | vname `S.notMember` gvSet                     -- not a member of the already-given variables       , Just u <- lookup (vname, sname) vars -> do    -- and a unit has been inferred         -- Create new annotation which labels this as a refactored node.-        let newA  = a { FA.prevAnnotation = (FA.prevAnnotation a) {-                           prevAnnotation = (prevAnnotation (FA.prevAnnotation a)) {+        let newA  = a { FA.prevAnnotation    = (FA.prevAnnotation a) {+                           UA.prevAnnotation = (UA.prevAnnotation (FA.prevAnnotation a)) {                                refactored = Just lp } } }             -- Create a zero-length span for the new comment node.             newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0})@@ -96,7 +98,7 @@     -- if return var has a unit & not a member of the already-given variables     Just u | vname `S.notMember` gvSet -> do       let newA  = a { FA.prevAnnotation = (FA.prevAnnotation a) {-                         prevAnnotation = (prevAnnotation (FA.prevAnnotation a)) {+                         UA.prevAnnotation = (UA.prevAnnotation (FA.prevAnnotation a)) {                              refactored = Just lp } } }       -- Create a zero-length span for the new comment node.       let newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0})
src/Camfort/Transformation/CommonBlockElim.hs view
@@ -27,6 +27,7 @@ import Control.Monad.Writer.Strict (execWriter, tell)  import Data.Data+import Data.Void import Data.Function (on) import Data.List import qualified Data.Map as M@@ -39,6 +40,7 @@ import qualified Language.Fortran.ParserMonad as PM import qualified Language.Fortran.PrettyPrint as PP +import Camfort.Analysis import Camfort.Helpers import Camfort.Helpers.Syntax import Camfort.Analysis.Annotations@@ -58,7 +60,7 @@ type TLCommon p = (Filename, (F.Name, TCommon p))  type A1 = FA.Analysis Annotation-type CommonState = State (Report, [TLCommon A])+type CommonState = State (String, [TLCommon A])  -- | Type for type-level annotations giving documentation type (:?) a (b :: k) = a@@ -67,16 +69,17 @@ commonElimToModules ::        Directory     -> [F.ProgramFile A]-    -> (Report, [F.ProgramFile A], [F.ProgramFile A])+    -> PureAnalysis Void Void ([F.ProgramFile A], [F.ProgramFile A])  -- Eliminates common blocks in a program directory (and convert to modules)-commonElimToModules d pfs =-    (r ++ r', pfs'', pfM)+commonElimToModules d pfs = do+  let (pfs', (r, cg)) = runState (analyseAndRmCommons pfs) ("", [])+      (r', pfM)       = introduceModules meta d cg+      pfs''           = updateUseDecls pfs' cg+  logDebug' pfs $ describe $ r ++ r'+  pure (pfs'', pfM)   where-    (pfs', (r, cg)) = runState (analyseAndRmCommons pfs) ("", [])     meta = F.MetaInfo PM.Fortran90 ""-    (r', pfM) = introduceModules meta d cg-    pfs'' = updateUseDecls pfs' cg  analyseAndRmCommons :: [F.ProgramFile A]                -> CommonState [F.ProgramFile A]@@ -232,7 +235,7 @@     tcrs = mkTLCommonRenamers tcs      inames :: F.Statement A -> Maybe String-    inames (F.StInclude _ _ (F.ExpValue _ _ (F.ValString fname))) = Just fname+    inames (F.StInclude _ _ (F.ExpValue _ _ (F.ValString fname)) _) = Just fname     inames _ = Nothing      importIncludeCommons :: PM.FortranVersion -> F.ProgramUnit A -> F.ProgramUnit A@@ -395,7 +398,7 @@              typR = if ty1  ==  ty2 then Nothing else Just (ty1, ty2)         generate _ _ _ = error "Common blocks of different field length\n" -allCoherentCommons :: [TLCommon A] -> (Report, Bool)+allCoherentCommons :: [TLCommon A] -> (String, Bool) allCoherentCommons commons =    foldM (\p (c1, c2) -> coherentCommons c1 c2 >>= \p' -> return $ p && p')      True (pairs commons)@@ -406,14 +409,14 @@     pairs (x:xs) = zip (repeat x) xs ++ pairs xs  -coherentCommons :: TLCommon A -> TLCommon A -> (Report, Bool)+coherentCommons :: TLCommon A -> TLCommon A -> (String, Bool) coherentCommons (_, (_, (n1, vtys1))) (_, (_, (n2, vtys2))) =     if n1 == n2     then coherentCommons' vtys1 vtys2     else error $ "Trying to compare differently named common blocks: "                ++ show n1 ++ " and " ++ show n2 ++ "\n" -coherentCommons' ::  [(F.Name, F.BaseType)] -> [(F.Name, F.BaseType)] -> (Report, Bool)+coherentCommons' ::  [(F.Name, F.BaseType)] -> [(F.Name, F.BaseType)] -> (String, Bool) coherentCommons' []               []                = ("", True) coherentCommons' ((var1, ty1):xs) ((var2, ty2):ys)       | af ty1 == af ty2 = let (r', c) = coherentCommons' xs ys@@ -432,12 +435,12 @@ introduceModules :: F.MetaInfo                  -> Directory                  -> [TLCommon A]-                 -> (Report, [F.ProgramFile A])+                 -> (String, [F.ProgramFile A]) introduceModules meta dir cenv =     mapM (mkModuleFile meta dir . head . head) (groupSortCommonBlock cenv)  mkModuleFile ::-  F.MetaInfo -> Directory -> TLCommon A -> (Report, F.ProgramFile A)+  F.MetaInfo -> Directory -> TLCommon A -> (String, F.ProgramFile A) mkModuleFile meta dir (_, (_, (name, varTys))) =     (r, F.pfSetFilename path $ F.ProgramFile meta [mod])   where
src/Camfort/Transformation/DeadCode.hs view
@@ -15,11 +15,13 @@ -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}  module Camfort.Transformation.DeadCode   ( deadCode   ) where +import Camfort.Analysis import Camfort.Analysis.Annotations import qualified Language.Fortran.Analysis.DataFlow as FAD import qualified Language.Fortran.Analysis.Renaming as FAR@@ -27,24 +29,28 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Util.Position as FU import qualified Language.Fortran.Analysis as FA-import Camfort.Helpers import Camfort.Helpers.Syntax  import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Generics.Uniplate.Operations import Data.Maybe+import Control.Monad (guard)+import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)+import Data.Monoid (Any(..), (<>))+import Data.Void (Void) +type DeadCodeAnalysis = PureAnalysis Void Void + -- Eliminate dead code from a program, based on the fortran-src -- live-variable analysis  -- Currently only strips out dead code through simple variable assignments -- but not through array-subscript assignmernts-deadCode :: Bool -> F.ProgramFile A -> (Report, F.ProgramFile A)-deadCode flag pf = (report, fmap FA.prevAnnotation pf')-  where-    (report, _) = deadCode' flag lva pf'+deadCode :: Bool -> F.ProgramFile A -> DeadCodeAnalysis (F.ProgramFile A)+deadCode flag pf = do+  let     -- initialise analysis     pf'   = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ pf     -- get map of program unit ==> basic block graph@@ -56,32 +62,34 @@     -- live variables     lva   = FAD.liveVariableAnalysis gr +  deadCode' flag lva pf'+  pure $ fmap FA.prevAnnotation pf'+ deadCode' :: Bool -> FAD.InOutMap (S.Set F.Name)                   -> F.ProgramFile (FA.Analysis A)-                  -> (Report, F.ProgramFile (FA.Analysis A))-deadCode' flag lva pf =-    if null report-      then (report, pf')-      else (report, pf') >>= deadCode' flag lva-  where-    (report, pf') = transformBiM (perStmt flag lva) pf+                  -> DeadCodeAnalysis (F.ProgramFile (FA.Analysis A))+deadCode' flag lva pf = do+  (pf', Any eliminated) <- runWriterT $ transformBiM (perStmt flag lva) pf+  if eliminated+    then deadCode' flag lva pf'+    else return pf'  -- Core of the transformation happens here on assignment statements perStmt :: Bool         -> FAD.InOutMap (S.Set F.Name)-        -> F.Statement (FA.Analysis A) -> (Report, F.Statement (FA.Analysis A))+        -> F.Statement (FA.Analysis A) -> WriterT Any DeadCodeAnalysis (F.Statement (FA.Analysis A)) perStmt flag lva x@(F.StExpressionAssign a sp@(FU.SrcSpan s1 _) e1 e2)      | pRefactored (FA.prevAnnotation a) == flag =-  fromMaybe ("", x) $-    do label <- FA.insLabel a-       (_, out) <- IM.lookup label lva-       assignedName <- extractVariable e1-       if assignedName `S.member` out-         then Nothing-         else -- Dead assignment-           Just (report, F.StExpressionAssign a' (dropLine sp) e1 e2)-             where report =  "o" ++ show s1 ++ ": removed dead code\n"-                   -- Set annotation to mark statement for elimination in-                   -- the reprinter-                   a' = onPrev (\ap -> ap {refactored = Just s1}) a+       let output = do+             logInfo' x $ "o" <> describe (show s1) <> ": removed dead code"+             tell (Any True)+             return $ F.StExpressionAssign a' (dropLine sp) e1 e2+               where a' = onPrev (\ap -> ap {refactored = Just s1}) a+                    -- Set annotation to mark statement for elimination in+                    -- the reprinter+       in maybe (return x) (const output) $ do+         label <- FA.insLabel a+         (_, out) <- IM.lookup label lva+         assignedName <- extractVariable e1+         guard (not (assignedName `S.member` out)) perStmt _ _ x = return x
src/Camfort/Transformation/EquivalenceElim.hs view
@@ -15,12 +15,14 @@ -} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}  module Camfort.Transformation.EquivalenceElim   ( refactorEquivalences   ) where  import Data.List+import Data.Void (Void) import qualified Data.Map as M import Data.Generics.Uniplate.Operations import Control.Monad.State.Lazy@@ -31,42 +33,50 @@ import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis as FA -import Camfort.Helpers+import Camfort.Analysis import Camfort.Helpers.Syntax import Camfort.Analysis.Annotations import Camfort.Transformation.DeadCode +type EquivalenceRefactoring = PureAnalysis Void Void  type A1 = FA.Analysis Annotation-type RmEqState = ([[F.Expression A1]], Int, Report)+type RmEqState = ([[F.Expression A1]], Int) -refactorEquivalences :: F.ProgramFile A -> (Report, F.ProgramFile A)+refactorEquivalences :: F.ProgramFile A -> EquivalenceRefactoring (F.ProgramFile A) refactorEquivalences pf = do-   -- initialise analysis-   let pf'   = FAR.analyseRenames . FA.initAnalysis $ pf-   -- calculate types-   let (pf'', typeEnv) = FAT.analyseTypes pf'-   -- Remove equivalences and add appropriate copy statements-   pf''' <- refactoring typeEnv pf''-   -- Lastly deadcode eliminate any redundant copy statements-   -- generated by the refactoring (but don't dead code elim-   -- existing code)-   deadCode True (fmap FA.prevAnnotation pf''')+  let+    -- initialise analysis+    pf'             = FAR.analyseRenames . FA.initAnalysis $ pf+    -- calculate types+    (pf'', typeEnv) = FAT.analyseTypes pf'+    -- Remove equivalences and add appropriate copy statements+  pf''' <- refactoring typeEnv pf''+  -- Lastly deadcode eliminate any redundant copy statements+  -- generated by the refactoring (but don't dead code elim+  -- existing code)+  deadCode True (fmap FA.prevAnnotation pf''')   where-    refactoring :: FAT.TypeEnv -> F.ProgramFile A1 -> (Report, F.ProgramFile A1)-    refactoring tenv pf = (report, pf')+    refactoring+      :: FAT.TypeEnv -> F.ProgramFile A1+      -> EquivalenceRefactoring (F.ProgramFile A1)+    refactoring tenv pf = do+      (pf', _) <- runStateT equiv ([], 0)+      return pf'       where-         (pf', (_, _, report)) = runState equiv ([], 0, "")-          equiv = do pf' <- transformBiM perBlockRmEquiv pf                     descendBiM (addCopysPerBlockGroup tenv) pf' -addCopysPerBlockGroup :: FAT.TypeEnv -> [F.Block A1] -> State RmEqState [F.Block A1]+addCopysPerBlockGroup+  :: FAT.TypeEnv -> [F.Block A1]+  -> StateT RmEqState EquivalenceRefactoring [F.Block A1] addCopysPerBlockGroup tenv blocks = do     blockss <- mapM (addCopysPerBlock tenv) blocks     return $ concat blockss -addCopysPerBlock :: FAT.TypeEnv -> F.Block A1 -> State RmEqState [F.Block A1]+addCopysPerBlock+  :: FAT.TypeEnv -> F.Block A1+  -> StateT RmEqState EquivalenceRefactoring [F.Block A1] addCopysPerBlock tenv x@(F.BlStatement _ _ _                  (F.StExpressionAssign a sp@(FU.SrcSpan s1 _) dstE _))   | not (pRefactored $ FA.prevAnnotation a) = do@@ -78,7 +88,7 @@       then return [x]     -- If there are more than one, copy statements must be generated       else do-        (equivs, n, r) <- get+        (equivs, n) <- get          -- Remove the destination from the equivalents         let eqs' = deleteBy (\x y -> af x == af y) dstE eqs@@ -87,14 +97,17 @@         let pos = afterAligned sp         let copies = map (mkCopy tenv pos dstE) eqs' -        -- Reporting-        let (FU.Position _ c l) = s1-        let reportF i = show (l + i) ++ ":" ++ show c-                    ++ ": added copy due to refactored equivalence\n"-        let report n = concatMap reportF [n..(n + length copies - 1)]+        let (FU.Position ao c l) = s1+            reportSpan i =+              let pos = FU.Position (ao + i) c (l + i)+              in (FU.SrcSpan pos pos) +        forM_ [n..(n + length copies - 1)] $ \i -> do+          origin <- atSpanned (reportSpan i)+          logInfo origin $ "added copy due to refactored equivalence"+         -- Update refactoring state-        put (equivs, n + length eqs', r ++ report n)+        put (equivs, n + length eqs')         -- Sequence original assignment with new assignments         return $ x : copies @@ -140,23 +153,30 @@      dstE' = FA.stripAnalysis dstE      srcE' = FA.stripAnalysis srcE -perBlockRmEquiv :: F.Block A1 -> State RmEqState (F.Block A1)+perBlockRmEquiv :: F.Block A1 -> StateT RmEqState EquivalenceRefactoring (F.Block A1) perBlockRmEquiv = transformBiM perStatementRmEquiv -perStatementRmEquiv :: F.Statement A1 -> State RmEqState (F.Statement A1)-perStatementRmEquiv (F.StEquivalence a sp@(FU.SrcSpan spL _) equivs) = do-    (ess, n, r) <- get-    let report = r ++ show spL ++ ": removed equivalence \n"-    put (((map F.aStrip) . F.aStrip $ equivs) ++ ess, n - 1, r ++ report)+perStatementRmEquiv+  :: F.Statement A1+  -> StateT RmEqState EquivalenceRefactoring (F.Statement A1)+perStatementRmEquiv x@(F.StEquivalence a sp@(FU.SrcSpan spL _) equivs) = do+    (ess, n) <- get++    let spL' = FU.SrcSpan spL spL+    logInfo' spL' $ "removed equivalence"++    put (((map F.aStrip) . F.aStrip $ equivs) ++ ess, n - 1)     let a' = onPrev (\ap -> ap {refactored = Just spL, deleteNode = True}) a     return (F.StEquivalence a' (deleteLine sp) equivs) perStatementRmEquiv f = return f  -- 'equivalents e' returns a list of variables/memory cells -- that have been equivalenced with "e".-equivalentsToExpr :: F.Expression A1 -> State RmEqState [F.Expression A1]+equivalentsToExpr+  :: F.Expression A1+  -> StateT RmEqState EquivalenceRefactoring [F.Expression A1] equivalentsToExpr x = do-    (equivs, _, _) <- get+    (equivs, _) <- get     return (inGroup x equivs)   where     inGroup _ [] = []
+ src/Language/Fortran/Model.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS_GHC -Wall #-}++{-|++An embedding of Fortran expressions into strongly-typed Haskell values, and+facilities for reasoning about them.++-}++module Language.Fortran.Model+  (+  {-|+  Each Fortran type gets a corresponding Haskell type.+  -}+    module Language.Fortran.Model.Types++  {-|+  The Fortran expressions that can be formed are specified at the type level.+  -}+  , module Language.Fortran.Model.Op+++  {-|+  Fortran values and expressions are represented symbolically, in a form that+  can be easily used in external theorem-provers via "Data.SBV".+  -}+  , module Language.Fortran.Model.Repr+  ) where++import Language.Fortran.Model.Types+import Language.Fortran.Model.Op+import Language.Fortran.Model.Repr
+ src/Language/Fortran/Model/Op.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -Wall #-}++{-|++The root module for the language of Fortran operators.++"Language.Expression" provides a way of forming expressions from what we call+/operators/, via 'HFree'.++For any type constructor @op@ of kind @(* -> *) -> * -> *@, @'HFree' op v a@ can+be seen as an /expression/ over @op@. @op@ defines how we may combine different+expressions. This is best illustrated with a simple example.++@+-- An operator type has two arguments. @t@ is a type constructor used to refer+-- to expressions. @a@ is the semantic type of the expression formed by the+-- operator.+data SimpleOp t a where+  -- Given two int expressions, we may add them. Notice how we refer to+  -- expressions recursively with the type constructor parameter @t@.+  Add :: t Int -> t Int -> SimpleOp t Int++  -- An operator does not have to actually combine expressions. It may produce+  -- an expression from a basic value, i.e. a literal int.+  Literal :: Int -> SimpleOp t Int+@+++These modules define+operators designed to be used as the higher-ranked functors for the+higher-ranked free monads defined in "Language.Expression". For example,+@'HFree' 'CoreOp' v a@ is an expression over core Fortran operators with+variables in @v@ representing a computation of type @a@.++-}+module Language.Fortran.Model.Op+  (+    -- * Core Fortran operators++    {-|+    \'Core\' Fortran operators, that is operators that directly represent parts of +    -}++    module Language.Fortran.Model.Op.Core+    -- * Meta-level Fortran operators+  , module Language.Fortran.Model.Op.Meta+    -- * High-level operators+  , module Language.Fortran.Model.Op.High+  ) where+++import           Language.Fortran.Model.Op.Core+import           Language.Fortran.Model.Op.High+import           Language.Fortran.Model.Op.Meta
+ src/Language/Fortran/Model/Op/Core.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -Wall #-}++{-|+Actual Fortran language operators. For expressions over normal Fortran values+that are actually representable in Fortran.+++, -, *, /, read array, etc...+-}+module Language.Fortran.Model.Op.Core+  (+    CoreOp(..)+  , Op(..)+  , OpKind(..)+  , OpSpec(..)+  ) where++import           Data.Functor.Compose++import           Data.Singletons.Prelude.List+import           Data.Singletons.TypeLits++import           Data.Vinyl+import           Data.Vinyl.Curry++import           Language.Expression+import           Language.Expression.Pretty++import           Language.Fortran.Model.Repr+import           Language.Fortran.Model.Op.Core.Core+import           Language.Fortran.Model.Op.Core.Eval+import           Language.Fortran.Model.Singletons+import           Language.Fortran.Model.Types+++data CoreOp t a where+  CoreOp+    :: Op (Length args) ok+    -> OpSpec ok args result+    -> Rec t args+    -> CoreOp t result++instance HFunctor CoreOp where+instance HTraversable CoreOp where+  htraverse f (CoreOp op opr args) = CoreOp op opr <$> rtraverse f args++instance (MonadEvalFortran r m) => HFoldableAt (Compose m CoreRepr) CoreOp where+  hfoldMap = implHfoldMapCompose $ \(CoreOp op opr args) -> evalCoreOp op opr args++instance (MonadEvalFortran r m) => HFoldableAt (Compose m HighRepr) CoreOp where+  hfoldMap = implHfoldMapCompose $ fmap HRCore . hfoldA .+    hmap (\case+               HRCore x -> x+               HRHigh _ -> error "impossible")++instance Pretty2 CoreOp where+  prettys2Prec p (CoreOp op opr args) = prettysPrecOp p opr op args++showsPrim :: Prim p k a -> a -> ShowS+showsPrim = \case+  PInt8   -> shows+  PInt16  -> shows+  PInt32  -> shows+  PInt64  -> shows+  PBool8  -> shows+  PBool16 -> shows+  PBool32 -> shows+  PBool64 -> shows+  PFloat  -> shows+  PDouble -> shows+  PChar   -> shows++prettysPrecOp+  :: Pretty1 t+  => Int+  -> OpSpec ok args result+  -> Op (Length args) ok+  -> Rec t args -> ShowS+prettysPrecOp p = \case+  OSLit px x -> \case+    OpLit -> runcurry $ showsPrim px x+  OSNum1 _ _ _ -> \case+    OpNeg -> runcurry $ prettys1PrecUnop 8 "-" p+    OpPos -> runcurry $ prettys1PrecUnop 8 "+" p+  OSNum2 _ _ _ _ _ -> \case+    OpAdd -> runcurry $ prettys1PrecBinop 5 " + " p+    OpSub -> runcurry $ prettys1PrecBinop 5 " - " p+    OpMul -> runcurry $ prettys1PrecBinop 6 " * " p+    OpDiv -> runcurry $ prettys1PrecBinop 6 " / " p+  OSLogical1 _ _ -> \case+    OpNot -> runcurry $ prettys1PrecUnop 8 "!" p+  OSLogical2 _ _ _ -> \case+    OpAnd      -> runcurry $ prettys1PrecBinop 3 " && " p+    OpOr       -> runcurry $ prettys1PrecBinop 2 " || " p+    OpEquiv    -> runcurry $ prettys1PrecBinop 1 " <=> " p+    OpNotEquiv -> runcurry $ prettys1PrecBinop 1 " </=> " p+  OSEq _ _ _ _ -> \case+    OpEq -> runcurry $ prettys1PrecBinop 4 " = " p+    OpNE -> runcurry $ prettys1PrecBinop 4 " /= " p+  OSRel _ _ _ _ -> \case+    OpLT -> runcurry $ prettys1PrecBinop 4 " < " p+    OpLE -> runcurry $ prettys1PrecBinop 4 " <= " p+    OpGT -> runcurry $ prettys1PrecBinop 4 " > " p+    OpGE -> runcurry $ prettys1PrecBinop 4 " >= " p+  OSLookup _ -> \case+    OpLookup ->+      runcurry $ \arr i ->+      showParen (p > 9) $ prettys1Prec 10 arr .+                          showString "[" . prettys1Prec 0 i .+                          showString "]"+  OSDeref _ fname -> \case+    OpDeref -> runcurry $ \r ->+      showParen (p > 9) $ prettys1Prec 10 r .+      showString "%" .+      showString (withKnownSymbol fname (symbolVal fname))++-- TODO: HEq instance++-- instance HEq CoreOp where+--   liftHEq he le (CoreOp op1 opr1 args1) (CoreOp op2 opr2 args2) =+--     eqOp op1 op2 &&+--     eqOpR opr1 opr2 &&+--     liftEqRec (he _) args1 args2
+ src/Language/Fortran/Model/Op/Core/Core.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}++{-# OPTIONS_GHC -Wall      #-}++-- TODO: Function calls+module Language.Fortran.Model.Op.Core.Core where++import           Data.Singletons.TypeLits++import           Data.Vinyl++import           Language.Fortran.Model.Singletons+import           Language.Fortran.Model.Types++--------------------------------------------------------------------------------+--  Closed Typeclasses on BasicTypes+--------------------------------------------------------------------------------++data NumericBasicType k where+  NBTInt :: NumericBasicType 'BTInt+  NBTReal :: NumericBasicType 'BTReal++data ComparableBasicTypes k1 k2 where+  CBTNum :: NumericBasicType k1 -> NumericBasicType k2 -> ComparableBasicTypes k1 k2+  CBTBool :: ComparableBasicTypes 'BTLogical 'BTLogical+  CBTChar :: ComparableBasicTypes 'BTChar 'BTChar++--------------------------------------------------------------------------------+--  Operator Result Types+--------------------------------------------------------------------------------++data OpSpec ok args result where+  -- TODO: non-primitive literals (initialization)+  OSLit+    :: Prim p k a+    -> a+    -> OpSpec 'OKLit '[] (PrimS a)++  OSNum1+    :: NumericBasicType k1+    -> Prim p1 k1 a+    -> Prim p2 k2 b+    -> OpSpec 'OKNum '[PrimS a] (PrimS b)++  OSNum2+    :: NumericBasicType k1 -> NumericBasicType k2+    -> Prim p1 k1 a -> Prim p2 k2 b+    -> Prim (PrecMax p1 p2) (BasicTypeMax k1 k2) c+    -> OpSpec 'OKNum '[PrimS a, PrimS b] (PrimS c)++  OSLogical1+    :: Prim p1 'BTLogical a+    -> Prim 'P8 'BTLogical b+    -> OpSpec 'OKLogical '[PrimS a] (PrimS b)++  OSLogical2+    :: Prim p1 'BTLogical a+    -> Prim p2 'BTLogical b+    -> Prim 'P8 'BTLogical c+    -> OpSpec 'OKLogical '[PrimS a, PrimS b] (PrimS c)++  OSEq+    :: ComparableBasicTypes k1 k2+    -> Prim p1 k1 a -> Prim p2 k2 b+    -> Prim 'P8 'BTLogical c+    -> OpSpec 'OKEq '[PrimS a, PrimS b] (PrimS c)++  OSRel+    :: ComparableBasicTypes k1 k2+    -> Prim p1 k1 a -> Prim p2 k2 b+    -> Prim 'P8 'BTLogical c+    -> OpSpec 'OKRel '[PrimS a, PrimS b] (PrimS c)++  OSLookup+    :: D (Array i v)+    -> OpSpec 'OKLookup '[Array i v, i] v++  OSDeref+    :: RElem '(fname, a) fields i+    => D (Record rname fields)+    -> SSymbol fname+    -> OpSpec 'OKDeref '[Record rname fields] a++--------------------------------------------------------------------------------+--  Specific Operators+--------------------------------------------------------------------------------++data Op n ok where+  OpLit       :: Op 0 'OKLit++  OpNeg       :: Op 1 'OKNum+  OpPos       :: Op 1 'OKNum++  OpAdd       :: Op 2 'OKNum+  OpSub       :: Op 2 'OKNum+  OpMul       :: Op 2 'OKNum+  OpDiv       :: Op 2 'OKNum++  OpEq        :: Op 2 'OKEq+  OpNE        :: Op 2 'OKEq++  OpLT        :: Op 2 'OKRel+  OpLE        :: Op 2 'OKRel+  OpGT        :: Op 2 'OKRel+  OpGE        :: Op 2 'OKRel++  OpNot       :: Op 1 'OKLogical+  OpAnd       :: Op 2 'OKLogical+  OpOr        :: Op 2 'OKLogical+  OpEquiv     :: Op 2 'OKLogical+  OpNotEquiv  :: Op 2 'OKLogical++  OpLookup    :: Op 2 'OKLookup++  OpDeref     :: Op 1 'OKDeref
+ src/Language/Fortran/Model/Op/Core/Eval.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE LambdaCase             #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE UndecidableInstances   #-}++{-# OPTIONS_GHC -Wall #-}++module Language.Fortran.Model.Op.Core.Eval+  ( MonadEvalFortran+  , evalCoreOp+  ) where++import           Control.Applicative                  (liftA2)++import           Data.SBV.Dynamic                     (SVal)+import qualified Data.SBV.Dynamic                     as SBV++import           Data.Singletons+import           Data.Singletons.Prelude.List+import           Data.Singletons.TypeLits++import           Data.Vinyl                           hiding (Field)+import           Data.Vinyl.Curry++import           Language.Fortran.Model.Op.Core.Core+import           Language.Fortran.Model.Op.Core.Match+import           Language.Fortran.Model.Op.Eval+import           Language.Fortran.Model.Repr+import           Language.Fortran.Model.Repr.Prim+import           Language.Fortran.Model.Singletons+import           Language.Fortran.Model.Types+import           Language.Fortran.Model.Types.Match++--------------------------------------------------------------------------------+--  Evaluation+--------------------------------------------------------------------------------++evalCoreOp+  :: (MonadEvalFortran r m)+  => Op (Length args) ok -> OpSpec ok args result -> Rec CoreRepr args -> m (CoreRepr result)+evalCoreOp op opr = case opr of+  OSLit px x -> \_ -> primFromVal px <$> primLit px x++  OSNum1 _ _ p2 ->+    primUnop True p2 (numUnop op)+  OSNum2 nk1 nk2 p1 p2 p3 ->+    primBinop True p1 p2 p3 (numBinop (nkBothInts nk1 nk2) op)++  OSLogical1 _ p2 -> primUnop True p2 (logicalUnop op)+  OSLogical2 p1 p2 p3 -> primBinop True p1 p2 p3 (logicalBinop op)++  OSEq cmp p1 p2 p3 -> primBinop False p1 p2 p3 (eqBinop cmp op)+  OSRel cmp p1 p2 p3 -> primBinop False p1 p2 p3 (relBinop cmp op)++  OSLookup _ -> return . runcurry lookupArr++  OSDeref _ s -> return . runcurry (derefData s Proxy)++--------------------------------------------------------------------------------+--  General+--------------------------------------------------------------------------------++primToVal :: CoreRepr (PrimS a) -> SVal+primToVal = \case+  CRPrim (DPrim _) v -> v++primFromVal :: Prim p k a -> SVal -> CoreRepr (PrimS a)+primFromVal p v = CRPrim (DPrim p) v++primUnop+  :: (MonadEvalFortran r m)+  => Bool+  -> Prim p2 k2 b -- ^ The target type+  -> (SVal -> SVal)+  -> Rec CoreRepr '[PrimS a] -> m (CoreRepr (PrimS b))+primUnop shouldCoerce p2 f = runcurry $ fmap (primFromVal p2 . f) . maybeCoerce . primToVal+  where+    maybeCoerce+      | shouldCoerce = coercePrimSVal p2+      | otherwise = return++primBinop+  :: (MonadEvalFortran r m)+  => Bool+  -- ^ True to coerce arguments to result value. False to coerce arguments to+  -- ceiling of each.+  -> Prim p1 k1 a -> Prim p2 k2 b -> Prim p3 k3 c+  -> (SVal -> SVal -> SVal)+  -> Rec CoreRepr '[PrimS a, PrimS b] -> m (CoreRepr (PrimS c))+primBinop takesResultVal p1 p2 p3 (.*.) =+  fmap (primFromVal p3) .+  runcurry (\x y -> liftA2 (.*.) (coerceArg (primToVal x)) (coerceArg (primToVal y)))++  where+    coerceToCeil = case primCeil p1 p2 of+      Just (MakePrim pCeil) -> coercePrimSVal pCeil+      _                     -> return++    coerceArg+      | takesResultVal = coercePrimSVal p3+      | otherwise = coerceToCeil++--------------------------------------------------------------------------------+--  Numeric+--------------------------------------------------------------------------------++-- TODO: Worry about what happens when LHS and RHS have different types++nkBothInts :: NumericBasicType k1 -> NumericBasicType k2 -> Bool+nkBothInts NBTInt NBTInt = True+nkBothInts _ _           = False++numUnop :: Op 1 'OKNum -> SVal -> SVal+numUnop = \case+  OpNeg -> SBV.svUNeg+  OpPos -> id++numBinop :: Bool -> Op 2 'OKNum -> SVal -> SVal -> SVal+numBinop isInt = \case+  OpAdd -> SBV.svPlus+  OpSub -> SBV.svMinus+  OpMul -> SBV.svTimes+  OpDiv -> if isInt then SBV.svQuot else SBV.svDivide++--------------------------------------------------------------------------------+--  Logical+--------------------------------------------------------------------------------++-- TODO: Always return single bits, special-case when inputs are not single bits.+-- TODO: Worry about what happens when LHS and RHS have different types++logicalUnop :: Op 1 'OKLogical -> SVal -> SVal+logicalUnop = \case+  OpNot -> SBV.svNot++logicalBinop :: Op 2 'OKLogical -> SVal -> SVal -> SVal+logicalBinop = \case+  OpAnd -> SBV.svAnd+  OpOr -> SBV.svOr+  OpEquiv -> svEquiv+  OpNotEquiv -> svNotEquiv+  where+    svEquiv x y = (x `SBV.svAnd` y) `SBV.svOr` (SBV.svNot x `SBV.svAnd` SBV.svNot y)+    svNotEquiv x y = SBV.svNot (x `svEquiv` y)++--------------------------------------------------------------------------------+--  Equality+--------------------------------------------------------------------------------++-- TODO: Worry about what happens when LHS and RHS have different types++eqBinop :: ComparableBasicTypes k1 k2 -> Op 2 'OKEq -> SVal -> SVal -> SVal+eqBinop _ = \case+  OpEq -> SBV.svEqual+  OpNE -> SBV.svNotEqual++--------------------------------------------------------------------------------+--  Relational+--------------------------------------------------------------------------------++-- TODO: Worry about what happens when LHS and RHS have different types++relBinop :: ComparableBasicTypes k1 k2 -> Op 2 'OKRel -> SVal -> SVal -> SVal+relBinop _ = \case+  OpLT -> SBV.svLessThan+  OpLE -> SBV.svLessEq+  OpGT -> SBV.svGreaterThan+  OpGE -> SBV.svGreaterEq++--------------------------------------------------------------------------------+--  Lookup+--------------------------------------------------------------------------------++lookupArrRepr+  :: CoreRepr i+  -> D (Array i v)+  -> ArrRepr i v+  -> CoreRepr v+lookupArrRepr ixRepr (DArray ixIndex@(Index _) valAV) arrRepr =+  case ixRepr of+    CRPrim _ ixVal -> case (valAV, arrRepr) of+      (ArrPrim _, ARPrim arr) ->+        CRPrim (dArrValue valAV) (SBV.readSArr arr ixVal)+      (ArrData _ dfields, ARData afields) ->+        let avD = (dArrValue valAV)+        in CRData avD (+          rzipWith+          (zipFieldsWith (lookupArrRepr ixRepr . DArray ixIndex))+          dfields+          afields)++lookupArr+  :: CoreRepr (Array i v)+  -> CoreRepr i+  -> CoreRepr v+lookupArr (CRArray arrD arrRepr) ixRepr = lookupArrRepr ixRepr arrD arrRepr++--------------------------------------------------------------------------------+--  Deref+--------------------------------------------------------------------------------++derefData+  :: RElem '(fname, a) fields i+  => SSymbol fname -> proxy a+  -> CoreRepr (Record rname fields)+  -> CoreRepr a+derefData nameSymbol valProxy (CRData _ dataRec) =+  case rget (pairProxy nameSymbol valProxy) dataRec of+    Field _ x -> x+  where+    pairProxy :: p1 a -> p2 b -> Proxy '(a, b)+    pairProxy _ _ = Proxy++--------------------------------------------------------------------------------+--  Equality of operators+--------------------------------------------------------------------------------++-- eqOpRArgs+--   :: (forall x y. (x -> y -> Bool) -> f x -> g y -> Bool)+--   -> OpSpec ok1 args1 r1+--   -> OpSpec ok2 args2 r2+--   -> Rec f args1+--   -> Rec g args2+--   -> Bool+-- eqOpRArgs le opr1 opr2 =+--   case (opr1, opr2) of+--     (OSLit _ _, OSLit _ _) -> \_ _ -> True+--     (OSNum1 _ px _, OSNum1 _ py _) -> runcurry $ runcurry . le (eqPrimS px py)+--     (OSNum2 _ _ px1 px2 _, OSNum2 _ _ py1 py2 _) ->+--       runcurry $ \x1 x2 -> runcurry $ \y1 y2 ->+--       le (eqPrimS px1 py1) x1 y1 && le (eqPrimS px2 py2) x2 y2+--     (OSLogical1 px _, OSLogical1 py _) -> runcurry $ runcurry . le (eqPrimS px py)+--     (OSLogical2 px1 px2 _, OSLogical2 py1 py2 _) ->+--       runcurry $ \x1 x2 -> runcurry $ \y1 y2 ->+--       le (eqPrimS px1 py1) x1 y1 && le (eqPrimS px2 py2) x2 y2+--     (OSEq _ px1 px2 _, OSEq _ py1 py2 _) ->+--       runcurry $ \x1 x2 -> runcurry $ \y1 y2 ->+--       le (eqPrimS px1 py1) x1 y1 && le (eqPrimS px2 py2) x2 y2+--     (OSRel _ px1 px2 _, OSRel _ py1 py2 _) ->+--       runcurry $ \x1 x2 -> runcurry $ \y1 y2 ->+--       le (eqPrimS px1 py1) x1 y1 && le (eqPrimS px2 py2) x2 y2+--     (OSLookup (DArray (Index pi1) _), OSLookup (DArray (Index pi2) _)) ->+--       runcurry $ \arr1 i1 -> runcurry $ \arr2 i2 ->+--       le _ arr1 arr2 && le (eqPrimS pi1 pi2) i1 i2+--       -- le ()++-- liftEqRec+--   :: (forall a b. f a -> g b -> Bool)+--   -> Rec f xs -> Rec g ys+--   -> Bool+-- liftEqRec f r1 r2 = case (r1, r2) of+--   (RNil, RNil) -> True+--   (h1 :& t1, h2 :& t2) -> f h1 h2 && liftEqRec f t1 t2+--   _ -> False
+ src/Language/Fortran/Model/Op/Core/Match.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeOperators              #-}++{-# OPTIONS_GHC -Wall #-}++-- TODO: Complex Numbers++module Language.Fortran.Model.Op.Core.Match where++import           Control.Monad                       ((>=>))+import           Data.Typeable++import           Control.Lens++import           Data.Singletons+import           Data.Singletons.Prelude.List++import           Data.Vinyl                          hiding ((:~:), Field)++import           Language.Fortran.Model.Op.Core.Core+import           Language.Fortran.Model.Singletons+import           Language.Fortran.Model.Types+import           Language.Fortran.Model.Types.Match+import           Language.Fortran.Model.Util+++data MatchNumType a where+  MatchNumType :: Sing p -> Sing k -> NumericBasicType k -> Prim p k a -> MatchNumType (PrimS a)++-- | Checks if the given type is numeric, and if so returns a proof of that+-- fact.+matchNumType :: D a -> Maybe (MatchNumType a)+matchNumType = matchPrimD >=> \case+  MatchPrimD (MatchPrim sp SBTInt) p -> Just (MatchNumType sp SBTInt NBTInt p)+  MatchPrimD (MatchPrim sp SBTReal) p -> Just (MatchNumType sp SBTReal NBTReal p)+  _ -> Nothing+++data MatchNumR a b where+  MatchNumR+    :: NumericBasicType k1 -> NumericBasicType k2+    -> Prim p1 k1 a -> Prim p2 k2 b+    -> Prim (PrecMax p1 p2) (BasicTypeMax k1 k2) c+    -> MatchNumR (PrimS a) (PrimS b)++-- | Checks if it is possible to perform a binary numeric operation on arguments+-- with the given respective types. If so, returns the type that would result+-- plus some more information about the types.+matchNumR :: D a -> D b -> Maybe (MatchNumR a b)+matchNumR = matchingWith2 matchNumType matchNumType $ \case+  (MatchNumType sp1 sk1 nk1 prim1, MatchNumType sp2 sk2 nk2 prim2) ->+    makePrim (sPrecMax sp1 sp2) (sBasicTypeMax sk1 sk2) <$$> \case+      MakePrim prim3 -> MatchNumR nk1 nk2 prim1 prim2 prim3++primCeil :: Prim p1 k1 a -> Prim p2 k2 b -> Maybe (MakePrim (PrecMax p1 p2) (BasicTypeMax k1 k2))+primCeil prim1 prim2 = case (matchPrim prim1, matchPrim prim2) of+  (MatchPrim p1 k1, MatchPrim p2 k2) -> makePrim (sPrecMax p1 p2) (sBasicTypeMax k1 k2)+++data MatchCompareR a b where+  MatchCompareR :: ComparableBasicTypes k1 k2 -> Prim p1 k1 a -> Prim p2 k2 b -> MatchCompareR (PrimS a) (PrimS b)++-- | Checks if it is possible to perform a binary comparison (equality or+-- relational) operation on arguments with the given respective types. If so,+-- returns proof of that fact.+matchCompareR :: D a -> D b -> Maybe (MatchCompareR a b)+matchCompareR =+  (matchingWithBoth matchNumR $ Just . \case+      MatchNumR nk1 nk2 p1 p2 _ -> MatchCompareR (CBTNum nk1 nk2) p1 p2+  ) `altf2`+  (matchingWith2 matchPrimD matchPrimD $ \case+      (MatchPrimD (MatchPrim _ SBTLogical) p1, MatchPrimD (MatchPrim _ SBTLogical) p2) ->+        Just (MatchCompareR CBTBool p1 p2)+      (MatchPrimD (MatchPrim _ SBTChar) p1, MatchPrimD (MatchPrim _ SBTChar) p2) ->+        Just (MatchCompareR CBTChar p1 p2)+      _ -> Nothing+  )++--------------------------------------------------------------------------------+--  Matching on operator result types+--------------------------------------------------------------------------------++data MatchOpSpec ok args where+  MatchOpSpec :: OpSpec ok args result -> D result -> MatchOpSpec ok args++-- | Checks if it is possible to apply the given operator to the given+-- arguments, and if so returns a proof of that fact, packaged with information+-- about the result of applying the operator.+matchOpSpec :: Op (Length args) ok -> Rec D args -> Maybe (MatchOpSpec ok args)+matchOpSpec operator argTypes =+  case argTypes of+    RNil -> case operator of+      OpLit -> Nothing++    d1 :& RNil -> case operator of+      OpNeg -> argsNumeric <$$> \case+        MatchNumType _ _ nk p :& RNil -> MatchOpSpec (OSNum1 nk p p) d1+      OpPos -> argsNumeric <$$> \case+        MatchNumType _ _ nk p :& RNil -> MatchOpSpec (OSNum1 nk p p) d1++      OpNot -> argsPrim >>= \case+        MatchPrimD (MatchPrim _ SBTLogical) p :& RNil -> Just $ MatchOpSpec (OSLogical1 p PBool8) (DPrim PBool8)+        _ -> Nothing++      -- In the deref case, we don't have access to a particular field to+      -- dereference, so there's nothing we can return.+      OpDeref -> Nothing++    d1 :& d2 :& RNil -> case operator of+      OpAdd -> matchNumR d1 d2 <$$> \case+          MatchNumR nk1 nk2 p1 p2 p3 -> MatchOpSpec (OSNum2 nk1 nk2 p1 p2 p3) (DPrim p3)+      OpSub -> matchNumR d1 d2 <$$> \case+          MatchNumR nk1 nk2 p1 p2 p3 -> MatchOpSpec (OSNum2 nk1 nk2 p1 p2 p3) (DPrim p3)+      OpMul -> matchNumR d1 d2 <$$> \case+          MatchNumR nk1 nk2 p1 p2 p3 -> MatchOpSpec (OSNum2 nk1 nk2 p1 p2 p3) (DPrim p3)+      OpDiv -> matchNumR d1 d2 <$$> \case+          MatchNumR nk1 nk2 p1 p2 p3 -> MatchOpSpec (OSNum2 nk1 nk2 p1 p2 p3) (DPrim p3)++      OpAnd -> argsPrim >>= \case+        MatchPrimD (MatchPrim _ SBTLogical) p1 :& MatchPrimD (MatchPrim _ SBTLogical) p2 :& RNil ->+          Just $ MatchOpSpec (OSLogical2 p1 p2 PBool8) (DPrim PBool8)+        _ -> Nothing+      OpOr -> argsPrim >>= \case+        MatchPrimD (MatchPrim _ SBTLogical) p1 :& MatchPrimD (MatchPrim _ SBTLogical) p2 :& RNil ->+          Just $ MatchOpSpec (OSLogical2 p1 p2 PBool8) (DPrim PBool8)+        _ -> Nothing+      OpEquiv -> argsPrim >>= \case+        MatchPrimD (MatchPrim _ SBTLogical) p1 :& MatchPrimD (MatchPrim _ SBTLogical) p2 :& RNil ->+          Just $ MatchOpSpec (OSLogical2 p1 p2 PBool8) (DPrim PBool8)+        _ -> Nothing+      OpNotEquiv -> argsPrim >>= \case+        MatchPrimD (MatchPrim _ SBTLogical) p1 :& MatchPrimD (MatchPrim _ SBTLogical) p2 :& RNil ->+          Just $ MatchOpSpec (OSLogical2 p1 p2 PBool8) (DPrim PBool8)+        _ -> Nothing++      OpEq -> matchCompareR d1 d2 <$$> \case+        MatchCompareR cmp p1 p2 -> MatchOpSpec (OSEq cmp p1 p2 PBool8) (DPrim PBool8)+      OpNE -> matchCompareR d1 d2 <$$> \case+        MatchCompareR cmp p1 p2 -> MatchOpSpec (OSEq cmp p1 p2 PBool8) (DPrim PBool8)+      OpLT -> matchCompareR d1 d2 <$$> \case+        MatchCompareR cmp p1 p2 -> MatchOpSpec (OSRel cmp p1 p2 PBool8) (DPrim PBool8)+      OpLE -> matchCompareR d1 d2 <$$> \case+        MatchCompareR cmp p1 p2 -> MatchOpSpec (OSRel cmp p1 p2 PBool8) (DPrim PBool8)+      OpGT -> matchCompareR d1 d2 <$$> \case+        MatchCompareR cmp p1 p2 -> MatchOpSpec (OSRel cmp p1 p2 PBool8) (DPrim PBool8)+      OpGE -> matchCompareR d1 d2 <$$> \case+        MatchCompareR cmp p1 p2 -> MatchOpSpec (OSRel cmp p1 p2 PBool8) (DPrim PBool8)++      OpLookup -> with (d1, d2) $ traverseOf _2 matchPrimD >=> \case+        (DArray (Index pi1) av, MatchPrimD _ pi2) -> case eqPrim pi1 pi2 of+          Just Refl -> Just $ MatchOpSpec (OSLookup d1) (dArrValue av)+          _         -> Nothing+        _ -> Nothing++    _ -> Nothing++  where+    argsNumeric = rtraverse matchNumType argTypes+    argsPrim = rtraverse matchPrimD argTypes
+ src/Language/Fortran/Model/Op/Eval.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# OPTIONS_GHC -Wall #-}++module Language.Fortran.Model.Op.Eval where++import           Control.Monad.Reader.Class       (MonadReader (..))++import           Data.SBV                         (SDouble, SFloat, SReal, sRTZ)+import qualified Data.SBV                         as SBV+import           Data.SBV.Dynamic                 (SVal)+import qualified Data.SBV.Dynamic                 as SBV+import           Data.SBV.Internals               (SBV (..))++import           Language.Fortran.Model.Repr.Prim+import           Language.Fortran.Model.Types++--------------------------------------------------------------------------------+--  Monad+--------------------------------------------------------------------------------++class (MonadReader r m, HasPrimReprHandlers r) => MonadEvalFortran r m | m -> r where+instance (MonadReader r m, HasPrimReprHandlers r) => MonadEvalFortran r m where++--------------------------------------------------------------------------------+--  SBV Kinds+--------------------------------------------------------------------------------++coerceBy :: (SBV a -> SBV b) -> SVal -> SVal+coerceBy f x = unSBV (f (SBV x))++coerceSBVKinds :: SBV.Kind -> SBV.Kind -> (SVal -> SVal)+coerceSBVKinds SBV.KReal   SBV.KReal = id+coerceSBVKinds SBV.KFloat  SBV.KReal = coerceBy (SBV.fromSFloat sRTZ :: SFloat -> SReal)+coerceSBVKinds SBV.KDouble SBV.KReal = coerceBy (SBV.fromSDouble sRTZ :: SDouble -> SReal)+coerceSBVKinds _        k2@SBV.KReal = SBV.svFromIntegral k2++coerceSBVKinds SBV.KReal   SBV.KDouble = coerceBy (SBV.toSDouble sRTZ :: SReal -> SDouble)+coerceSBVKinds SBV.KDouble SBV.KDouble = id+coerceSBVKinds SBV.KFloat  SBV.KDouble = coerceBy (SBV.toSDouble sRTZ :: SFloat -> SDouble)+coerceSBVKinds _        k2@SBV.KDouble = SBV.svFromIntegral k2++coerceSBVKinds SBV.KReal   SBV.KFloat = coerceBy (SBV.toSFloat sRTZ :: SReal -> SFloat)+coerceSBVKinds SBV.KDouble SBV.KFloat = coerceBy (SBV.toSFloat sRTZ :: SDouble -> SFloat)+coerceSBVKinds SBV.KFloat  SBV.KFloat = id+coerceSBVKinds _        k2@SBV.KFloat = SBV.svFromIntegral k2++coerceSBVKinds _ k2 = SBV.svFromIntegral k2++coercePrimSVal :: (MonadEvalFortran r m) => Prim p k a -> SVal -> m SVal+coercePrimSVal p v = do+  k2 <- primSBVKind p+  let k1 = SBV.kindOf v+  return $ coerceSBVKinds k1 k2 v
+ src/Language/Fortran/Model/Op/High.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE EmptyCase              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE LambdaCase             #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE UndecidableInstances   #-}++{-# OPTIONS_GHC -Wall #-}++{-|+Operators for expressions over lifted values++- Lifting Fortran types to higher-level representations+- Folds over arrays (sum, product)+- High-level mathematical functions (factorial...)+-}++module Language.Fortran.Model.Op.High where+++import           Control.Monad.Reader.Class       (MonadReader, asks)+import           Data.Functor.Compose++import           Language.Expression+import           Language.Expression.Pretty++import           Language.Fortran.Model.Repr+import           Language.Fortran.Model.Repr.Prim++--------------------------------------------------------------------------------+--  High-level Operations+--------------------------------------------------------------------------------++data HighOp t a where+  HopLift :: LiftDOp t a -> HighOp t a+++instance HFunctor HighOp+instance HTraversable HighOp where+  htraverse f = \case+    HopLift x -> HopLift <$> htraverse f x++instance (MonadReader r m, HasPrimReprHandlers r) => HFoldableAt (Compose m HighRepr) HighOp where+  hfoldMap f = \case+    HopLift x -> hfoldMap f x++instance Pretty2 HighOp where+  prettys2Prec p (HopLift x) = prettys2Prec p x++--------------------------------------------------------------------------------+--  Lifting Fortran values+--------------------------------------------------------------------------------++data LiftDOp t a where+  LiftDOp :: LiftD b a => t b -> LiftDOp t a++instance HFunctor LiftDOp where+instance HTraversable LiftDOp where+  htraverse f = \case+    LiftDOp x -> LiftDOp <$> f x++instance (MonadReader r m, HasPrimReprHandlers r+         ) => HFoldableAt (Compose m HighRepr) LiftDOp where+  hfoldMap = implHfoldMapCompose $ \case+    LiftDOp x -> do+      env <- asks primReprHandlers+      pure $ liftDRepr env x++instance Pretty2 LiftDOp where+  prettys2Prec p = \case+    -- TODO: Consider adding printed evidence of the lifting+    LiftDOp x -> prettys1Prec p x
+ src/Language/Fortran/Model/Op/Meta.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE EmptyCase             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -Wall #-}++{-|+For expressions over normal Fortran values that are not representable in+Fortran.++- Immutable array update ('MopWriteArr')+- Immutable data update ('MopWriteData')+- Explicit coercions ('MopCoercePrim')+-}++module Language.Fortran.Model.Op.Meta (MetaOp(..)) where++import           Data.Functor.Compose++import           Data.Vinyl                          (Rec, rmap, (<<*>>))+import           Data.Vinyl.Functor                  (Lift (..))+import           Data.Vinyl.Lens                     (RElem, RecElem (rput))++import           Data.Singletons.TypeLits++import qualified Data.SBV.Dynamic                    as SBV++import           Language.Expression+import           Language.Expression.Pretty++import           Language.Fortran.Model.Op.Core.Eval+import           Language.Fortran.Model.Op.Eval+import           Language.Fortran.Model.Repr+import           Language.Fortran.Model.Types+++data MetaOp t a where+  MopWriteArr+    :: D (Array i v)+    -> t (Array i v)+    -> t i+    -> t v+    -> MetaOp t (Array i v)++  {-|++  In @'MopWriteData' recD fSymb valD recVal valVal@:++  * @recD@ is the type of the record we're writing to.+  * @fSymb@ is the name of the field we're writing to.+  * @valD@ is the type of the value we're writing to.+  * @recVal@ is the original value of the record.+  * @valVal@ is the new value of the field to write to.+  -}+  MopWriteData+    :: RElem '(fname, a) fields i+    => D (Record rname fields)+    -> SSymbol fname+    -> D a+    -> t (Record rname fields)+    -> t a+    -> MetaOp t (Record rname fields)++  MopCoercePrim+    :: Prim p k b+    -> t (PrimS a)+    -> MetaOp t (PrimS b)+++instance HFunctor MetaOp where+instance HTraversable MetaOp where+  htraverse f = \case+    MopWriteArr d x y z -> MopWriteArr d <$> f x <*> f y <*> f z+    MopWriteData a b c x y -> MopWriteData a b c <$> f x <*> f y+    MopCoercePrim p x -> MopCoercePrim p <$> f x+++instance (MonadEvalFortran r m) => HFoldableAt (Compose m CoreRepr) MetaOp where+  hfoldMap = implHfoldMapCompose $ \case+    MopWriteArr _ arr ix val -> pure $ writeArray arr ix val+    MopWriteData _ fname _ rec val -> pure $ writeDataAt fname rec val+    MopCoercePrim p x -> coercePrim p x+++instance (MonadEvalFortran r m) => HFoldableAt (Compose m HighRepr) MetaOp where+  hfoldMap = implHfoldMapCompose $ fmap HRCore . hfoldA .+    hmap (\case HRCore x -> x+                HRHigh _ -> error "impossible")+++instance Pretty2 MetaOp where+  prettys2Prec p = \case+    MopWriteArr _ arr i v ->+      -- e.g. @myArrayVar[9 <- "new value"]@+      showParen (p > 9) $ prettys1Prec 10 arr .+                          showString "[" . prettys1Prec 0 i .+                          showString " <- " . prettys1Prec 0 v .+                          showString "]"+    MopWriteData _ fname _ r v ->+      showParen (p > 9) $ prettys1Prec 10 r .+      showString "{" .+      showString (withKnownSymbol fname (symbolVal fname)) .+      showString " <- " .+      prettys1Prec 0 v .+      showString "}"++    -- TODO: Consider adding visual evidence of coercion+    MopCoercePrim _ x -> prettys1Prec p x+++--------------------------------------------------------------------------------+--  Write array+--------------------------------------------------------------------------------++rzip3With+  :: (forall x. f x -> g x -> h x -> i x)+  -> Rec f xs+  -> Rec g xs+  -> Rec h xs+  -> Rec i xs+rzip3With f x y z = rmap (Lift . (Lift .) . f) x <<*>> y <<*>> z++writeArray' :: CoreRepr i -> D (Array i v) -> ArrRepr i v -> CoreRepr v -> ArrRepr i v+writeArray' ixRep (DArray ixIndex@(Index _) valAV) arrRep valRep =+  case ixRep of+    CRPrim _ ixVal -> case (valAV, arrRep, valRep) of+      (ArrPrim _, ARPrim arr, CRPrim _ valVal) -> ARPrim (SBV.writeSArr arr ixVal valVal)+      (ArrData _ fieldsAV, ARData fieldsAR, CRData _ fieldsRep) ->+        ARData (rzip3With (zip3FieldsWith (writeArray' ixRep . DArray ixIndex))+                fieldsAV+                fieldsAR+                fieldsRep)+++writeArray :: CoreRepr (Array i v) -> CoreRepr i -> CoreRepr v -> CoreRepr (Array i v)+writeArray (CRArray arrD arrRep) ixRep valRep =+  CRArray arrD (writeArray' ixRep arrD arrRep valRep)++--------------------------------------------------------------------------------+--  Write Data+--------------------------------------------------------------------------------++writeDataAt+  :: RElem '(fname, a) fields i+  => SSymbol fname+  -> CoreRepr (Record rname fields)+  -> CoreRepr a+  -> CoreRepr (Record rname fields)+writeDataAt fieldSymbol (CRData d dataRec) valRep =+  CRData d $ rput (Field fieldSymbol valRep) dataRec++--------------------------------------------------------------------------------+--  Coerce primitives+--------------------------------------------------------------------------------++coercePrim+  :: (MonadEvalFortran r m)+  => Prim p k b+  -> CoreRepr (PrimS a)+  -> m (CoreRepr (PrimS b))+coercePrim prim2 (CRPrim _ v) = CRPrim (DPrim prim2) <$> coercePrimSVal prim2 v
+ src/Language/Fortran/Model/Repr.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE EmptyCase                  #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}++{-# OPTIONS_GHC -Wall #-}+++{-|++Symbolic representations of Fortran values, for symbolic reasoning.++There is a distinction between core representations ('CoreRepr') and high-level+representations ('HighRepr'). 'CoreRepr' represents any @a@ such that @'D' a@+exists; i.e. anything with a corresponding Fortran type. 'HighRepr' is a+superset of 'CoreRepr'. It represents Fortran types, and also higher-level types+that facilitate reasoning. There is more information about this distinction in+"Language.Fortran.Model.Op".++-}+module Language.Fortran.Model.Repr where++import           Data.Int                        (Int16, Int32, Int64, Int8)+import           Data.Word                       (Word8)++import           Data.Functor.Compose++import           Data.SBV+import           Data.SBV.Dynamic+import           Data.SBV.Internals              (SBV (..))++import           Data.Vinyl                      hiding (Field)++import           Language.Expression+import           Language.Expression.Prop++import           Language.Fortran.Model.Repr.Prim+import           Language.Fortran.Model.Types++--------------------------------------------------------------------------------+-- * Core Fortran Representations++{-|++Symbolic representations of Fortran values, using "Data.SBV.Dynamic".++-}+data CoreRepr a where+  CRPrim+    :: D (PrimS a)+    -> SVal+    -> CoreRepr (PrimS a)++  CRArray+    :: D (Array i a)+    -> ArrRepr i a+    -> CoreRepr (Array i a)++  CRData+    :: D (Record name fs)+    -> Rec (Field CoreRepr) fs+    -> CoreRepr (Record name fs)++{-|++Symbolic respresentations of Fortran arrays. SBV arrays can only contain basic+values, so in order to represent arrays of derived data types, we use multiple+flat arrays, one for each basic field. Nested derived data types are recursively+expanded.++Arrays of arrays are not yet supported.++-}+data ArrRepr i a where+  -- | A primitive type is represented by a flat 'SArr'.+  ARPrim :: SArr -> ArrRepr i (PrimS a)++  -- | A derived data type is represented by a record of 'ArrRepr's over the+  -- record's fields.+  ARData :: Rec (Field (ArrRepr i)) fs -> ArrRepr i (Record name fs)+++--------------------------------------------------------------------------------+-- * High-level data representations++{-|++Symbolic representations of Fortran values plus types in the higher-level+meta-language (see "Language.Fortran.Op" for more information).++-}+data HighRepr a where+  HRCore :: CoreRepr a -> HighRepr a+  HRHigh :: SBV a -> HighRepr a++instance HFoldableAt HighRepr LogicOp where+  hfoldMap = implHfoldMap $ \case+    LogLit x     -> HRHigh (fromBool x)+    LogNot x     -> HRHigh . bnot . getHrBool $ x+    LogAnd x y   -> appBinop (&&&) x y+    LogOr x y    -> appBinop (|||) x y+    LogImpl x y  -> appBinop (==>) x y+    LogEquiv x y -> appBinop (<=>) x y++    where+      appBinop (g :: SBool -> SBool -> SBool) x y =+        HRHigh $ g (getHrBool x) (getHrBool y)+      getHrBool :: HighRepr Bool -> SBool+      getHrBool (HRHigh x) = x+      getHrBool (HRCore x) = case x of -- I.e. absurd++instance (Monad m) => HFoldableAt (Compose m HighRepr) LogicOp where+  hfoldMap = implHfoldMapCompose (pure . hfold)++--------------------------------------------------------------------------------+-- *  Lifting Fortran types to high-level representations++-- | Provides conversions between symbolic representations of core Fortran+-- values and their corresponding high-level types.+class (SymWord a) => LiftD b a | b -> a where+  -- | Go from a core value to the corresponding high-level value.+  liftD :: b -> a+  -- | Go from a symbolic core value to the corresponding symbolic high-level+  -- value.+  liftDRepr :: PrimReprHandlers -> HighRepr b -> HighRepr a++liftDInt :: PrimReprHandlers -> HighRepr (PrimS a) -> HighRepr Integer+liftDInt _ (HRCore (CRPrim _ x)) = HRHigh (SBV (svFromIntegral KUnbounded x))+liftDInt _ _ = error "impossible"+++liftDReal :: PrimReprHandlers -> HighRepr (PrimS a) -> HighRepr AlgReal+liftDReal env (HRCore (CRPrim (DPrim prim) x)) =+  HRHigh $ case primSBVKind prim env of+              KFloat -> fromSFloat sRTZ (SBV x)+              KDouble -> fromSDouble sRTZ (SBV x)+              KReal -> SBV x+              k -> error $ "liftDReal: can't convert something of kind " +++                   show k ++ " to a real"+liftDReal _ _ = error "impossible"++liftDBool :: PrimReprHandlers -> HighRepr (PrimS a) -> HighRepr Bool+liftDBool _ (HRCore (CRPrim _ x)) = HRHigh (SBV (x `svGreaterThan` svFalse))+liftDBool _ _ = error "impossible"+++instance LiftD (PrimS Int8) Integer where+  liftD = fromIntegral . getPrimS+  liftDRepr = liftDInt+instance LiftD (PrimS Int16) Integer where+  liftD = fromIntegral . getPrimS+  liftDRepr = liftDInt+instance LiftD (PrimS Int32) Integer where+  liftD = fromIntegral . getPrimS+  liftDRepr = liftDInt+instance LiftD (PrimS Int64) Integer where+  liftD = fromIntegral . getPrimS+  liftDRepr = liftDInt++instance LiftD (PrimS Float) AlgReal where+  liftD = realToFrac . getPrimS+  liftDRepr = liftDReal+instance LiftD (PrimS Double) AlgReal where+  liftD = realToFrac . getPrimS+  liftDRepr = liftDReal++instance LiftD (PrimS Bool8) Bool where+  liftD = (> 0) . getBool8 . getPrimS+  liftDRepr = liftDBool+instance LiftD (PrimS Bool16) Bool where+  liftD = (> 0) . getBool16 . getPrimS+  liftDRepr = liftDBool+instance LiftD (PrimS Bool32) Bool where+  liftD = (> 0) . getBool32 . getPrimS+  liftDRepr = liftDBool+instance LiftD (PrimS Bool64) Bool where+  liftD = (> 0) . getBool64 . getPrimS+  liftDRepr = liftDBool++instance LiftD (PrimS Char8) Word8 where+  liftD = getChar8 . getPrimS+  liftDRepr _ (HRCore (CRPrim _ x)) = HRHigh (sFromIntegral (SBV x :: SBV Word8))+  liftDRepr _ _ =+    error "liftDRepr: a 'PrimS Char8' has a non-primitive representation"++--------------------------------------------------------------------------------+-- * Combinators++-- | Any type that has a core representation has a corresponding Fortran type.+coreReprD :: CoreRepr a -> D a+coreReprD = \case+  CRPrim d _  -> d+  CRArray d _ -> d+  CRData d _  -> d
+ src/Language/Fortran/Model/Repr/Prim.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}++{-# OPTIONS_GHC -Wall      #-}++{-|++= Handling primitive Fortran values symbolically.++There are a few challenges that this module attempts to solve:++Fortran uses fixed-width machine integers and floating point reals. Sometimes we+might want to reason about these directly (which is supported by SBV and+therefore feasible). However, sometimes they get in the way of the logic and we+just want to pretend that they're the pure mathematical values that they+approximate. For example floating point addition obeys very few algebraic laws,+so most theorems about real numbers don't hold at all for floating point+numbers.++In addition, Fortran's boolean values are actually arbitrary signed integers. If+we treat all boolean values symbolically as bit-vectors, logic can become very+slow; so it might be best to pretend that all booleans are single bits. However,+sometimes we might want to verify properties that rely on the actual bit-vector+representation of booleans.++This module deals with these problems by abstracting over the choices: the user+should be able to choose which representation they want to use for each+primitive data type.++The user provides a 'PrimReprSpec' which specifies how each data type should be+treated. Some examples are provided: 'prsPrecise' treats all values precisely as+they are represented in the Fortran program. This makes logic slow and makes it+very difficult to prove many things, but it is most accurate. On the other hand,+'prsIdealized' treats all values as their idealized mathematical equivalents.+This makes logic fast and lots intuitive properties can be proved easily.+However, these properties often will not hold in actual running Fortran+programs: sometimes in weird edge cases and sometimes in sensible-seeming+executions. It would be interesting future work to provide an analysis that+helps to determine which of the two applies to a particular program!++-}+module Language.Fortran.Model.Repr.Prim where++import           Data.Int                         (Int16, Int32, Int64, Int8)+import           Data.Word                        (Word8)++import           Control.Lens+import           Control.Monad.Reader             (MonadReader (..))++import qualified Data.SBV                         as SBV+import           Data.SBV.Dynamic                 (SVal)+import           Data.SBV.Internals               (SBV (..))++import           Language.Fortran.Model.Types++--------------------------------------------------------------------------------+-- * Types++data IntRepr a = MachineInt | ArbitraryInt deriving (Eq, Ord, Show)+data RealRepr a = MachineFloat | ArbitraryReal deriving (Eq, Ord, Show)+data BoolRepr a = IntBool | BitBool deriving (Eq, Ord, Show)++data PrimReprHandler a =+  PrimReprHandler+  { _prhKind     :: !SBV.Kind+  , _prhLiteral  :: !(a -> SVal)+  , _prhSymbolic :: !(String -> SBV.Symbolic SVal)+  }++data PrimReprSpec =+  PrimReprSpec+  { _prsInt8Repr   :: !(IntRepr Int8)+  , _prsInt16Repr  :: !(IntRepr Int16)+  , _prsInt32Repr  :: !(IntRepr Int32)+  , _prsInt64Repr  :: !(IntRepr Int64)+  , _prsFloatRepr  :: !(RealRepr Float)+  , _prsDoubleRepr :: !(RealRepr Double)+  , _prsBool8Repr  :: !(BoolRepr Bool8)+  , _prsBool16Repr :: !(BoolRepr Bool16)+  , _prsBool32Repr :: !(BoolRepr Bool32)+  , _prsBool64Repr :: !(BoolRepr Bool64)+  }++--------------------------------------------------------------------------------+-- ** Lenses++makeLenses ''PrimReprHandler+makeLenses ''PrimReprSpec++--------------------------------------------------------------------------------+-- * Standard specs++prsPrecise :: PrimReprSpec+prsPrecise = PrimReprSpec+  { _prsInt8Repr = MachineInt+  , _prsInt16Repr = MachineInt+  , _prsInt32Repr = MachineInt+  , _prsInt64Repr = MachineInt+  , _prsFloatRepr = MachineFloat+  , _prsDoubleRepr = MachineFloat+  , _prsBool8Repr = IntBool+  , _prsBool16Repr = IntBool+  , _prsBool32Repr = IntBool+  , _prsBool64Repr = IntBool+  }++prsIdealized :: PrimReprSpec+prsIdealized = PrimReprSpec+  { _prsInt8Repr = ArbitraryInt+  , _prsInt16Repr = ArbitraryInt+  , _prsInt32Repr = ArbitraryInt+  , _prsInt64Repr = ArbitraryInt+  , _prsFloatRepr = ArbitraryReal+  , _prsDoubleRepr = ArbitraryReal+  , _prsBool8Repr = BitBool+  , _prsBool16Repr = BitBool+  , _prsBool32Repr = BitBool+  , _prsBool64Repr = BitBool+  }++prsWithArbitraryInts :: Bool -> PrimReprSpec -> PrimReprSpec+prsWithArbitraryInts useArbitrary+  | useArbitrary =+    set prsInt8Repr ArbitraryInt .+    set prsInt16Repr ArbitraryInt .+    set prsInt32Repr ArbitraryInt .+    set prsInt64Repr ArbitraryInt+  | otherwise =+    set prsInt8Repr MachineInt .+    set prsInt16Repr MachineInt .+    set prsInt32Repr MachineInt .+    set prsInt64Repr MachineInt++prsWithArbitraryReals :: Bool -> PrimReprSpec -> PrimReprSpec+prsWithArbitraryReals useArbitrary+  | useArbitrary =+    set prsFloatRepr ArbitraryReal .+    set prsDoubleRepr ArbitraryReal+  | otherwise =+    set prsFloatRepr MachineFloat .+    set prsDoubleRepr MachineFloat++--------------------------------------------------------------------------------+-- * Using specs++makeSymRepr :: PrimReprSpec -> Prim p k a -> PrimReprHandler a+makeSymRepr spec = \case+  PInt8   -> intRepr prsInt8Repr+  PInt16  -> intRepr prsInt16Repr+  PInt32  -> intRepr prsInt32Repr+  PInt64  -> intRepr prsInt64Repr+  PFloat  -> realRepr prsFloatRepr+  PDouble -> realRepr prsDoubleRepr+  PBool8  -> boolRepr getBool8 prsBool8Repr+  PBool16 -> boolRepr getBool16 prsBool16Repr+  PBool32 -> boolRepr getBool32 prsBool32Repr+  PBool64 -> boolRepr getBool64 prsBool64Repr+  PChar   -> bySymWord (0 :: Word8) getChar8+  where+    intRepr+      :: (Integral a, SBV.SymWord a)+      => Lens' PrimReprSpec (IntRepr a) -> PrimReprHandler a+    intRepr l = case spec ^. l of+      MachineInt   -> bySymWord 0 id+      ArbitraryInt -> bySymWord (0 :: Integer) fromIntegral++    realRepr+      :: (RealFloat a, SBV.SymWord a)+      => Lens' PrimReprSpec (RealRepr a) -> PrimReprHandler a+    realRepr l = case spec ^. l of+      MachineFloat  -> bySymWord 0 id+      ArbitraryReal -> bySymWord (0 :: SBV.AlgReal) realToFrac++    boolRepr+      :: (Integral b, SBV.SymWord b)+      => (a -> b) -> Lens' PrimReprSpec (BoolRepr a) -> PrimReprHandler a+    boolRepr unwrap l = case spec ^. l of+      IntBool -> bySymWord 0 unwrap+      BitBool -> bySymWord (False :: Bool) (toBool . unwrap)++    bySymWord :: (SBV.SymWord b) => b -> (a -> b) -> PrimReprHandler a+    bySymWord (repValue :: b) fromPrim =+      PrimReprHandler+      { _prhKind = SBV.kindOf repValue+      , _prhLiteral = unSBV . SBV.literal . fromPrim+      , _prhSymbolic = fmap (unSBV :: SBV b -> SVal) . SBV.symbolic+      }++    toBool :: (Ord a, Num a) => a -> Bool+    toBool x = x > 0++--------------------------------------------------------------------------------+-- * Monadic Accessors++class HasPrimReprHandlers r where+  primReprHandlers :: r -> PrimReprHandlers+  primReprHandlers env = PrimReprHandlers (primReprHandler env)++  primReprHandler :: r -> Prim p k a -> PrimReprHandler a+  primReprHandler = unPrimReprHandlers . primReprHandlers++newtype PrimReprHandlers =+  PrimReprHandlers { unPrimReprHandlers :: forall p k a. Prim p k a -> PrimReprHandler a }++instance HasPrimReprHandlers PrimReprHandlers where+  primReprHandlers = id++primSBVKind :: (MonadReader r m, HasPrimReprHandlers r) => Prim p k a -> m SBV.Kind+primSBVKind p = view (to (flip primReprHandler p) . prhKind)++primLit :: (MonadReader r m, HasPrimReprHandlers r) => Prim p k a -> a -> m SVal+primLit p a = do+  lit <- view (to (flip primReprHandler p) . prhLiteral)+  return (lit a)++primSymbolic+  :: (MonadReader r m, HasPrimReprHandlers r)+  => Prim p k a -> String -> m (SBV.Symbolic SVal)+primSymbolic p nm = do+  symbolic <- view (to (flip primReprHandler p) . prhSymbolic)+  return (symbolic nm)
+ src/Language/Fortran/Model/Singletons.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DefaultSignatures         #-}+{-# LANGUAGE EmptyCase                 #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE InstanceSigs              #-}+{-# LANGUAGE KindSignatures            #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeInType                #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-}++{-|++Data kinds and corresponding singletons (via the @singletons@ library) for kinds+used in various places in "Language.Fortran.Model".++As documentation in Template Haskell is not yet supported, documentation for+each data type is given here.++== 'Precision'++The precision, in bits, of an intrinsic Fortran data type.++== 'BasicType'++The basic type of an intrinsic Fortran data type.++== 'OpKind'++TODO++== 'precMax'++Finds the maximum of two precisions. Use 'PrecMax' at the type level and 'sPrecMax' for singletons.++== 'basicTypeMax'++Finds the \'largest\' (with respect to the size of the set it semantically+represents) of numeric basic types. Also works with non-numeric basic types, but+the result in that case is unspecified. Use 'BasicTypeMax' at the type level and+'sBasicTypeMax' for singletons.++-}+module Language.Fortran.Model.Singletons where++import           Data.Singletons.Prelude+import           Data.Singletons.Prelude.Maybe+import           Data.Singletons.TH++$(singletons+  [d|++  data Precision+    = P8+    | P16+    | P32+    | P64+    | P128+    deriving (Eq, Ord)++  data BasicType+    -- NB. The order of the constructors is very important for the derived 'Ord'+    -- instance! Numeric basicTypes that can represent smaller sets of numbers must be+    -- earlier in the list.+    = BTInt+    | BTReal+    | BTLogical+    | BTChar+    deriving (Eq, Ord)++  data OpKind+    = OKLit+    | OKNum+    | OKEq+    | OKRel+    | OKLogical+    | OKLookup+    | OKDeref+    | OKWriteArr+    | OKWriteData++  precMax :: Precision -> Precision -> Precision+  precMax = max++  basicTypeMax :: BasicType -> BasicType -> BasicType+  basicTypeMax = max+   |])++-- These are derived outside the TH splice because we don't need them at the+-- type level so we don't want to waste compilation time on type-level versions+-- of them.++deriving instance Show Precision+deriving instance Show BasicType++deriving instance Eq OpKind+deriving instance Ord OpKind+deriving instance Show OpKind
+ src/Language/Fortran/Model/Translate.hs view
@@ -0,0 +1,678 @@+{-# LANGUAGE TupleSections              #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -fno-warn-unused-matches #-}++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}++-- TODO: Implement translation for more unsupported language parts++{-|++Provides translation from a subset of the dynamically typed Fortran syntax+("Language.Fortran.AST") to the strongly typed expression language+("Language.Fortran.Model").++-}+module Language.Fortran.Model.Translate+  (+    -- * Types+    -- ** Fortran Expressions+    FortranExpr+    -- ** Existentials+  , Some(..)+  , SomeVar+  , SomeExpr+  , SomeType+    -- ** Semantics+  , KindSelector(..)+  , FortranSemantics(..)+  , defaultSemantics++    -- * Translation Monad+    -- ** Environment+  , TranslateEnv(..)+  , defaultTranslateEnv+    -- ** Errors+  , TranslateError(..)+    -- ** Monad+  , TranslateT(..)+  , runTranslateT++    -- * Translating Expressions+  , translateExpression+  , translateExpression'+  , translateCoerceExpression++    -- * Translating Types+    -- ** 'TypeInfo'+  , TypeInfo+  , typeInfo+    -- ** Translation+  , translateTypeInfo++    -- * Lenses+    -- ** 'FortranSemantics'+  , fsIntegerKinds+  , fsRealKinds+  , fsLogicalKinds+  , fsCharacterKinds+  , fsDoublePrecisionKinds+    -- * 'TranslateEnv'+  , teVarsInScope+  , teImplicitVars+  , teSemantics+    -- ** 'TypeInfo'+  , tiSrcSpan+  , tiBaseType+  , tiSelectorLength+  , tiSelectorKind+  , tiDeclaratorLength+  , tiDimensionDeclarators+  , tiAttributes+  ) where++import           Prelude                              hiding (span)++import           Control.Applicative                  ((<|>))+import           Data.Char                            (toLower)+import           Data.List                            (intersperse)+import           Data.Maybe                           (catMaybes)+import           Data.Typeable                        (Typeable)+import           Text.Read                            (readMaybe)++import           Control.Lens                         hiding (Const (..),+                                                       indices, op, rmap, (.>))+import           Control.Monad.Except+import           Control.Monad.Reader+import           Data.Map                             (Map)++import           Data.Singletons+import           Data.Singletons.Prelude.List         (Length)++import           Data.Vinyl+import           Data.Vinyl.Functor                   (Const (..))++import qualified Language.Fortran.Analysis            as F+import qualified Language.Fortran.AST                 as F+import qualified Language.Fortran.Util.Position       as F++import           Language.Expression+import           Language.Expression.Pretty++import           Camfort.Analysis.Logger+import           Camfort.Helpers.TypeLevel+import           Language.Fortran.Model.Op.Core+import           Language.Fortran.Model.Op.Meta+import           Language.Fortran.Model.Op.Core.Match+import           Language.Fortran.Model.Singletons+import           Language.Fortran.Model.Types+import           Language.Fortran.Model.Types.Match+import           Language.Fortran.Model.Vars++--------------------------------------------------------------------------------+--  General types+--------------------------------------------------------------------------------++-- | The type of strongly-typed Fortran expressions.+type FortranExpr = HFree CoreOp FortranVar++-- | A Fortran variable with an existential type.+type SomeVar = Some FortranVar++-- | A Fortran expression with an existential type.+type SomeExpr = Some (PairOf D FortranExpr)++-- | An existential Fortran type.+type SomeType = Some D++--------------------------------------------------------------------------------+--  Semantics+--------------------------------------------------------------------------------++-- | A function mapping numeric kind annotations from Fortran programs to actual+-- precision, for a particular basic type `bt`.+newtype KindSelector = KindSelector { selectKind :: Integer -> Maybe Precision }++{-|++A (currently very incomplete) specification of the semantics of a particular+version of Fortran, needed when translating.++-}+data FortranSemantics =+  FortranSemantics+  { _fsIntegerKinds         :: KindSelector+  , _fsRealKinds            :: KindSelector+  , _fsCharacterKinds       :: KindSelector+  , _fsLogicalKinds         :: KindSelector+  , _fsDoublePrecisionKinds :: Maybe KindSelector+  }++makeLenses ''FortranSemantics++{-|++== /Kinds/++The default semantics has sensible defaults for kind 0 (unspecified). Otherwise,+the kind is the number of bytes used for the type's representation. Only+power-of-two values up to 8 are valid. Characters only allow single byte+precision. Reals only allow 4- or 8-byte precision.++-}+defaultSemantics :: FortranSemantics+defaultSemantics =+  FortranSemantics+  { _fsIntegerKinds = KindSelector $ \case+      0 -> Just P64+      1 -> Just P8+      2 -> Just P16+      4 -> Just P32+      8 -> Just P64+      _ -> Nothing+  , _fsRealKinds = KindSelector $ \case+      0 -> Just P32+      4 -> Just P32+      8 -> Just P64+      _ -> Nothing+  , _fsCharacterKinds = KindSelector $ \case+      0 -> Just P8+      _ -> Nothing+  , _fsLogicalKinds = KindSelector $ \case+      0 -> Just P8+      1 -> Just P8+      2 -> Just P16+      4 -> Just P32+      8 -> Just P64+      _ -> Nothing+  , _fsDoublePrecisionKinds = Nothing+  }+++--------------------------------------------------------------------------------+--  Translate Monad+--------------------------------------------------------------------------------++-- | In order to translate Fortran expressions, we require some information+-- about the environment. That information is capture in this record.+data TranslateEnv =+  TranslateEnv+  { _teImplicitVars :: Bool+    -- ^ Are implicit variable types enabled? (TODO: this currently does+    -- nothing)+  , _teVarsInScope  :: Map UniqueName SomeVar+    -- ^ A map of the variables in scope, including their types+  , _teSemantics    :: FortranSemantics+    -- ^ The version of Fortran's semantics to use when translating code.+  }++defaultTranslateEnv :: TranslateEnv+defaultTranslateEnv =+  TranslateEnv+  { _teImplicitVars = True+  , _teVarsInScope = mempty+  , _teSemantics = defaultSemantics+  }++makeLenses ''TranslateEnv++newtype TranslateT m a =+  TranslateT+  { getTranslateT+    :: ReaderT TranslateEnv (ExceptT TranslateError m) a+  }+  deriving ( Functor, Applicative, Monad+           , MonadError TranslateError+           , MonadReader TranslateEnv+           , MonadLogger e w+           )++runTranslateT+  :: (Monad m)+  => TranslateT m a+  -> TranslateEnv+  -> m (Either TranslateError a)+runTranslateT (TranslateT action) env = runExceptT $ runReaderT action env++--------------------------------------------------------------------------------+--  Errors+--------------------------------------------------------------------------------++data TranslateError+  = ErrUnsupportedItem Text+  -- ^ Tried to translate a part of the language that is not (yet) supported.+  | ErrBadLiteral+  -- ^ Found a literal value that we didn't know how to translate. May or may+  -- not be valid Fortran.+  | ErrUnexpectedType Text SomeType SomeType+  -- ^ @'ErrUnexpectedType' message expected actual@: tried to translate a+  -- Fortran language part into the wrong expression type, and it wasn't+  -- coercible to the correct type.+  | ErrInvalidOpApplication (Some (Rec D))+  -- ^ Tried to apply an operator to arguments with the wrong types.+  | ErrVarNotInScope F.Name+  -- ^ Reference to a variable that's not currently in scope+  | ErrInvalidKind Text Integer+  -- ^ @'ErrInvalidKind' baseTypeName givenKind@: tried to interpret a type with+  -- the given kind which is not valid under the semantics.+  deriving (Typeable)++instance Describe TranslateError where+  describeBuilder = \case+    ErrUnsupportedItem message ->+      "unsupported " <> describeBuilder message++    ErrBadLiteral ->+      "encountered a literal value that couldn't be translated; " <>+      "it might be invalid Fortran or it might use unsupported language features"++    ErrUnexpectedType message expected actual ->+      "unexpected type in " <> describeBuilder message <>+      "; expected type was '" <> describeBuilder (show expected) <>+      "'; actual type was '" <> describeBuilder (show actual) <> "'"++    ErrInvalidOpApplication (Some argTypes) ->+      let descTypes+            = recordToList+            . rmap (Const . surround "'" . describeBuilder . pretty1)+            $ argTypes+          surround s x = s <> x <> s+      in "tried to apply operator to arguments of the wrong type; arguments had types " <>+         mconcat (intersperse ", " descTypes)++    ErrVarNotInScope nm ->+      "reference to variable '" <> describeBuilder nm <> "' which is not in scope"++    ErrInvalidKind bt k ->+      "type with base '" <> describeBuilder bt <> "' specified a kind '" <>+      describeBuilder (show k) <> "' which is not valid under the current semantics"++unsupported :: (MonadError TranslateError m) => Text -> m a+unsupported = throwError . ErrUnsupportedItem++--------------------------------------------------------------------------------+--  Translating Types+--------------------------------------------------------------------------------++{-|++The different ways of specifying Fortran types are complicated. This record+contains information about all the different things that might contribute to a+type.++-}+data TypeInfo ann =+  TypeInfo+  { _tiSrcSpan              :: F.SrcSpan+  , _tiBaseType             :: F.BaseType+  , _tiSelectorLength       :: Maybe (F.Expression ann)+    -- ^ The length expression from a 'F.Selector' associated with a+    -- 'F.TypeSpec'.+  , _tiSelectorKind         :: Maybe (F.Expression ann)+    -- ^ The kind expression from a 'F.Selector' associated with a 'F.TypeSpec'.+  , _tiDeclaratorLength     :: Maybe (F.Expression ann)+    -- ^ The length expression from a 'F.Declarator' associated with an instance+    -- of 'F.StDeclaration'.+  , _tiDimensionDeclarators :: Maybe (F.AList F.DimensionDeclarator ann)+    -- ^ The list of dimension declarators from an instance of 'F.DeclArray'+    -- associated with an instance of 'F.StDeclaration'.+  , _tiAttributes           :: Maybe (F.AList F.Attribute ann)+    -- ^ The list of attributes from an instance of 'F.StDeclaration'.+  }+  deriving (Functor, Show)++makeLenses ''TypeInfo++instance F.Spanned (TypeInfo ann) where+  getSpan = view tiSrcSpan+  setSpan = set tiSrcSpan++-- | Create a simple 'TypeInfo' from an 'F.TypeSpec'. Many use cases will need+-- to add more information to fully specify the type.+typeInfo :: F.TypeSpec ann -> TypeInfo ann+typeInfo ts@(F.TypeSpec _ _ bt mselector) =+  let selectorLength (F.Selector _ _ l _) = l+      selectorKind (F.Selector _ _ _ k) = k+  in TypeInfo+     { _tiSrcSpan = F.getSpan ts+     , _tiBaseType = bt+     , _tiSelectorLength = mselector >>= selectorLength+     , _tiSelectorKind = mselector >>= selectorKind+     , _tiDeclaratorLength = Nothing+     , _tiDimensionDeclarators = Nothing+     , _tiAttributes = Nothing+     }+++-- | Convert a 'TypeInfo' to its corresponding strong type.+translateTypeInfo+  :: (Monad m, Show ann)+  => TypeInfo ann+  -> TranslateT m SomeType+translateTypeInfo ti = do+  -- TODO: Derived data types+  SomePrimD basePrim <- translateBaseType (ti ^. tiBaseType) (ti ^. tiSelectorKind)++  let+    -- If an attribute corresponds to a dimension declaration which contains a+    -- simple length dimension, get the expression out.+    attrToLength (F.AttrDimension _ _ declarators) = dimensionDeclaratorsToLength declarators+    attrToLength _                           = Nothing++    attrsToLength (F.AList _ _ attrs) =+      case catMaybes (attrToLength <$> attrs) of+        [e] -> Just e+        _   -> Nothing++    -- If a list of dimension declarators corresponds to a simple one+    -- dimensional length, get the expression out. We don't handle other cases+    -- yet.+    dimensionDeclaratorsToLength (F.AList _ _ [F.DimensionDeclarator _ _ e1 e2]) = e1 <|> e2+    dimensionDeclaratorsToLength _ = Nothing++    mLengthExp =+      (ti ^. tiSelectorLength) <|>+      (ti ^. tiDeclaratorLength) <|>+      (ti ^. tiDimensionDeclarators >>= dimensionDeclaratorsToLength) <|>+      (ti ^. tiAttributes >>= attrsToLength)++  case mLengthExp of+    Just lengthExp -> do+      -- If a length expression could be found, this variable is an array++      -- TODO: If the length expression is malformed, throw an error.+      -- TODO: Use information about the length.+      -- maybe (unsupported "type spec") void (exprIntLit lengthExp)+      case basePrim of+        DPrim bp -> return (Some (DArray (Index PInt64) (ArrPrim bp)))+    Nothing ->+      return (Some basePrim)+++data SomePrimD where+  SomePrimD :: D (PrimS a) -> SomePrimD++translateBaseType+  :: (Monad m)+  => F.BaseType+  -> Maybe (F.Expression ann) -- ^ Kind+  -> TranslateT m SomePrimD+translateBaseType bt mkind = do++  kindInt <- case mkind of+    Nothing -> return 0+    Just (F.ExpValue _ _ (F.ValInteger s)) ->+      case readLitInteger s of+        Just k  -> return k+        Nothing -> throwError ErrBadLiteral+    _ -> unsupported "kind which isn't an integer literal"++  let getKindPrec btName ksl = do+        mks <- preview (teSemantics . ksl)+        case mks >>= (`selectKind` kindInt) of+          Just p  -> return p+          Nothing -> throwError $ ErrInvalidKind btName kindInt++  -- Get value-level representations of the type's basic type and precision+  (basicType, prec) <- case bt of+    F.TypeInteger   -> (BTInt     ,) <$> getKindPrec "integer"   fsIntegerKinds+    F.TypeReal      -> (BTReal    ,) <$> getKindPrec "real"      fsRealKinds+    F.TypeCharacter -> (BTChar    ,) <$> getKindPrec "character" fsCharacterKinds+    F.TypeLogical   -> (BTLogical ,) <$> getKindPrec "logical"   fsLogicalKinds+    -- Double precision is special because it's not always supported as its own+    -- basic type, being subsumed by the `REAL` basic type.+    F.TypeDoublePrecision ->+      (BTReal,) <$> getKindPrec "double precision" (fsDoublePrecisionKinds . _Just)+    _ -> unsupported "type spec"++  -- Lift the value-level representations to the type level and get a primitive+  -- type with those properties.+  case (toSing basicType, toSing prec) of+    (SomeSing sbt, SomeSing sprec) -> case makePrim sprec sbt of+      Just (MakePrim prim) -> return (SomePrimD (DPrim prim))+      Nothing              -> unsupported "type spec"++--------------------------------------------------------------------------------+--  Translating Expressions+--------------------------------------------------------------------------------++-- | Translate an expression with an unknown type. The return value+-- existentially captures the type of the result.+translateExpression :: (Monad m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr+translateExpression = \case+  e@(F.ExpValue ann span val) -> translateValue e+  F.ExpBinary ann span bop e1 e2 -> translateOp2App e1 e2 bop+  F.ExpUnary ann span uop operand -> translateOp1App operand uop++  F.ExpSubscript ann span lhs (F.AList _ _ indices) -> translateSubscript lhs indices++  F.ExpDataRef ann span e1 e2           -> unsupported "data reference"+  F.ExpFunctionCall ann span fexpr args -> unsupported "function call"+  F.ExpImpliedDo ann span es spec       -> unsupported "implied do expression"+  F.ExpInitialisation ann span es       -> unsupported "intitialization expression"+  F.ExpReturnSpec ann span rval         -> unsupported "return spec expression"+++-- | Translate an expression with a known type. Fails if the actual type does+-- not match.+translateExpression'+  :: (Monad m) => D a -> F.Expression (F.Analysis ann)+  -> TranslateT m (FortranExpr a)+translateExpression' targetD ast = do+  SomePair sourceD expr <- translateExpression ast++  case dcast sourceD targetD expr of+    Just y -> return y+    Nothing -> throwError $ ErrUnexpectedType "expression" (Some sourceD) (Some targetD)+++-- | Translate an expression and try to coerce it to a particular type. Fails if+-- the actual type cannot be coerced to the given type.+translateCoerceExpression+  :: (Monad m) => D a -> F.Expression (F.Analysis ann)+  -> TranslateT m (HFree MetaOp FortranExpr a)+translateCoerceExpression targetD ast = do+  SomePair sourceD expr <- translateExpression ast++  -- First check if it's already the right type+  case dcast sourceD targetD expr of+    Just y -> return (HPure y)+    Nothing -> case (matchPrimD sourceD, matchPrimD targetD) of+      (Just (MatchPrimD _ sourcePrim), Just (MatchPrimD _ targetPrim)) ->+        return (HWrap (MopCoercePrim targetPrim (HPure expr)))+      _ -> throwError $ ErrUnexpectedType "expression" (Some sourceD) (Some targetD)+++translateSubscript+  :: (Monad m)+  => F.Expression (F.Analysis ann) -> [F.Index (F.Analysis ann)] -> TranslateT m SomeExpr+translateSubscript arrAst [F.IxSingle _ _ _ ixAst] = do+  SomePair arrD arrExp <- translateExpression arrAst+  SomePair ixD ixExp <- translateExpression ixAst++  case matchOpSpec OpLookup (arrD :& ixD :& RNil) of+    Just (MatchOpSpec opResult resultD) ->+      return $ SomePair resultD $ HWrap $ CoreOp OpLookup opResult (arrExp :& ixExp :& RNil)+    Nothing ->+      case arrD of+        -- If the LHS is indeed an array, the index type must not have matched+        DArray (Index requiredIx) _ ->+          throwError $+          ErrUnexpectedType "array indexing"+          (Some (DPrim requiredIx)) (Some ixD)+        -- If the LHS is not an array, tell the user we expected some specific+        -- array type; in reality any array type would have done.+        _ -> throwError $+          ErrUnexpectedType "array indexing"+          (Some (DArray (Index PInt64) (ArrPrim PInt64)))+          (Some arrD)++translateSubscript lhs [F.IxRange {}] =+  unsupported "range indices"+translateSubscript _ _ =+  unsupported "multiple indices"+++-- | Translate a source 'F.Value' to a strongly-typed expression. Accepts an+-- 'F.Expression' which is expected to be an 'F.ExpValue' because it needs+-- access to annotations to get unique names, and 'F.Value' doesn't have any+-- annotations of its own.+--+-- Do not call on an expression that you don't know to be an 'F.ExpValue'!+translateValue :: (Monad m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr+translateValue e = case e of+  F.ExpValue _ _ v -> case v of+    F.ValInteger s -> translateLiteral v PInt64 (fmap fromIntegral . readLitInteger) s+    F.ValReal    s -> translateLiteral v PFloat (fmap realToFrac . readLitReal) s++    -- TODO: Auxiliary variables+    F.ValVariable nm -> do+      let uniq = UniqueName (F.varName e)+      theVar <- view (teVarsInScope . at uniq)+      case theVar of+        Just (Some v'@(FortranVar d _)) -> return (SomePair d (HPure v'))+        _                               -> throwError $ ErrVarNotInScope nm++    F.ValLogical s ->+      let intoBool = fmap (\b -> if b then Bool8 1 else Bool8 0) . readLitBool+      in translateLiteral v PBool8 intoBool s++    F.ValComplex r c  -> unsupported "complex literal"+    F.ValString s     -> unsupported "string literal"+    F.ValHollerith s  -> unsupported "hollerith literal"+    F.ValIntrinsic nm -> unsupported $ "intrinsic " <> describe nm+    F.ValOperator s   -> unsupported "user-defined operator"+    F.ValAssignment   -> unsupported "interface assignment"+    F.ValType s       -> unsupported "type value"+    F.ValStar         -> unsupported "star value"+  _ -> fail "impossible: translateValue called on a non-value"+++translateLiteral+  :: (Monad m)+  => F.Value ann+  -> Prim p k a -> (s -> Maybe a) -> s+  -> TranslateT m SomeExpr+translateLiteral v pa readLit+  = maybe (throwError ErrBadLiteral) (return . SomePair (DPrim pa) . flit pa)+  . readLit+  where+    flit px x = HWrap (CoreOp OpLit (OSLit px x) RNil)+++translateOp1 :: F.UnaryOp -> Maybe (Some (Op 1))+translateOp1 = \case+  F.Minus -> Just (Some OpNeg)+  F.Plus -> Just (Some OpPos)+  F.Not -> Just (Some OpNot)+  _ -> Nothing+++translateOp2 :: F.BinaryOp -> Maybe (Some (Op 2))+translateOp2 = \case+  F.Addition -> Just (Some OpAdd)+  F.Subtraction -> Just (Some OpSub)+  F.Multiplication -> Just (Some OpMul)+  F.Division -> Just (Some OpDiv)++  F.LT -> Just (Some OpLT)+  F.GT -> Just (Some OpGT)+  F.LTE -> Just (Some OpLE)+  F.GTE -> Just (Some OpGE)++  F.EQ -> Just (Some OpEq)+  F.NE -> Just (Some OpNE)++  F.And -> Just (Some OpAnd)+  F.Or -> Just (Some OpOr)+  F.Equivalent -> Just (Some OpEquiv)+  F.NotEquivalent -> Just (Some OpNotEquiv)++  _ -> Nothing+++data HasLength n as where+  HasLength :: Length as ~ n => HasLength n as++-- | Given a record of 'Some' functorial types, return 'Some' record over the+-- list of those types.+--+-- In the return value, @'Some' ('PairOf' ('HasLength' n) ('Rec' f))@ is a record over+-- an unknown list of types, with the constraint that the unknown list has+-- length @n@.+recSequenceSome :: Rec (Const (Some f)) xs -> Some (PairOf (HasLength (Length xs)) (Rec f))+recSequenceSome RNil = SomePair HasLength RNil+recSequenceSome (x :& xs) = case (x, recSequenceSome xs) of+  (Const (Some y), Some (PairOf HasLength ys)) -> SomePair HasLength (y :& ys)+++-- This is way too general for its own good but it was fun to write.+translateOpApp+  :: (Monad m)+  => (Length xs ~ n)+  => Op n ok+  -> Rec (Const (F.Expression (F.Analysis ann))) xs -> TranslateT m SomeExpr+translateOpApp operator argAsts = do+  someArgs <- recSequenceSome <$> rtraverse (fmap Const . translateExpression . getConst) argAsts++  case someArgs of+    Some (PairOf HasLength argsTranslated) -> do+      let argsD = rmap (\(PairOf d _) -> d) argsTranslated+          argsExpr = rmap (\(PairOf _ e) -> e) argsTranslated++      MatchOpSpec opResult resultD <- case matchOpSpec operator argsD of+        Just x  -> return x+        Nothing -> throwError $ ErrInvalidOpApplication (Some argsD)++      return $ SomePair resultD $ HWrap $ CoreOp operator opResult argsExpr+++translateOp2App+  :: (Monad m)+  => F.Expression (F.Analysis ann) -> F.Expression (F.Analysis ann) -> F.BinaryOp+  -> TranslateT m SomeExpr+translateOp2App e1 e2 bop = do+  Some operator <- case translateOp2 bop of+    Just x  -> return x+    Nothing -> unsupported "binary operator"+  translateOpApp operator (Const e1 :& Const e2 :& RNil)+++translateOp1App+  :: (Monad m)+  => F.Expression (F.Analysis ann) -> F.UnaryOp+  -> TranslateT m SomeExpr+translateOp1App e uop = do+  Some operator <- case translateOp1 uop of+    Just x  -> return x+    Nothing -> unsupported "unary operator"+  translateOpApp operator (Const e :& RNil)++--------------------------------------------------------------------------------+--  Readers for things that are strings in the AST+--------------------------------------------------------------------------------++readLitInteger :: String -> Maybe Integer+readLitInteger = readMaybe++readLitReal :: String -> Maybe Double+readLitReal = readMaybe++readLitBool :: String -> Maybe Bool+readLitBool l = case map toLower l of+  ".true."  -> Just True+  ".false." -> Just False+  _         -> Nothing
+ src/Language/Fortran/Model/Types.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}++{-# OPTIONS_GHC -Wall #-}++-- TODO: Complex Numbers++{-|++Embeds Fortran's type system in Haskell via the 'D' GADT.++== Note: Phantom Types and GADTs++Lots of the data types in this module are parameterised by phantom types. These+are types which appear at the type-level, but not at the value level. They are+there to make things more type-safe.++In addition, a lot of the data types are GADTs. In a phantom-type-indexed GADT,+the phantom type often restricts which GADT constructors a particular value may+be an instance of. This is very useful for restricting value-level terms based+on type-level information.++-}++module Language.Fortran.Model.Types where++import           Data.Int                              (Int16, Int32, Int64,+                                                        Int8)+import           Data.List                             (intersperse)+import           Data.Monoid                           (Endo (..))+import           Data.Typeable                         (Typeable)+import           Data.Word                             (Word8)++import           Data.Singletons.TypeLits++import           Data.Vinyl                            hiding (Field)+import           Data.Vinyl.Functor++import           Language.Expression.Pretty++import           Language.Fortran.Model.Singletons++--------------------------------------------------------------------------------+-- * Fortran Types++{-|++This is the main embedding of Fortran types. A value of type @D a@ represents+the Fortran type which corresponds to the Haskell type @a@. @a@ is a phantom+type parameter. There is at most one instance of @D a@ for each @a@. This means+that a value of type @D a@ acts as a kind of proof that it possible to have a+Fortran type corresponding to the Haskell type @a@ -- and that when you match on+@D a@ knowing the particular @a@ you have, you know which constructor you will+get. This is a nice property because it means that GHC (with+@-fwarn-incomplete-patterns@) will not warn when you match on an impossible+case. It eliminates situations where you'd otherwise write @error "impossible:+..."@.++* @'DPrim' p :: D ('PrimS' a)@ is for primitive types. It contains a value @p@+  of type @'Prim' p k a@ for some @p@, @k@, @a@. When matching on something of+  type @D ('PrimS' a)@, you know it can only contain a primitive type.++* @'DArray' i v :: D ('Array' i v)@ is for arrays. It contains instances of @'Index'+  i@ and @'ArrValue' a@. @'Index' i@ is a proof that @i@ can be used as an index,+  and @'ArrValue' a@ is a proof that @a@ can be stored in arrays.++* @'DData' s xs :: D ('Record' name fs)@ is for user-defined data types. The+  type has a name, represented at the type level by the type parameter @name@ of+  kind 'Symbol'. The constructor contains @s :: 'SSymbol' name@, which acts as a+  sort of value-level representation of the name. 'SSymbol' is from the+  @singletons@ library. It also contains @xs :: 'Rec' ('Field' D) fs@. @fs@ is a+  type-level list of pairs, pairing field names with field types. @'Field' D+  '(fname, b)@ is a value-level pair of @'SSymbol' fname@ and @D b@. The vinyl+  record is a list of fields, one for each pair in @fs@.++-}+data D a where+  DPrim :: Prim p k a -> D (PrimS a)+  DArray :: Index i -> ArrValue a -> D (Array i a)+  DData :: SSymbol name -> Rec (Field D) fs -> D (Record name fs)++--------------------------------------------------------------------------------+-- * Semantic Types++newtype Bool8  = Bool8 { getBool8 :: Int8 } deriving (Show, Num, Eq, Typeable)+newtype Bool16 = Bool16 { getBool16 :: Int16 } deriving (Show, Num, Eq, Typeable)+newtype Bool32 = Bool32 { getBool32 :: Int32 } deriving (Show, Num, Eq, Typeable)+newtype Bool64 = Bool64 { getBool64 :: Int64 } deriving (Show, Num, Eq, Typeable)+newtype Char8  = Char8 { getChar8 :: Word8 } deriving (Show, Num, Eq, Typeable)++{-|++This newtype wrapper is used in 'DPrim' for semantic primitive types. This means+that when matching on something of type @'D' ('PrimS' a)@, we know it can't be+an array or a record.++-}+newtype PrimS a = PrimS { getPrimS :: a }+  deriving (Show, Eq, Typeable)++--------------------------------------------------------------------------------+-- * Primitive Types++{-|++Lists the allowed primitive Fortran types. For example, @'PInt8' :: 'Prim' 'P8+''BTInt' 'Int8'@ represents 8-bit integers. 'Prim' has three phantom type+parameters: precision, base type and semantic Haskell type. Precision is the+number of bits used to store values of that type. The base type represents the+corresponding Fortran base type, e.g. @integer@ or @real@. Constructors are only+provided for those Fortran types which are semantically valid, so for example no+constructor is provided for a 16-bit real. A value of type @'Prim' p k a@ can be+seen as a proof that there is some Fortran primitive type with those parameters.++-}+data Prim p k a where+  PInt8          :: Prim 'P8   'BTInt     Int8+  PInt16         :: Prim 'P16  'BTInt     Int16+  PInt32         :: Prim 'P32  'BTInt     Int32+  PInt64         :: Prim 'P64  'BTInt     Int64++  PBool8         :: Prim 'P8   'BTLogical Bool8+  PBool16        :: Prim 'P16  'BTLogical Bool16+  PBool32        :: Prim 'P32  'BTLogical Bool32+  PBool64        :: Prim 'P64  'BTLogical Bool64++  PFloat         :: Prim 'P32  'BTReal    Float+  PDouble        :: Prim 'P64  'BTReal    Double++  PChar          :: Prim 'P8   'BTChar    Char8++--------------------------------------------------------------------------------+-- * Arrays++-- | Specifies which types can be used as array indices.+data Index a where+  Index :: Prim p 'BTInt a -> Index (PrimS a)++-- | Specifies which types can be stored in arrays. Currently arrays of arrays+-- are not supported.+data ArrValue a where+  ArrPrim :: Prim p k a -> ArrValue (PrimS a)+  ArrData :: SSymbol name -> Rec (Field ArrValue) fs -> ArrValue (Record name fs)+++-- | An array with a phantom index type. Mostly used at the type-level to+-- constrain instances of @'D' (Array i a)@ etc.+newtype Array i a = Array [a]++--------------------------------------------------------------------------------+-- * Records++-- | A field over a pair of name and value type.+data Field f field where+  Field :: SSymbol name -> f a -> Field f '(name, a)++-- | A type of records with the given @name@ and @fields@. Mostly used at the+-- type level to constrain instances of @'D' (Record name fields)@ etc.+data Record name fields where+  Record :: SSymbol name -> Rec (Field Identity) fields -> Record name fields++--------------------------------------------------------------------------------+-- * Combinators++-- | Any Fortran index type is a valid Fortran type.+dIndex :: Index i -> D i+dIndex (Index p) = DPrim p++-- | Anything that can be stored in Fortran arrays is a valid Fortran type.+dArrValue :: ArrValue a -> D a+dArrValue (ArrPrim p) = DPrim p+dArrValue (ArrData nameSym fieldArrValues) =+  DData nameSym (rmap (overField' dArrValue) fieldArrValues)++-- | Given a field with known contents, we can change the functor and value+-- type.+overField :: (f a -> g b) -> Field f '(name, a) -> Field g '(name, b)+overField f (Field n x) = Field n (f x)++-- | Given a field with unknown contents, we can change the functor but not the+-- value type.+overField' :: (forall a. f a -> g a) -> Field f nv -> Field g nv+overField' f (Field n x) = Field n (f x)++traverseField' :: (Functor t) => (forall a. f a -> t (g a)) -> Field f nv -> t (Field g nv)+traverseField' f (Field n x) = Field n <$> f x++-- | Combine two fields over the same name-value pair but (potentially)+-- different functors.+zipFieldsWith :: (forall a. f a -> g a -> h a) -> Field f nv -> Field g nv -> Field h nv+zipFieldsWith f (Field _ x) (Field n y) = Field n (f x y)++zip3FieldsWith+  :: (forall a. f a -> g a -> h a -> i a)+  -> Field f nv+  -> Field g nv+  -> Field h nv+  -> Field i nv+zip3FieldsWith f (Field _ x) (Field _ y) (Field n z) = Field n (f x y z)++--------------------------------------------------------------------------------+--  Pretty Printing++instance Pretty1 (Prim p k) where+  prettys1Prec p = \case+    PInt8   -> showString "integer8"+    PInt16  -> showString "integer16"+    PInt32  -> showString "integer32"+    PInt64  -> showString "integer64"+    PFloat  -> showString "real"+    PDouble -> showParen (p > 8) $ showString "double precision"+    PBool8  -> showString "logical8"+    PBool16 -> showString "logical16"+    PBool32 -> showString "logical32"+    PBool64 -> showString "logical64"+    PChar   -> showString "character"++instance Pretty1 ArrValue where+  prettys1Prec p = prettys1Prec p . dArrValue++instance (Pretty1 f) => Pretty1 (Field f) where+  prettys1Prec _ = \case+    Field fname x ->+      prettys1Prec 0 x .+      showString " " .+      withKnownSymbol fname (showString (symbolVal fname))++-- | e.g. "type custom_type { character a, integer array b }"+instance Pretty1 D where+  prettys1Prec p = \case+    DPrim px -> prettys1Prec p px+    DArray _ pv -> prettys1Prec p pv . showString " array"+    DData rname fields ->+        showParen (p > 8)+      $ showString "type "+      . withKnownSymbol rname (showString (symbolVal rname))+      . showString "{ "+      . appEndo ( mconcat+              . intersperse (Endo $ showString ", ")+              . recordToList+              . rmap (Const . Endo . prettys1Prec 0)+              $ fields)+      . showString " }"
+ src/Language/Fortran/Model/Types/Match.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeOperators              #-}++{-# OPTIONS_GHC -Wall #-}++-- TODO: Complex Numbers++module Language.Fortran.Model.Types.Match where++import           Data.Typeable++import           Data.Singletons+import           Data.Singletons.TypeLits+import           GHC.TypeLits++import           Data.Vinyl                        hiding ((:~:), Field)++import           Language.Fortran.Model.Singletons+import           Language.Fortran.Model.Types++--------------------------------------------------------------------------------+--  Matching on properties of types+--------------------------------------------------------------------------------++data MatchPrim p k a where+  MatchPrim :: Sing p -> Sing k -> MatchPrim p k a++matchPrim :: Prim p k a -> MatchPrim p k a+matchPrim = \case+  PInt8   -> MatchPrim sing sing+  PInt16  -> MatchPrim sing sing+  PInt32  -> MatchPrim sing sing+  PInt64  -> MatchPrim sing sing+  PFloat  -> MatchPrim sing sing+  PDouble -> MatchPrim sing sing+  PBool8  -> MatchPrim sing sing+  PBool16 -> MatchPrim sing sing+  PBool32 -> MatchPrim sing sing+  PBool64 -> MatchPrim sing sing+  PChar   -> MatchPrim sing sing+++data MatchPrimD a where+  MatchPrimD :: MatchPrim p k a -> Prim p k a -> MatchPrimD (PrimS a)++-- | Checks if the given type is primitive, and if so returns a proof of that+-- fact.+matchPrimD :: D a -> Maybe (MatchPrimD a)+matchPrimD = \case+  DPrim p -> Just (MatchPrimD (matchPrim p) p)+  _ -> Nothing+++data MakePrim p k where+  MakePrim :: Prim p k a -> MakePrim p k++-- | Tries to make a primitive type with the given precision and kind. Fails if+-- there is no primitive with the given combination.+makePrim :: Sing p -> Sing k -> Maybe (MakePrim p k)+makePrim = curry $ \case+  (SP8, SBTInt)      -> Just $ MakePrim PInt8+  (SP16, SBTInt)     -> Just $ MakePrim PInt16+  (SP32, SBTInt)     -> Just $ MakePrim PInt32+  (SP64, SBTInt)     -> Just $ MakePrim PInt64+  (SP32, SBTReal)    -> Just $ MakePrim PFloat+  (SP64, SBTReal)    -> Just $ MakePrim PDouble+  (SP8, SBTLogical)  -> Just $ MakePrim PBool8+  (SP16, SBTLogical) -> Just $ MakePrim PBool16+  (SP32, SBTLogical) -> Just $ MakePrim PBool32+  (SP64, SBTLogical) -> Just $ MakePrim PBool64+  (SP8, SBTChar)     -> Just $ MakePrim PChar+  _ -> Nothing++--------------------------------------------------------------------------------+--  Equality of Fortran types+--------------------------------------------------------------------------------++eqSymbol :: forall n1 n2. SSymbol n1 -> SSymbol n2 -> Maybe (n1 :~: n2)+eqSymbol n1 n2 = withKnownSymbol n1 $ withKnownSymbol n2 $ sameSymbol (Proxy :: Proxy n1) (Proxy :: Proxy n2)+++eqPrim :: Prim p1 k1 a -> Prim p2 k2 b -> Maybe ('(p1, k1, a) :~: '(p2, k2, b))+eqPrim = curry $ \case+  (PInt8, PInt8) -> Just Refl+  (PInt16, PInt16) -> Just Refl+  (PInt32, PInt32) -> Just Refl+  (PInt64, PInt64) -> Just Refl+  (PBool8, PBool8) -> Just Refl+  (PBool16, PBool16) -> Just Refl+  (PBool32, PBool32) -> Just Refl+  (PBool64, PBool64) -> Just Refl+  (PFloat, PFloat) -> Just Refl+  (PDouble, PDouble) -> Just Refl+  (PChar, PChar) -> Just Refl+  _ -> Nothing+++eqField :: (forall x y. f x -> g y -> Maybe (x :~: y)) -> Field f p1 -> Field g p2 -> Maybe (p1 :~: p2)+eqField eqVals = curry $ \case+  (Field n1 x1, Field n2 x2) ->+    case (eqSymbol n1 n2, eqVals x1 x2) of+      (Just Refl, Just Refl) -> Just Refl+      _                      -> Nothing+++eqRec :: (forall a b. t a -> t b -> Maybe (a :~: b)) -> Rec (Field t) fs -> Rec (Field t) gs -> Maybe (fs :~: gs)+eqRec eqInside = curry $ \case+  (RNil, RNil) -> Just Refl+  (h1 :& t1, h2 :& t2) ->+    case (eqField eqInside h1 h2, eqRec eqInside t1 t2) of+      (Just Refl, Just Refl) -> Just Refl+      _                      -> Nothing+  _ -> Nothing+++eqArrValue :: ArrValue a -> ArrValue b -> Maybe (a :~: b)+eqArrValue a1 a2 = eqD (dArrValue a1) (dArrValue a2)+++eqD :: D a -> D b -> Maybe (a :~: b)+eqD = curry $ \case+  (DPrim p1, DPrim p2) ->+    case eqPrim p1 p2 of+      Just Refl -> Just Refl+      _         -> Nothing+  (DArray (Index i1) av1, DArray (Index i2) av2) ->+    case (eqPrim i1 i2, eqArrValue av1 av2) of+      (Just Refl, Just Refl) -> Just Refl+      _ -> Nothing+  (DData n1 r1, DData n2 r2) ->+    case (eqSymbol n1 n2, eqRec eqD r1 r2) of+      (Just Refl, Just Refl) -> Just Refl+      _                      -> Nothing+  _ -> Nothing+++dcast :: D a -> D b -> f a -> Maybe (f b)+dcast d1 d2 = case eqD d1 d2 of+  Just Refl -> Just+  _         -> const Nothing
+ src/Language/Fortran/Model/Util.hs view
@@ -0,0 +1,59 @@++{-|++Miscellaneous combinators.++-}+module Language.Fortran.Model.Util where++import           Control.Applicative+import           Control.Monad.Reader++import           Data.Function       ((&), on)++--------------------------------------------------------------------------------+--  Combinators+--------------------------------------------------------------------------------++-- | Like 'on', but apply a different function to each argument (which are+-- allowed to have different types).+on2 :: (c -> d -> e) -> (a -> c) -> (b -> d) -> a -> b -> e+on2 h g f = (h . g) *.. f+++-- | '..*' in the Kleisli category.+matchingWithBoth :: (Monad m) => (a -> b -> m c) -> (c -> m r) -> a -> b -> m r+matchingWithBoth f k = (>>= k) ..* f+++-- | 'on2' in the Kleisli category.+matchingWith2 :: (Monad m) => (a -> m a') -> (b -> m b') -> ((a', b') -> m r) -> a -> b -> m r+matchingWith2 = matchingWithBoth ..* on2 (liftA2 (,))+++-- | Alternative @('<|>')@ over single-argument functions.+altf :: (Alternative f) => (a -> f b) -> (a -> f b) -> a -> f b+altf = runReaderT ..* (<|>) `on` ReaderT+++-- | Alternative @('<|>')@ over two-argument functions.+altf2 :: (Alternative f) => (a -> b -> f c) -> (a -> b -> f c) -> a -> b -> f c+altf2 = curry ..* altf `on` uncurry++-- | Flipped 'fmap'.+(<$$>) :: (Functor f) => f a -> (a -> b) -> f b+(<$$>) = flip (<$>)++-- | Flipped function application.+with :: a -> (a -> b) -> b+with = (&)++-- | @(f *.. g) x y = f x (g y)@. Mnemonic: the @*@ is next to the function+-- which has two arguments.+(*..) :: (a -> c -> d) -> (b -> c) -> a -> b -> d+(f *.. g) x y = f x (g y)++-- | @(f ..* g) x y = f (g x y)@. Mnemonic: the @*@ is next to the function+-- which has two arguments.+(..*) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+f ..* g = curry (f . uncurry g)
+ src/Language/Fortran/Model/Vars.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}++{-# OPTIONS_GHC -Wall #-}++-- TODO: Variables for user-defined data types++{-|++Defines a strongly-typed representation of Fortran variables.++-}+module Language.Fortran.Model.Vars+  (+    -- * Variables+    FortranVar(..)+    -- * Names+  , NamePair(..)+  , npSource+  , npUnique+  , SourceName(..)+  , UniqueName(..)+  ) where++import           Data.Typeable                      ((:~:) (..))++import           Control.Lens                       hiding (Index, op)++import           Data.SBV.Dynamic++import           Data.Vinyl                         (rtraverse)++import qualified Language.Fortran.AST               as F++import           Language.Expression.Pretty+import           Language.Verification++import           Language.Fortran.Model.Repr+import           Language.Fortran.Model.Repr.Prim+import           Language.Fortran.Model.Types+import           Language.Fortran.Model.Types.Match++--------------------------------------------------------------------------------+--  Names+--------------------------------------------------------------------------------++-- | Newtype wrapper for source-level variable names.+newtype SourceName = SourceName { getSourceName :: F.Name }+  deriving (Eq, Ord)++instance Show SourceName where show = show . getSourceName++-- | Newtype wrapper for unique variable names.+newtype UniqueName = UniqueName { getUniqueName :: F.Name }+  deriving (Eq, Ord)++instance Show UniqueName where show = show . getUniqueName++makeWrapped ''SourceName+makeWrapped ''UniqueName++-- | A 'NamePair' represents the name of some part of a Fortran program,+-- including the human-readable source name and the unique name.+data NamePair =+  NamePair+  { _npUnique :: UniqueName+  , _npSource :: SourceName+  }+  deriving (Eq, Ord, Show)++makeLenses ''NamePair++instance Pretty SourceName where+  pretty = view _Wrapped++-- | The pretty version of a 'NamePair' is its source name.+instance Pretty NamePair where+  pretty = pretty . view npSource++--------------------------------------------------------------------------------+--  Fortran Variables+--------------------------------------------------------------------------------++-- | A variable representing a value of type @a@. Contains a @'D' a@ as proof+-- that the type has a corresponding Fortran type, and the variable name.+data FortranVar a where+  FortranVar :: D a -> NamePair -> FortranVar a++instance VerifiableVar FortranVar where+  type VarKey FortranVar = UniqueName+  type VarSym FortranVar = CoreRepr+  type VarEnv FortranVar = PrimReprHandlers++  symForVar (FortranVar d np) env =+    case d of+      DPrim prim -> CRPrim d <$> primSymbolic prim uniqueName env+      DArray i val -> CRArray d <$> arraySymbolic i val uniqueName env+      DData _ _ -> fail "User-defined data type variables are not supported yet"+    where+      uniqueName = np ^. npUnique . _Wrapped++  varKey (FortranVar _ np) = np ^. npUnique++  eqVarTypes (FortranVar d1 _) (FortranVar d2 _) = eqD d1 d2++  castVarSym (FortranVar d1 _) s = case s of+    CRPrim d2 _  | Just Refl <- eqD d1 d2 -> Just s+    CRArray d2 _ | Just Refl <- eqD d1 d2 -> Just s+    CRData d2 _  | Just Refl <- eqD d1 d2 -> Just s++    -- Variables can't have the 'Bool' type so 'CRProp' can't be casted.+    _            -> Nothing++instance Pretty1 FortranVar where+  pretty1 (FortranVar _ np) = pretty np++--------------------------------------------------------------------------------+--  Internals+--------------------------------------------------------------------------------++arraySymbolic :: (HasPrimReprHandlers r) => Index i -> ArrValue a -> String -> r -> Symbolic (ArrRepr i a)+arraySymbolic ixIndex@(Index ixPrim) valAV nm env =+  case valAV of+    ArrPrim valPrim -> ARPrim <$> arraySymbolicPrim ixPrim valPrim nm env+    ArrData _ valData -> do+      valReprs <- rtraverse (traverseField' (\av -> arraySymbolic ixIndex av nm env)) valData+      return $ ARData valReprs++arraySymbolicPrim :: (HasPrimReprHandlers r) => Prim p1 k1 i -> Prim p2 k2 a -> String -> r -> Symbolic SArr+arraySymbolicPrim ixPrim valPrim nm = do+  k1 <- primSBVKind ixPrim+  k2 <- primSBVKind valPrim+  return $ newSArr (k1, k2) (\i -> nm ++ "_" ++ show i)++-- pairProxy :: p1 a -> p2 b -> Proxy '(a, b)+-- pairProxy _ _ = Proxy
src/Main.hs view
@@ -17,41 +17,134 @@  module Main (main) where +import Camfort.Analysis.Logger (LogLevel(..)) import Camfort.Input (defaultValue) import Camfort.Functionality-import Camfort.Specification.Stencils.InferenceFrontend (InferMode(..)) import Camfort.Specification.Units.Monad (LiteralsOpt(LitMixed))+import Camfort.Specification.Hoare (PrimReprOption(..))  import Data.Maybe (fromMaybe) import Data.Monoid ((<>))-+import System.Directory (getCurrentDirectory)+import System.Exit import Options.Applicative +main :: IO ()+main = do+  currentDir <- getCurrentDirectory+  cmd <- execParser (info (commandParser currentDir) idm)+  code <- runCommand cmd+  if code == 0+    then exitWith ExitSuccess+    else exitWith $ ExitFailure code+  where+    env ro lo = CamfortEnv+      { ceInputSources = inputSource ro+      , ceIncludeDir = includeDir ro+      , ceExcludeFiles = getExcludes ro+      , ceLogLevel = logLevel lo+      } +    getExcludes = fromMaybe [] . exclude++    getOutputFile _ (WriteFile f) = f+    getOutputFile inp WriteInplace = inp++    runRO ro lo f = f (env ro lo)+    runSIO sio f =+      let ro      = sioReadOptions sio+          lo      = sioLogOptions sio+          useEval = sioUseEval sio+          inFile  = inputSource ro+      in runRO ro lo (f useEval)+    runSSO sso f =+      let ao     = ssoAnnotationOptions sso+          wo     = ssoWriteOptions sso+          ro     = ssoReadOptions sso+          lo     = ssoLogOptions sso+          inFile = inputSource ro+      in runRO ro lo (f (annotationType ao) (getOutputFile inFile wo))+    runUO uo f =+      let ro = uoReadOptions uo+          lo = uoLogOptions uo+      in runRO ro lo (f (literals uo))+    runUWO uwo f =+      let uo     = uwoUnitsOptions uwo+          ro     = uoReadOptions uo+          wo     = uwoWriteOptions uwo+          inFile = inputSource ro+      in runUO uo (f (getOutputFile inFile wo))+    runUSO uso f =+      let uwo = usoUnitsWriteOptions uso+          ao  = usoAnnotationOptions uso+      in runUWO uwo (f (annotationType ao))+    runIO io f =+      let ro = ioReadOptions io+          lo = ioLogOptions io+          pro = ioPrimReprOption io+      in runRO ro lo (f pro)+    runRFO rfo f =+      let ro     = rfoReadOptions rfo+          lo     = rfoLogOptions rfo+          wo     = rfoWriteOptions rfo+          inFile = inputSource ro+      in runRO ro lo (f (getOutputFile inFile wo))++    runCommand :: Command -> IO Int+    runCommand (CmdAST ro lo)             = runRO ro lo ast >> return 0+    runCommand (CmdCount ro lo)           = runRO ro lo countVarDecls+    runCommand (CmdStencilsCheck ro lo)   = runRO ro lo stencilsCheck+    runCommand (CmdStencilsInfer so)      = runSIO so stencilsInfer+    runCommand (CmdStencilsSynth sso)     = runSSO sso stencilsSynth+    runCommand (CmdUnitsSuggest uo)       = runUO uo unitsCriticals+    runCommand (CmdUnitsCheck uo)         = runUO uo unitsCheck+    runCommand (CmdUnitsInfer uo)         = runUO uo unitsInfer+    runCommand (CmdUnitsSynth uso)        = runUSO uso unitsSynth+    runCommand (CmdUnitsCompile uo)       = runUO uo unitsCompile+    runCommand (CmdInvariantsCheck io)    = runIO io invariantsCheck+    runCommand (CmdRefactCommon rfo)      = runRFO rfo common+    runCommand (CmdRefactDead rfo)        = runRFO rfo dead+    runCommand (CmdRefactEquivalence rfo) = runRFO rfo equivalences+    runCommand (CmdImplicitNone ro lo)    = runRO ro lo (implicitNone False)+    runCommand (CmdImplicitNoneAll ro lo) = runRO ro lo (implicitNone True)+    runCommand (CmdInit dir)              = camfortInitialize dir >> return 0+    runCommand CmdTopVersion              = displayVersion >> return 0++ -- | Commands supported by CamFort.-data Command = CmdCount ReadOptions-             | CmdAST ReadOptions-             | CmdStencilsCheck ReadOptions-             | CmdStencilsInfer StencilsOptions+data Command = CmdCount ReadOptions LogOptions+             | CmdAST ReadOptions LogOptions+             | CmdStencilsCheck ReadOptions LogOptions+             | CmdStencilsInfer StencilsInferOptions              | CmdStencilsSynth StencilsSynthOptions              | CmdUnitsSuggest UnitsOptions              | CmdUnitsCheck UnitsOptions              | CmdUnitsInfer UnitsOptions+             | CmdUnitsCompile UnitsOptions              | CmdUnitsSynth UnitsSynthOptions-             | CmdUnitsCompile UnitsWriteOptions+             | CmdInvariantsCheck InvariantsOptions              | CmdRefactCommon RefactOptions              | CmdRefactDead RefactOptions              | CmdRefactEquivalence RefactOptions+             | CmdImplicitNone ReadOptions LogOptions+             | CmdImplicitNoneAll ReadOptions LogOptions+             | CmdInit FilePath              | CmdTopVersion   -- | Options for reading files. data ReadOptions = ReadOptions   { inputSource :: String+  , includeDir  :: Maybe String   , exclude     :: Maybe [String]   }  +data LogOptions = LogOptions+  { logLevel :: LogLevel+  }++ -- | Options for writing to files. -- -- User can choose to either specify which file to write, or have@@ -60,19 +153,11 @@                   | WriteInplace  --- | Options used by stencil commands.-data StencilsOptions = StencilsOptions-  { soReadOptions  :: ReadOptions-  , soInferMode    :: InferMode-  }-- -- | Options used by all unit commands. data UnitsOptions = UnitsOptions   { uoReadOptions :: ReadOptions+  , uoLogOptions  :: LogOptions   , literals      :: LiteralsOpt-  , debug         :: Bool-  , includeDir    :: Maybe String   }  @@ -92,16 +177,32 @@   }  +data StencilsInferOptions = StencilsInferOptions+  { sioReadOptions :: ReadOptions+  , sioLogOptions  :: LogOptions+  , sioUseEval     :: Bool+  }++ data StencilsSynthOptions = StencilsSynthOptions-  { ssoStencilsOptions    :: StencilsOptions+  { ssoReadOptions        :: ReadOptions+  , ssoLogOptions         :: LogOptions   , ssoWriteOptions       :: WriteOptions   , ssoAnnotationOptions  :: AnnotationOptions   }  +data InvariantsOptions = InvariantsOptions+  { ioReadOptions :: ReadOptions+  , ioLogOptions :: LogOptions+  , ioPrimReprOption :: PrimReprOption+  }++ -- | Options used by refactoring commands. data RefactOptions = RefactOptions   { rfoReadOptions  :: ReadOptions+  , rfoLogOptions   :: LogOptions   , rfoWriteOptions :: WriteOptions   } @@ -110,6 +211,9 @@ fileArgument :: Mod ArgumentFields String -> Parser String fileArgument m = strArgument (metavar "FILENAME" <> action "file" <> m) +-- | Parser for an argument representing an individual directory.+directoryArgument :: Mod ArgumentFields String -> Parser String+directoryArgument m = strArgument (metavar "DIRECTORY" <> action "directory" <> m)  -- | Parser for file options with multiple files specified -- | as a comma-separated list.@@ -135,9 +239,24 @@ readOptions :: Parser ReadOptions readOptions = fmap ReadOptions   (fileArgument $ help "input file")+  <*> optional includeDirOption   <*> excludeOption+  where+    dirOption m = strOption (metavar "DIR" <> action "directory" <> m)+    includeDirOption = dirOption+      (   long "include-dir"+       <> short 'I'+       <> help "directory to search for precompiled files")  +logOptions :: Parser LogOptions+logOptions = LogOptions <$> logLevelOption+  where+    logLevelOption =+      let toLogLevel debug = if debug then LogDebug else LogInfo+      in toLogLevel <$> switch (long "debug" <> help "enable debug output")++ -- | User must specify either an ouput file, or say that the file -- | should be rewritten in place. writeOptions :: Parser WriteOptions@@ -148,11 +267,11 @@                       <> help "write in place (replaces input files)"))  -stencilsOptions :: Parser StencilsOptions-stencilsOptions = fmap StencilsOptions-  readOptions <*> evalOption+stencilsInferOptions :: Parser StencilsInferOptions+stencilsInferOptions = fmap StencilsInferOptions+  readOptions <*> logOptions <*> evalOption   where-    evalOption = flag AssignMode EvalMode+    evalOption = switch       (    long "eval"         <> help "provide additional evaluation reporting"         <> internal)@@ -160,15 +279,14 @@  stencilsSynthOptions :: Parser StencilsSynthOptions stencilsSynthOptions = fmap StencilsSynthOptions-  stencilsOptions <*> writeOptions <*> annotationOptions+  readOptions <*> logOptions <*> writeOptions <*> annotationOptions   unitsOptions :: Parser UnitsOptions unitsOptions = fmap UnitsOptions       readOptions+  <*> logOptions   <*> literalsOption-  <*> debugOption-  <*> optional includeDirOption   where     literalsOption = option parseLiterals $                      long "units-literals"@@ -178,14 +296,23 @@                      <> value LitMixed                      <> help "units-of-measure literals mode. ID = Unitless, Poly, or Mixed"     parseLiterals = fmap read str-    debugOption = switch (long "debug" <> help "enable debug mode")-    dirOption m = strOption (metavar "DIR" <> action "directory" <> m)-    includeDirOption = dirOption-      (   long "include-dir"-       <> short 'I'-       <> help "directory to search for precompiled files")  +invariantsOptions :: Parser InvariantsOptions+invariantsOptions = fmap InvariantsOptions+      readOptions+  <*> logOptions+  <*> reprOption+  where+    reprOption =+      flag PROIdealized PROPrecise+      $  long "precise-reprs"+      <> short 'p'+      <> help "use precise data representations, in invariant verification, at\+              \the cost of speed and provability; see documentation in\+              \Language.Model.Fortran.Repr.Prim"++ unitsWriteOptions :: Parser UnitsWriteOptions unitsWriteOptions = fmap UnitsWriteOptions   unitsOptions <*> writeOptions@@ -206,29 +333,34 @@  refactOptions :: Parser RefactOptions refactOptions = fmap RefactOptions-  readOptions <*> writeOptions+  readOptions <*> logOptions <*> writeOptions   cmdCount, cmdAST :: Parser Command-cmdCount = fmap CmdCount readOptions-cmdAST   = fmap CmdAST   readOptions+cmdCount        = fmap CmdCount readOptions <*> logOptions+cmdAST          = fmap CmdAST   readOptions <*> logOptions   cmdStencilsCheck, cmdStencilsInfer, cmdStencilsSynth :: Parser Command-cmdStencilsCheck = fmap CmdStencilsCheck readOptions-cmdStencilsInfer = fmap CmdStencilsInfer stencilsOptions+cmdStencilsCheck = fmap CmdStencilsCheck readOptions <*> logOptions+cmdStencilsInfer = fmap CmdStencilsInfer stencilsInferOptions cmdStencilsSynth = fmap CmdStencilsSynth stencilsSynthOptions  -cmdUnitsSuggest, cmdUnitsCheck, cmdUnitsInfer-  , cmdUnitsSynth, cmdUnitsCompile :: Parser Command+cmdUnitsSuggest, cmdUnitsCheck, cmdUnitsInfer, cmdUnitsCompile, cmdUnitsSynth :: Parser Command cmdUnitsSuggest = fmap CmdUnitsSuggest unitsOptions cmdUnitsCheck   = fmap CmdUnitsCheck   unitsOptions cmdUnitsInfer   = fmap CmdUnitsInfer   unitsOptions+cmdUnitsCompile = fmap CmdUnitsCompile unitsOptions cmdUnitsSynth   = fmap CmdUnitsSynth   unitsSynthOptions-cmdUnitsCompile = fmap CmdUnitsCompile unitsWriteOptions  +cmdImplicitNone, cmdImplicitNoneAll, cmdInvariantsCheck :: Parser Command+cmdInvariantsCheck = fmap CmdInvariantsCheck invariantsOptions+cmdImplicitNone    = fmap CmdImplicitNone readOptions <*> logOptions+cmdImplicitNoneAll = fmap CmdImplicitNoneAll readOptions <*> logOptions++ cmdRefactCommon, cmdRefactDead, cmdRefactEquivalence :: Parser Command cmdRefactCommon      = fmap CmdRefactCommon refactOptions cmdRefactDead        = fmap CmdRefactDead refactOptions@@ -263,6 +395,12 @@       [ ("count",           [],           cmdCount,         "count variable declarations")+      , ("implicit-none",+          [],+          cmdImplicitNone,  "check 'implicit none' completeness")+      , ("implicit-none-all",+          [],+          cmdImplicitNoneAll,  "check 'implicit none' completeness (all program units)")       , ("ast",           [],           cmdAST,           "print the raw AST -- for development purposes")@@ -284,12 +422,16 @@       , ("units-infer",           ["unit-infer", "infer-units", "infer-unit"],           cmdUnitsInfer,    "unit-of-measure inference")+      , ("units-compile",+          ["unit-compile", "compile-units", "compile-unit"],+          cmdUnitsCompile,    "unit-of-measure compilation")       , ("units-synth",           ["unit-synth", "synth-units", "synth-unit"],           cmdUnitsSynth,    "unit-of-measure synthesise specs")-      , ("units-compile",-          ["unit-compile", "compile-units", "compile-unit"],-          cmdUnitsCompile,  "units-of-measure compile module information") ]+      , ("invariants-check",+          ["invariants-check","check-invariants", "check-hoare", "hoare-check"],+          cmdInvariantsCheck, "hoare logic invariant checking")+      ]   refactoringsParser :: Parser Command@@ -309,67 +451,27 @@                         <> short '?'                         <> help "show version number") ---- | Collective parser for all CamFort commands.-commandParser :: Parser Command-commandParser =-  helper <*> (analysesParser <|> refactoringsParser <|> topLevelCommands)-+cmdInit :: FilePath -> Parser Command+cmdInit currDir = fmap CmdInit . directoryArgument $+  help "project directory" <> value currDir -main :: IO ()-main = do-  cmd <- execParser (info commandParser idm)-  runCommand cmd+projectParser :: FilePath -> Parser Command+projectParser currDir = commandsParser "Project Commands" projectCommands   where-    getExcludes = fromMaybe [] . exclude-    getOutputFile _ (WriteFile f) = f-    getOutputFile inp WriteInplace = inp-    runRO ro f = f (inputSource ro) (getExcludes ro)-    runSO so f =-      runRO (soReadOptions so) f (soInferMode so)-    runSSO sso f =-      let ao     = ssoAnnotationOptions sso-          wo     = ssoWriteOptions sso-          so     = ssoStencilsOptions sso-          ro     = soReadOptions so-          inFile = inputSource ro-      in runSO so f (annotationType ao) (getOutputFile inFile wo)-    runUO uo f =-      let ro = uoReadOptions uo-      in runRO ro f (literals uo) (debug uo) (includeDir uo)-    runUWO uwo f =-      let uo     = uwoUnitsOptions uwo-          ro     = uoReadOptions uo-          wo     = uwoWriteOptions uwo-          inFile = inputSource ro-      in runUO uo f (getOutputFile inFile wo)-    runUSO uso f =-      let uwo = usoUnitsWriteOptions uso-          ao  = usoAnnotationOptions uso-      in runUWO uwo f (annotationType ao)-    runRFO rfo f =-      let ro     = rfoReadOptions rfo-          wo     = rfoWriteOptions rfo-          inFile = inputSource ro-      in runRO ro f (getOutputFile inFile wo)-    runCommand (CmdAST ro)                = runRO ro ast-    runCommand (CmdCount ro)              = runRO ro countVarDecls-    runCommand (CmdStencilsCheck ro)      = runRO ro stencilsCheck-    runCommand (CmdStencilsInfer so)      = runSO so stencilsInfer-    runCommand (CmdStencilsSynth sso)     = runSSO sso stencilsSynth-    runCommand (CmdUnitsSuggest uo)       = runUO uo unitsCriticals-    runCommand (CmdUnitsCheck uo)         = runUO uo unitsCheck-    runCommand (CmdUnitsInfer uo)         = runUO uo unitsInfer-    runCommand (CmdUnitsSynth uso)        = runUSO uso unitsSynth-    runCommand (CmdUnitsCompile uwo)      = runUWO uwo unitsCompile-    runCommand (CmdRefactCommon rfo)      = runRFO rfo common-    runCommand (CmdRefactDead rfo)        = runRFO rfo dead-    runCommand (CmdRefactEquivalence rfo) = runRFO rfo equivalences-    runCommand CmdTopVersion              = displayVersion+    projectCommands =+      [ ("init", [], cmdInit currDir, "initialize CamFort for the project") ] +-- | Collective parser for all CamFort commands.+commandParser :: FilePath -> Parser Command+commandParser currDir =+  helper <*> (    projectParser currDir+              <|> analysesParser+              <|> refactoringsParser+              <|> topLevelCommands) + -- | Current CamFort version.-version = "0.904"+version = "0.905"   -- | Full CamFort version string.
+ tests/Camfort/Analysis/ImplicitNoneSpec.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Camfort.Analysis.ImplicitNoneSpec (spec) where++import Data.Binary (encodeFile)+import Data.List (sort)+import System.Directory (createDirectory)+import System.FilePath ((</>), (<.>))+import System.IO.Temp (withSystemTempDirectory)+import Control.Lens++import Language.Fortran.Util.ModFile+import Language.Fortran.AST (ProgramUnitName(..))++import Camfort.Analysis.ModFile (getModFiles)+import Camfort.Analysis.Simple+import Camfort.Analysis.TestUtils+import Camfort.Analysis hiding (describe)++import Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++spec :: Test.Spec+spec = do+  let f n = testInputSources $ fixturesDir </> n+  let g a = (generalizePureAnalysis . checkImplicitNone a)+  describe "implicitNone" $ do+    it "basic" $ do+      testSingleFileAnalysis (f "implicitnone1.f90") (g False) $ \ report ->+        let ImplicitNoneReport ls = (report ^?! arResult . _ARSuccess) in+        map fst ls `shouldBe` [Named "s"]+    it "misplaced statements" $ do+      testSingleFileAnalysis (f "implicitnone2.f90") (g False) $ \ report ->+        let ImplicitNoneReport ls = (report ^?! arResult . _ARSuccess) in+        map fst ls `shouldBe` [Named "implicitnone1", Named "implicitnone2"]+    it "interfaces are separate scope" $ do+      testSingleFileAnalysis (f "implicitnone3.f90") (g False) $ \ report ->+        let ImplicitNoneReport ls = (report ^?! arResult . _ARSuccess) in+        map fst ls `shouldBe` [Named "s"]+  describe "implicitNoneAll" $ do+    it "basic" $ do+      testSingleFileAnalysis (f "implicitnone1.f90") (g True) $ \ report ->+        let ImplicitNoneReport ls = (report ^?! arResult . _ARSuccess) in+        map fst ls `shouldBe` [Named "f", Named "s"]+    it "misplaced statements" $ do+      testSingleFileAnalysis (f "implicitnone2.f90") (g True) $ \ report ->+        let ImplicitNoneReport ls = (report ^?! arResult . _ARSuccess) in+        map fst ls `shouldBe` [Named "implicitnone1", Named "f", Named "implicitnone2", Named "f"]+    it "interfaces are separate scope" $ do+      testSingleFileAnalysis (f "implicitnone3.f90") (g True) $ \ report ->+        let ImplicitNoneReport ls = (report ^?! arResult . _ARSuccess) in+        map fst ls `shouldBe` [Named "s"]++fixturesDir :: FilePath+fixturesDir = "tests" </> "fixtures"
+ tests/Camfort/Analysis/ModFileSpec.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++module Camfort.Analysis.ModFileSpec (spec) where++import Data.Binary (encodeFile)+import Data.List (sort)+import System.Directory (createDirectory)+import System.FilePath ((</>), (<.>))+import System.IO.Temp (withSystemTempDirectory)++import Language.Fortran.Util.ModFile++import Camfort.Analysis.ModFile (getModFiles)++import Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++spec :: Test.Spec+spec =+  describe "getModFiles" $+    it "correctly retrieves ModFiles" $+      withSystemTempDirectory "camfort-modfilespec"+        (\dir -> do+          let mkMod name = alterModFileData (const $ Just name) "mfs-name" emptyModFile+              mod1       = mkMod "file-a"+              mod2       = mkMod "file-b"+          encodeFile (dir </> "moda" <.> modFileSuffix) mod1+          encodeFile (dir </> "modb" <.> modFileSuffix) mod2+          fmap (sort . fmap (lookupModFileData "mfs-name")) . getModFiles $ dir)+        `shouldReturn` [Just "file-a", Just "file-b"]
+ tests/Camfort/Analysis/TestUtils.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE TemplateHaskell #-}++module Camfort.Analysis.TestUtils+  (+    -- * Inputs+    TestInput+  , testInputSources+  , tiInputSources+  , tiExcludeFiles+  , tiIncludeDir+    -- * Running Tests+  , testSingleFileAnalysis+  , testMultiFileAnalysis+  , testMultiFileAnalysisWithSrc+  ) where++import           Control.Monad                 (forM_)+import           Control.Monad.IO.Class+import           System.Directory              (getCurrentDirectory)+import           System.FilePath++import           Control.Lens++import qualified Language.Fortran.AST          as F+import           Language.Fortran.Util.ModFile (ModFiles, emptyModFiles)++import           Camfort.Analysis+import           Camfort.Analysis.ModFile+import           Camfort.Helpers+import           Camfort.Input+++data TestInput =+  TestInput+  { _tiInputSources :: FileOrDir+  , _tiExcludeFiles :: [Filename]+  , _tiIncludeDir   :: Maybe FilePath+  }++makeLenses ''TestInput++testInputSources :: FileOrDir -> TestInput+testInputSources inputSources =+  TestInput+  { _tiInputSources = inputSources+  , _tiExcludeFiles = []+  , _tiIncludeDir = Just $ takeDirectory inputSources+  }+++loadInput :: TestInput -> IO (ModFiles, [(ProgramFile, SourceText)])+loadInput input = do+  incDir <- case input ^. tiIncludeDir of+    Just x  -> return x+    Nothing -> getCurrentDirectory++  modFiles <- genModFiles emptyModFiles simpleCompiler () incDir (input ^. tiExcludeFiles)+  pfsTexts <- readParseSrcDir modFiles (input ^. tiInputSources) (input ^. tiExcludeFiles)+  return (modFiles, pfsTexts)+++testSingleFileAnalysis+  :: (Describe e, Describe w, MonadIO m)+  => TestInput+  -> AnalysisProgram e w IO ProgramFile b+  -> (AnalysisReport e w b -> m ())+  -> m ()+testSingleFileAnalysis input program testReport = do+  (mfs, pfsSources) <- liftIO $ loadInput input++  forM_ pfsSources $ \ (pf, _) -> do+    report <- liftIO $+      runAnalysisT+      (F.pfGetFilename pf)+      (logOutputNone True)+      LogError+      mfs+      (program pf)+    testReport report+++testMultiFileAnalysis+  :: (Describe e, Describe w, MonadIO m)+  => TestInput+  -> AnalysisProgram e w IO [ProgramFile] b+  -> (AnalysisReport e w b -> m ())+  -> m ()+testMultiFileAnalysis input program = testMultiFileAnalysisWithSrc input program . const+++testMultiFileAnalysisWithSrc+  :: (Describe e, Describe w, MonadIO m)+  => TestInput+  -> AnalysisProgram e w IO [ProgramFile] b+  -> ([SourceText] -> AnalysisReport e w b -> m ())+  -> m ()+testMultiFileAnalysisWithSrc input program testReport = do+  (mfs, (pfs, sources)) <- fmap (over _2 unzip) $ liftIO $ loadInput input++  let fname = maybe "" F.pfGetFilename (pfs ^? _head)++  report <- liftIO $+    runAnalysisT+    fname+    (logOutputNone True)+    LogError+    mfs+    (program pfs)+  testReport sources report
+ tests/Camfort/FunctionalitySpec.hs view
@@ -0,0 +1,132 @@+-- TODO: Fix this+module Camfort.FunctionalitySpec (spec) where++import System.Directory (copyFile, doesDirectoryExist)+import System.FilePath  ((</>))+import System.IO.Silently (capture_)+import System.IO.Temp   (withSystemTempDirectory)++import           Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++import Camfort.Functionality+  ( AnnotationType(ATDefault)+  , camfortInitialize+  , stencilsInfer+  , unitsCheck, unitsInfer, unitsSynth )+import Camfort.Specification.Units.Monad (LiteralsOpt(LitMixed))++spec :: Test.Spec+spec = do+  describe "camfortInitialize" $ return ()+    -- xit "creates a .camfort directory" $+    --   return ()+      -- withSystemTempDirectory "camfort-test-tmp"+      --   (\d -> camfortInitialize d >> doesDirectoryExist (d </> ".camfort"))+      -- `shouldReturn` True+  xdescribe "units-check" $ return ()+  --   it "correctly detects basic cross-module inconsistent"+  --     return ()+  --     -- unitsCheckTestCrossModuleInconsistBasic+  xdescribe "units-infer" $ return ()+  --   it "shows consistency error with inconsistent program"+  --     return ()+  --     -- unitsInferTestCrossModuleInconsistBasic+  xdescribe "units-synth" $ return ()+  --   it "correct synth output with basic, consistent file"+  --     return ()+  --     -- unitsSynthTestBasic+  xdescribe "stencils-infer" $ return ()+  --   it "correctly infers with basic cross-module"+  --     return ()+      -- stencilsInferTestCrossModuleBasic++analysisWithTmpFilesTest+  :: FilePath -> [FilePath] -> FilePath+  -> (FilePath -> Maybe FilePath -> [t] -> IO a)+  -> (FilePath -> String)+  -> Expectation+analysisWithTmpFilesTest dir files file analysis expected =+  withSystemTempDirectory "camfort-test-tmp"+  (\d -> do+      mapM_ (\fname -> copyFile (dir </> fname) (d </> fname)) files+      let actFile = d </> file+      res <- capture_ $ analysis actFile (Just d) []+      res `shouldBe` expected actFile)++fixturesDir :: FilePath+fixturesDir = "tests" </> "fixtures" </> "Specification"++unitsFixturesDir :: FilePath+unitsFixturesDir = fixturesDir </> "Units"++unitsWithTmpFilesTest+  :: FilePath -> [FilePath] -> FilePath+  -> (FilePath -> Maybe FilePath -> [t] -> LiteralsOpt -> Bool -> IO a)+  -> (FilePath -> String)+  -> Expectation+unitsWithTmpFilesTest dir files file analysis =+  analysisWithTmpFilesTest dir files file analysis'+  where analysis' inSrc incDir excludes = analysis inSrc incDir excludes LitMixed False++basicUnitsCrossModuleTestHelper+  :: (FilePath -> Maybe FilePath -> [t] -> LiteralsOpt -> Bool -> IO a)+  -> (FilePath -> String)+  -> Expectation+basicUnitsCrossModuleTestHelper =+  unitsWithTmpFilesTest unitsFixturesModuleDir+    ["crossmoduleuser.f90", "crossmoduleprovider.f90"] "crossmoduleuser.f90"+  where unitsFixturesModuleDir = unitsFixturesDir </> "cross-module-a"++-- unitsCheckTestCrossModuleInconsistBasic :: Expectation+-- unitsCheckTestCrossModuleInconsistBasic =+--   basicUnitsCrossModuleTestHelper unitsCheck unitsCheckTestCrossModuleInconsistBasicReport++-- unitsInferTestCrossModuleInconsistBasic :: Expectation+-- unitsInferTestCrossModuleInconsistBasic =+--   basicUnitsCrossModuleTestHelper unitsInfer unitsInferTestCrossModuleInconsistBasicReport++-- unitsSynthTestBasic :: Expectation+-- unitsSynthTestBasic =+--   unitsWithTmpFilesTest unitsFixturesDir+--     ["example-simple-1.f90"] "example-simple-1.f90" unitsSynth' unitsSynthBasicReport+--   where unitsSynth' inSrc incDir excludes m debug =+--           unitsSynth inSrc incDir excludes m debug inSrc ATDefault++unitsCheckTestCrossModuleInconsistBasicReport :: FilePath -> String+unitsCheckTestCrossModuleInconsistBasicReport fp =+  "Checking units for '" ++ fp ++ "'\n\n" +++  fp ++ ": Inconsistent:\n\+  \ - at 7:3: 'literal' should have unit 'm'\n\+  \ - at 7:3: 'parameter 1 to add' should have unit 'm'\n\+  \ - at 8:3: 'literal' should have unit 's'\n\+  \ - at 9:3: 'z' should have the same units as 'result of add'\n\n"++unitsInferTestCrossModuleInconsistBasicReport :: FilePath -> String+unitsInferTestCrossModuleInconsistBasicReport fp =+  "Inferring units for '" ++ fp ++ "'\n\n" +++  fp ++ ": Inconsistent:\n\+  \ - at 7:3: 'literal' should have unit 'm'\n\+  \ - at 7:3: 'parameter 1 to add' should have unit 'm'\n\+  \ - at 8:3: 'literal' should have unit 's'\n\+  \ - at 9:3: 'z' should have the same units as 'result of add'\n\n"++unitsSynthBasicReport :: FilePath -> String+unitsSynthBasicReport fp =+  "Synthesising units for '" ++ fp ++ "'\n" +++  "Writing " ++ fp ++ "\n\n" +++  fp ++ ":\n" +++  "  3:14 unit s :: x\n\+  \  3:17 unit s :: y\n\n"++-- stencilsInferTestCrossModuleBasic :: Expectation+-- stencilsInferTestCrossModuleBasic =+--   analysisWithTmpFilesTest stencilsFixturesModuleDir+--     ["user.f90", "provider.f90"] "user.f90" stencilsInfer' stencilsInferCrossModuleBasicReport+--   where stencilsFixturesModuleDir = fixturesDir </> "Stencils" </> "cross-module-a"+--         stencilsInfer' inSrc incDir excludes = stencilsInfer inSrc incDir excludes False++-- stencilsInferCrossModuleBasicReport :: FilePath -> String+-- stencilsInferCrossModuleBasicReport fp =+--   "Inferring stencil specs for '" ++ fp ++ "'\n\n" +++--   fp ++ "\n(7:6)-(7:16)    stencil readOnce, pointed(dim=1) :: b\n"
tests/Camfort/ReprintSpec.hs view
@@ -69,13 +69,18 @@       (fst $ takeBounds (FU.Position 1 1 1, FU.Position 1 5 3) btext2)         `shouldBe` (B.pack $ unlines $ take 3 text2) -    context "Integration test with synthesising a spec" $ do-       runIO $ unitsSynth ("tests" </> "fixtures" </> "simple.f90") []-         LitMixed False Nothing-         ("tests" </> "fixtures" </> "simple.f90.out") ATDefault-       actual <- runIO $ readFile ("tests" </> "fixtures" </> "simple.f90.out")-       expected <- runIO $ readFile ("tests" </> "fixtures" </> "simple.expected.f90")-       it "Unit synth" $ actual `shouldBe` expected+    -- TODO: Fix this+    -- context "Integration test with synthesising a spec" $ do+    --    let simpleDir = "tests" </> "fixtures"+    --        simpleIn  = simpleDir </> "simple.f90"+    --        simpleExpected = simpleDir </> "simple.expected.f90"+    --        simpleOut = simpleDir </> "simple.f90.out"+    --    runIO $ unitsSynth simpleIn (Just simpleIn) []+    --      LitMixed False+    --      simpleOut ATDefault+    --    actual <- runIO $ readFile simpleOut+    --    expected <- runIO $ readFile simpleExpected+    --    it "Unit synth" $ actual `shouldBe` expected  ----
+ tests/Camfort/Specification/Hoare/ParserSpec.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleContexts #-}++module Camfort.Specification.Hoare.ParserSpec (spec) where++import           Data.Data                                (Data)+import           Data.Either                              (isLeft)+import           Data.Foldable                            (traverse_)++import           Data.Generics.Uniplate.Operations        (Biplate, transformBi)++import           Camfort.Specification.Hoare.Lexer+import           Camfort.Specification.Hoare.Parser+import           Camfort.Specification.Hoare.Parser.Types+import           Camfort.Specification.Hoare.Syntax+import           Camfort.Specification.Parser             (runParser)+import qualified Camfort.Specification.Parser             as Parser+import qualified Language.Fortran.AST                     as F+import qualified Language.Fortran.Util.Position           as F++import           Test.Hspec                               hiding (Spec)+import qualified Test.Hspec                               as Test++spec :: Test.Spec+spec = describe "Hoare - Parser" $ do+  let (.->) = (,)++  it "lexes" $ do+    let runTest (input, output) =+          lexer input `shouldBe` Right output++        tests =+          [ "\"x\"" .-> [TQuoted "x"]+          , "\"x + y - 347\"" .-> [TQuoted "x + y - 347"]+          , "static_assert invariant(\"x == 4)7\" )" .->+            [ TStaticAssert, TInvariant+            , TLParen, TQuoted "x == 4)7", TRParen]+          , "static_assert pre(t)" .->+            [ TStaticAssert, TPre, TLParen, TTrue, TRParen]+          , "decl_aux(\"integer\" :: x)" .->+            [ TDeclAux, TLParen, TQuoted "integer", TDColon, TName "x", TRParen]+          ]++    traverse_ runTest tests++    lexer "static_assert post(\"missing close quote)" `shouldSatisfy` isLeft++  it "parses" $ do+    let runTest (input, output) =+          parse input `shouldSatisfy` (matches (Right output))++        fvar n = F.ExpValue () defSpan (F.ValVariable n)+        x = fvar "x"+        y = fvar "y"+        z = fvar "z"++        num n = F.ExpValue () defSpan (F.ValInteger (show n))++        bin o e1 e2 = F.ExpBinary () defSpan o e1 e2+        add = bin F.Addition+        sub = bin F.Subtraction++        xA3 = x `add` num 3+        ySz = y `sub` z+        yAz = y `add` z++        (.==) = bin F.EQ+        (.<) = bin F.LT+        (.>) = bin F.GT+        (.>=) = bin F.GTE++        x *&& y = PFLogical (PLAnd x y)+        x *|| y = PFLogical (PLOr x y)+        x *-> y = PFLogical (PLImpl x y)++        tests =+          [ "! static_assert pre(\"x == y\")"+            .->+            SodSpec (Specification SpecPre (PFExpr $ x .== y))++          , "! static_assert pre(t)"+            .->+            SodSpec (Specification SpecPre (PFLogical (PLLit True)))++          , "! static_assert invariant(\"x + 3 < y - z\" & \"x + 3 > y + z\")"+            .->+            SodSpec (Specification SpecInvariant+                     ((PFExpr $ xA3 .< ySz) *&& (PFExpr $ xA3 .> yAz)))++          , "! static_assert post(\"x + 3 < y - z\" & \"x + 3 > y + z\" | \"x >= 7\")"+            .->+            SodSpec (Specification SpecPost+                     (((PFExpr $ xA3 .< ySz) *&& (PFExpr $ xA3 .> yAz)) *||+                      (PFExpr $ x .>= (num 7))+                     ))++          , "! static_assert seq(\"x + 3 < y - z\" -> \"x + 3 > y + z\" -> \"x >= 7\")"+            .->+            SodSpec (Specification SpecSeq+                     ((PFExpr $ xA3 .< ySz) *->+                      (((PFExpr $ xA3 .> yAz)) *-> (PFExpr $ x .>= (num 7)))+                     ))++          ]++    traverse_ runTest tests+++stripSpans :: Data from => from -> from+stripSpans = transformBi (const defSpan)++-- | Check if the two inputs are equal after removing all source spans, which+-- this test suite doesn't care about.+matches :: (Eq a, Data a) => a -> a -> Bool+matches a b =+  stripSpans a == stripSpans b++defSpan = F.SrcSpan (F.Position 0 0 0) (F.Position 0 0 0)++parse :: String -> Either (Parser.SpecParseError HoareParseError) (SpecOrDecl ())+parse = runParser hoareParser
tests/Camfort/Specification/Stencils/CheckSpec.hs view
@@ -4,19 +4,24 @@  import qualified Data.ByteString.Internal as BS -import Camfort.Analysis.Annotations (unitAnnotation)-import Camfort.Specification.Parser (runParser)-import Camfort.Specification.Stencils.CheckBackend-import Camfort.Specification.Stencils.CheckFrontend+import Control.Lens++import           Camfort.Analysis hiding (describe)+import           Camfort.Analysis.Annotations (unitAnnotation)+import           Camfort.Specification.Parser (runParser)+import qualified Camfort.Specification.Stencils.Annotation as SA+import           Camfort.Specification.Stencils.CheckBackend+import           Camfort.Specification.Stencils.CheckFrontend   (CheckResult, stencilChecking)-import Camfort.Specification.Stencils.Parser (specParser)-import Camfort.Specification.Stencils.Model-import Camfort.Specification.Stencils.Syntax+import           Camfort.Specification.Stencils.Parser (specParser)+import           Camfort.Specification.Stencils.Model+import           Camfort.Specification.Stencils.Syntax  import qualified Language.Fortran.Analysis          as FA import qualified Language.Fortran.Analysis.BBlocks  as FAB import qualified Language.Fortran.Analysis.Renaming as FAR import           Language.Fortran.Parser.Any (fortranParser)+import           Language.Fortran.Util.ModFile (emptyModFiles) import qualified Language.Fortran.Util.Position     as FU  import Test.Hspec@@ -121,17 +126,27 @@           \        but at (5:5)-(5:15) the code behaves as\n\           \                stencil readOnce, pointed(dim=1) :: a\n" -checkText text =-  either (error "received test input with invalid syntax")-     (stencilChecking . getBlocks . fmap (const unitAnnotation)) $ fortranParser text "example"-  where getBlocks = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis+checkText :: BS.ByteString -> IO CheckResult+checkText text = do+  pf <- either (fail "received test input with invalid syntax") return $+        fortranParser text "example" -runCheck :: String -> CheckResult+  let pf' = getBlocks . fmap (const unitAnnotation) $ pf++  return (runChecking pf' ^?! arResult . _ARSuccess)++  where+    runChecking = runIdentity . runAnalysisT "example" (logOutputNone True) LogInfo emptyModFiles . stencilChecking+    getBlocks = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis . fmap SA.mkStencilAnnotation++runCheck :: String -> IO CheckResult runCheck = checkText . BS.packChars  checkTestShow :: String -> String -> String -> SpecWith () checkTestShow exampleText testDescription expected =-  it testDescription $ show (runCheck exampleText) `shouldBe` expected+  it testDescription $ do+    res <- runCheck exampleText+    show res `shouldBe` expected  exampleUnusedRegion :: String exampleUnusedRegion =
tests/Camfort/Specification/StencilsSpec.hs view
@@ -5,26 +5,43 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-} +-- TODO: Fix this+ module Camfort.Specification.StencilsSpec (spec) where  -import Control.Monad.Writer.Strict hiding (Sum, Product)-import Data.List+import           Control.Monad.Writer.Strict hiding (Sum, Product)+import qualified Data.Graph.Inductive.Graph as Gr+import           Data.List -import Camfort.Helpers.Vec+import Control.Lens++import qualified Data.Text as Text++import Language.Fortran.Util.ModFile (emptyModFiles, ModFile)++import Camfort.Analysis.TestUtils+import Camfort.Analysis hiding (describe)+import qualified Camfort.Analysis.Logger as L+import Camfort.Analysis.ModFile (genModFiles)+import Camfort.Helpers.Vec hiding (zipWith) import Camfort.Input import Camfort.Specification.Stencils+import Camfort.Specification.Stencils.Analysis+  (StencilsAnalysis, compileStencils) import Camfort.Specification.Stencils.Generate-  (Neighbour(..), indicesToSpec, convIxToNeighbour)+  (Neighbour(..), indicesToSpec, convIxToNeighbour, runStencilInferer) import Camfort.Specification.Stencils.Synthesis import Camfort.Specification.Stencils.Model-import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.InferenceFrontend+import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.Syntax import qualified Language.Fortran.AST as F import Language.Fortran.Parser.Any (deduceVersion) import Language.Fortran.ParserMonad+import Language.Fortran.Util.ModFile (emptyModFiles) import Camfort.Reprint import Camfort.Output @@ -158,49 +175,49 @@     describe "Inconsistent induction variable usage tests" $ do       it "consistent (1) a(i,j) = b(i+1,j+1) + b(i,j)" $         indicesToSpec' ["i", "j"]-                       [Neighbour "i" 0, Neighbour "j" 0]-                       [[offsetToIx "i" 1, offsetToIx "j" 1],-                        [offsetToIx "i" 0, offsetToIx "j" 0]]-         `shouldBe` (Just $ Specification (Once $ Exact+               [Neighbour "i" 0, Neighbour "j" 0]+               [[offsetToIx "i" 1, offsetToIx "j" 1],+                 [offsetToIx "i" 0, offsetToIx "j" 0]]+          `shouldBe` (Just $ Specification (Once $ Exact                        (Spatial                          (Sum [Product [Forward 1 1 False, Forward 1 2 False],                                Product [Centered 0 1 True, Centered 0 2 True]]))) True)       it "consistent (2) a(i,c,j) = b(i,j+1) + b(i,j) \                         \:: forward(depth=1,dim=2)*pointed(dim=1)" $         indicesToSpec' ["i", "j"]-                        [Neighbour "i" 0, Constant (F.ValInteger "0"), Neighbour "j" 0]-                        [[offsetToIx "i" 0, offsetToIx "j" 1],-                         [offsetToIx "i" 0, offsetToIx "j" 0]]-         `shouldBe` (Just $ Specification (Once $ Exact+               [Neighbour "i" 0, Constant (F.ValInteger "0"), Neighbour "j" 0]+               [[offsetToIx "i" 0, offsetToIx "j" 1],+                 [offsetToIx "i" 0, offsetToIx "j" 0]]+          `shouldBe` (Just $ Specification (Once $ Exact                        (Spatial                          (Sum [Product [Centered 0 1 True, Forward 1 2 True]]))) True)        it "consistent (3) a(i+1,c,j) = b(j,i+1) + b(j,i) \                         \:: backward(depth=1,dim=2)*pointed(dim=1)" $         indicesToSpec' ["i", "j"]-                        [Neighbour "i" 1, Constant (F.ValInteger "0"), Neighbour "j" 0]-                        [[offsetToIx "j" 0, offsetToIx "i" 1],-                         [offsetToIx "j" 0, offsetToIx "i" 0]]-         `shouldBe` (Just $ Specification (Once $ Exact+               [Neighbour "i" 1, Constant (F.ValInteger "0"), Neighbour "j" 0]+               [[offsetToIx "j" 0, offsetToIx "i" 1],+                 [offsetToIx "j" 0, offsetToIx "i" 0]]+          `shouldBe` (Just $ Specification (Once $ Exact                        (Spatial                          (Sum [Product [Centered 0 1 True, Backward 1 2 True]]))) True)        it "consistent (4) a(i+1,j) = b(0,i+1) + b(0,i) \                          \:: backward(depth=1,dim=2)" $         indicesToSpec' ["i", "j"]-                        [Neighbour "i" 1, Neighbour "j" 0]-                        [[offsetToIx "j" absoluteRep, offsetToIx "i" 1],-                         [offsetToIx "j" absoluteRep, offsetToIx "i" 0]]-         `shouldBe` (Just $ Specification (Once $ Exact+               [Neighbour "i" 1, Neighbour "j" 0]+               [[offsetToIx "j" absoluteRep, offsetToIx "i" 1],+                 [offsetToIx "j" absoluteRep, offsetToIx "i" 0]]+          `shouldBe` (Just $ Specification (Once $ Exact                        (Spatial                          (Sum [Product [Backward 1 2 True]]))) True)        it "consistent (5) a(i) = b(i,i+1) \                         \:: pointed(dim=1)*forward(depth=1,dim=2,nonpointed)" $         indicesToSpec' ["i", "j"]-                        [Neighbour "i" 0]-                        [[offsetToIx "i" 0, offsetToIx "i" 1]]-         `shouldBe` (Just $ Specification (Once $ Exact+               [Neighbour "i" 0]+               [[offsetToIx "i" 0, offsetToIx "i" 1]]+          `shouldBe` (Just $ Specification (Once $ Exact                        (Spatial                          (Sum [Product [Centered 0 1 True,                                         Forward 1 2 False]]))) True)@@ -208,123 +225,156 @@       it "consistent (6) a(i) = b(i) + b(0) \                         \:: pointed(dim=1)" $         indicesToSpec' ["i", "j"]-                        [Neighbour "i" 0]-                        [[offsetToIx "i" 0], [offsetToIx "i" absoluteRep]]-         `shouldBe` Nothing+               [Neighbour "i" 0]+               [[offsetToIx "i" 0], [offsetToIx "i" absoluteRep]]+          `shouldBe` Nothing        it "inconsistent (1) RHS" $         indicesToSpec' ["i", "j"]-                        [Neighbour "i" 0, Neighbour "j" 0]-                        [[offsetToIx "i" 1, offsetToIx "j" 1],-                         [offsetToIx "j" 0, offsetToIx "i" 0]]-         `shouldBe` Nothing+               [Neighbour "i" 0, Neighbour "j" 0]+               [[offsetToIx "i" 1, offsetToIx "j" 1],+                 [offsetToIx "j" 0, offsetToIx "i" 0]]+          `shouldBe` Nothing        it "inconsistent (2) RHS to LHS" $         indicesToSpec' ["i", "j"]-                        [Neighbour "i" 0]-                        [[offsetToIx "i" 1, offsetToIx "j" 1],-                         [offsetToIx "j" 0, offsetToIx "i" 0]]-         `shouldBe` Nothing+               [Neighbour "i" 0]+               [[offsetToIx "i" 1, offsetToIx "j" 1],+                 [offsetToIx "j" 0, offsetToIx "i" 0]]+          `shouldBe` Nothing      -------------------------     -- Some integration tests     ------------------------- -    let example2In = fixturesDir </> "example2.f"-    program <- runIO $ readParseSrcDir example2In []+    let example2In = testInputSources (fixturesDir </> "example2.f")      describe "integration test on inference for example2.f" $ do       it "stencil infer" $-         fst (callAndSummarise (infer AssignMode '=') program)-           `shouldBe`-           "\ntests/fixtures/Specification/Stencils/example2.f\n\-            \(32:7)-(32:26)    stencil readOnce, backward(depth=1, dim=1) :: a\n\-            \(26:8)-(26:29)    stencil readOnce, pointed(dim=1)*pointed(dim=2) :: a\n\-            \(24:8)-(24:53)    stencil readOnce, pointed(dim=1)*centered(depth=1, dim=2) \-                                     \+ centered(depth=1, dim=1)*pointed(dim=2) :: a"+        testSingleFileAnalysis example2In (generalizePureAnalysis . infer False '=') $ \report -> do+          show (report ^?! arResult . _ARSuccess)+            `shouldBe` unlines+            [ "(31:7)-(31:26)    stencil readOnce, backward(depth=1, dim=1) :: a"+            , "(25:14)-(25:29)    access readOnce, pointed(dim=1)*pointed(dim=2) :: a"+            , "(24:14)-(24:53)    stencil readOnce, pointed(dim=1)*centered(depth=1, dim=2) \+                                     \+ centered(depth=1, dim=1)*pointed(dim=2) :: a"] +       it "stencil check" $-         fst (callAndSummarise (\p -> (check p, p)) program)-           `shouldBe`-           "\ntests/fixtures/Specification/Stencils/example2.f\n\-            \(23:1)-(23:78)    Correct.\n(31:1)-(31:56)    Correct."+        testSingleFileAnalysis example2In (generalizePureAnalysis . check) $ \report -> do+          let res = report ^?! arResult . _ARSuccess+          show res+            `shouldBe`+            "(23:1)-(23:78)    Correct.\n(30:1)-(30:56)    Correct." -    let example4In = fixturesDir </> "example4.f"-    program <- runIO $ readParseSrcDir example4In []+    let example4In = testInputSources (fixturesDir </> "example4.f")      describe "integration test on inference for example4.f" $       it "stencil infer" $-         fst (callAndSummarise (infer AssignMode '=') program)-           `shouldBe`-            "\ntests/fixtures/Specification/Stencils/example4.f\n\-             \(6:8)-(6:33)    stencil readOnce, pointed(dim=1) :: x"+        testSingleFileAnalysis example4In (generalizePureAnalysis . infer False '=') $ \report -> do+          show (report ^?! arResult . _ARSuccess)+            `shouldBe` unlines+             [ "(6:10)-(6:33)    stencil readOnce, pointed(dim=1) :: x"+             ]      describe "integration test on inference for example5" $       describe "stencil synth" $ do-        assertStencilInferenceNoWarn "example5.f"+        assertStencilSynthNoWarn "example5.f"           "inserts correct comment types for old fortran"-        assertStencilInferenceNoWarn "example5.f90"+        assertStencilSynthNoWarn "example5.f90"           "inserts correct comment types for modern fortran"      describe "synth on files already containing stencils" $ do-      assertStencilInferenceNoWarn "example6.f"+      assertStencilSynthNoWarn "example6.f"         "complements existing stencils (when second missing)"-      assertStencilInferenceNoWarn "example7.f"+      assertStencilSynthNoWarn "example7.f"         "complements existing stencils (when none missing)"-      assertStencilInferenceNoWarn "example8.f"+      assertStencilSynthNoWarn "example8.f"         "complements existing stencils (when first missing)"-      assertStencilInferenceNoWarn "example9.f"+      assertStencilSynthNoWarn "example9.f"         "complements existing stencils (when none missing - only one stencil)"-      assertStencilInferenceNoWarn "example10.f"+      assertStencilSynthNoWarn "example10.f"         "complements existing stencils (when one missing - inside if)"-      assertStencilInferenceNoWarn "example13.f"+      assertStencilSynthNoWarn "example13.f"         "complements existing stencils (when using regions references)"-      assertStencilInferenceNoWarn "example11.f"+      assertStencilSynthNoWarn "example11.f"         "inserts correct access specification"       assertStencilSynthResponse "example12.f"         "reports errors when conflicting stencil exists"-        "\nEncountered the following errors when checking stencil specs for 'tests/fixtures/Specification/Stencils/example12.f'\n\n\-\(8:1)-(8:52)    Not well specified.\n\-\        Specification is:\n\-\                stencil readOnce, backward(depth=1, dim=1) :: a\n\-\\n\-\        but at (9:8)-(9:32) the code behaves as\n\-\                stencil readOnce, forward(depth=1, dim=1) :: a\n\n\-\Please resolve these errors, and then run synthesis again."+        [unlines'+         [ ""+         , "Encountered the following errors when checking stencil specs for 'tests/fixtures/Specification/Stencils/example12.f'"+         , ""+         , "(8:1)-(8:52)    Not well specified."+         , "        Specification is:"+         , "                stencil readOnce, backward(depth=1, dim=1) :: a"+         , ""+         , "        but at (9:13)-(9:32) the code behaves as"+         , "                stencil readOnce, forward(depth=1, dim=1) :: a"+         , ""+         , "Please resolve these errors, and then run synthesis again."+         ]]       assertStencilSynthResponseOut "example14.f"         "warns when duplicate stencils exist, but continues"-        "\nEncountered the following errors when checking stencil specs for 'tests/fixtures/Specification/Stencils/example14.f'\n\n\-\(10:1)-(10:49)    Warning: Duplicate specification."+        [unlines'+         [ ""+         , "Encountered the following errors when checking stencil specs for 'tests/fixtures/Specification/Stencils/example14.f'"+         , ""+         , "(10:1)-(10:49)    Warning: Duplicate specification."+         ]]        assertStencilSynthResponseOut "example15.f"         "warns when duplicate stencils exist (combined stencils), but continues"-        "\nEncountered the following errors when checking stencil specs for 'tests/fixtures/Specification/Stencils/example15.f'\n\n\-\(9:1)-(9:49)    Warning: Duplicate specification."+        [unlines'+         [ ""+         , "Encountered the following errors when checking stencil specs for 'tests/fixtures/Specification/Stencils/example15.f'"+         , ""+         , "(9:1)-(9:49)    Warning: Duplicate specification."+         ]]        assertStencilCheck "example16.f"-        "error trying to check an access spec against a stencil"-        "\ntests/fixtures/Specification/Stencils/example16.f\n\-\(8:1)-(8:50)    Not well specified.\n\-\        Specification is:\n\-\                access readOnce, forward(depth=1, dim=1) :: a\n\-\\n\-\        but at (9:8)-(9:32) the code behaves as\n\-\                stencil readOnce, forward(depth=1, dim=1) :: a\n"+        "error trying to check an access spec against a stencil" $ unlines $+        [ "(8:1)-(8:50)    Not well specified."+        , "        Specification is:"+        , "                access readOnce, forward(depth=1, dim=1) :: a"+        , ""+        , "        but at (9:13)-(9:32) the code behaves as"+        , "                stencil readOnce, forward(depth=1, dim=1) :: a"+        ]        assertStencilCheck "example17.f"-        "error trying to check an access spec against a stencil"-        "\ntests/fixtures/Specification/Stencils/example17.f\n\-\(8:1)-(8:51)    Not well specified.\n\-\        Specification is:\n\-\                stencil readOnce, forward(depth=1, dim=1) :: a\n\-\\n\-\        but at (9:8)-(9:29) the code behaves as\n\-\                access readOnce, forward(depth=1, dim=1) :: a\n"+        "error trying to check an access spec against a stencil" $ unlines $+        [ "(8:1)-(8:51)    Not well specified."+        , "        Specification is:"+        , "                stencil readOnce, forward(depth=1, dim=1) :: a"+        , ""+        , "        but at (9:13)-(9:29) the code behaves as"+        , "                access readOnce, forward(depth=1, dim=1) :: a"+        ] +    describe "inference" $ do+      it "provides more information with evalmode on" $+        assertStencilInference True "example-no-specs-simple.f90" $+          [Text.unlines+           [ "(6:6)-(6:16)    stencil readOnce, pointed(dim=1) :: a"+           , "(6:6)-(6:16)    EVALMODE: assign to relative array subscript (tag: tickAssign)"+           , ""+           , "(6:6)-(6:16)    EVALMODE: dimensionality=1 :: a"+           ]] +      it "provides less information with evalmode off" $+        assertStencilInference False "example-no-specs-simple.f90"+          [unlines' [ "(6:6)-(6:16)    stencil readOnce, pointed(dim=1) :: a"]+          ]+     describe "synth/inference works correctly with nested loops" $ do-      assertStencilInferenceNoWarn "nestedLoops.f90" "inserts correct specification"+      assertStencilSynthNoWarn "nestedLoops.f90" "inserts correct specification" +    describe "inference with modules" $+      it "infers correctly with cross-module type declarations" $+        inferReportWithMod ["cross-module-a/provider.f90"] "cross-module-a/user.f90"+          crossModuleAUserReport+     -- Run over all the samples and test fixtures      sampleDirConts <- runIO $ listDirectory samplesDir@@ -334,56 +384,92 @@         sampleFiles          = filter hasExpectedSrcFile sampleDirConts      describe "sample file tests" $-        mapM_ (\file -> assertStencilInferenceSample+        mapM_ (\file -> assertStencilSynthSample                 file ("produces correct output file for " ++ file))         sampleFiles    where -- Helpers go here for loading files and running analyses         assertStencilCheck fileName testComment expected = do-            let file = fixturesDir </> fileName-            programs <- runIO $ readParseSrcDir file []-            let [(program,_)] = programs-            it testComment $  check program `shouldBe` expected+          let input = testInputSources (fixturesDir </> fileName)+          it "testComment" $+            testSingleFileAnalysis input (generalizePureAnalysis . check) $ \report -> do+              let res = report ^?! arResult . _ARSuccess+              show res `shouldBe` expected -        assertStencilInferenceDir expected dir fileName testComment =-          let file         = dir </> fileName-              version      = deduceVersion file+        assertStencilInference :: Bool -> FilePath -> [L.Text] -> Expectation+        assertStencilInference useEval fileName expected = do+          let input = testInputSources (fixturesDir </> fileName)+          testSingleFileAnalysis input (generalizePureAnalysis . infer useEval '=') $ \report -> do+            let res = report ^?! arResult . _ARSuccess+            show res `shouldBe` unlines (map Text.unpack expected)++        assertStencilSynthDir expected dir fileName testComment =+          let input        = testInputSources (dir </> fileName)+              version      = deduceVersion (dir </> fileName)               expectedFile = expected dir fileName           in do-            program          <- runIO $ readParseSrcDir file []-            programSrc       <- runIO $ readFile file             synthExpectedSrc <- runIO $ readFile expectedFile             it testComment $-               (map (B.unpack . runIdentity . flip (reprint (refactoring version)) (B.pack programSrc))-                 (snd . synth AssignMode '=' . fmap fst $ program))-                `shouldBe` [synthExpectedSrc]+              testMultiFileAnalysisWithSrc input (generalizePureAnalysis . synth '=') $ \sources report -> do+                let res = report ^?! arResult . _ARSuccess -        assertStencilInferenceOnFile = assertStencilInferenceDir+                    refactorings =+                      zipWith (\pf -> B.unpack . runIdentity . reprint (refactoring version) pf) res sources++                refactorings `shouldBe` [synthExpectedSrc]++        assertStencilSynthOnFile = assertStencilSynthDir           (\d f -> d </> getExpectedSrcFileName f) fixturesDir -        assertStencilInferenceSample = assertStencilInferenceDir+        assertStencilSynthSample = assertStencilSynthDir           (\d f -> d </> "expected" </> f) samplesDir          assertStencilSynthResponse fileName testComment expectedResponse =-            let file = fixturesDir </> fileName-            in do-              program          <- runIO $ readParseSrcDir file []-              programSrc       <- runIO $ readFile file-              it testComment $ (fst . synth AssignMode '=' . fmap fst $ program)-                `shouldBe` expectedResponse+          let input = testInputSources (fixturesDir </> fileName)+              modFiles = emptyModFiles+          in do+            it testComment $+              testMultiFileAnalysis input (generalizePureAnalysis . synth '=') $ \report -> do+                let logs = report ^.. arMessages . traverse . L._MsgInfo . L.lmMsg+                logs `shouldBe` expectedResponse          assertStencilSynthResponseOut fileName testComment expectedResponse =           describe testComment $ do-            assertStencilInferenceOnFile fileName "correct synthesis"+            assertStencilSynthOnFile fileName "correct synthesis"             assertStencilSynthResponse fileName "correct output" expectedResponse -        assertStencilInferenceNoWarn fileName testComment = assertStencilSynthResponseOut fileName testComment ""+        assertStencilSynthNoWarn fileName testComment = assertStencilSynthResponseOut fileName testComment [""]         fixturesDir = "tests" </> "fixtures" </> "Specification" </> "Stencils"         samplesDir  = "samples" </> "stencils"         getExpectedSrcFileName file =           let oldExtension = takeExtension file           in addExtension (replaceExtension file "expected") oldExtension +fixturesDir :: FilePath+fixturesDir = "tests" </> "fixtures" </> "Specification" </> "Stencils"++-- | Assert that the report of performing units checking on a file is as expected.+inferReportWithMod :: [String] -> String -> [L.Text] -> Expectation+inferReportWithMod modNames fileName expectedReport = do+  let file = fixturesDir </> fileName+      modPaths = fmap (fixturesDir </>) modNames++  modFiles <- mapM mkTestModFile modPaths+  [(pf, _)] <- readParseSrcDir modFiles file []++  let report = runIdentity $ runAnalysisT (F.pfGetFilename pf) (logOutputNone True) LogError modFiles (infer False '=' pf)++  show (report ^?! arResult . _ARSuccess) `shouldBe` unlines (map Text.unpack expectedReport)++-- | Helper for producing a basic ModFile from a (terminal) module file.+mkTestModFile :: String -> IO ModFile+mkTestModFile file = head <$> genModFiles emptyModFiles compileStencils () file []++crossModuleAUserReport :: [L.Text]+crossModuleAUserReport =+  [unlines' [ "(7:6)-(7:16)    stencil readOnce, pointed(dim=1) :: b"]+  ]+ -- Indices for the 2D five point stencil (deliberately in an odd order) fivepoint = [ Cons (-1) (Cons 0 Nil), Cons 0 (Cons (-1) Nil)             , Cons 1 (Cons 0 Nil) , Cons 0 (Cons 1 Nil), Cons 0 (Cons 0 Nil)@@ -416,15 +502,19 @@                    return $ Cons x xs  test2DSpecVariation a b (input, expectation) =-    it ("format=" ++ show input) $-       -- Test inference-       indicesToSpec' ["i", "j"] [a, b] (map fromFormatToIx input)-          `shouldBe` Just expectedSpec+    it ("format=" ++ show input) $ do+      -- Test inference+      indicesToSpec' ["i", "j"] [a, b] (map fromFormatToIx input)+        `shouldBe` Just expectedSpec   where     expectedSpec = Specification expectation True     fromFormatToIx [ri,rj] = [ offsetToIx "i" ri, offsetToIx "j" rj ] -indicesToSpec' ivs lhs = fst . runWriter . indicesToSpec ivs "a" lhs+indicesToSpec' ivs lhs ixs =+  let inferer = indicesToSpec "a" lhs ixs+      analysis = runStencilInferer inferer ivs Gr.empty+      report = runIdentity $ runAnalysisT "example" (logOutputNone True) LogError emptyModFiles analysis+  in report ^?! arResult . _ARSuccess . _1  variations =   [ ( [ [0,0] ]@@ -497,9 +587,9 @@     it ("format=" ++ show input) $       -- Test inference       indicesToSpec' ["i", "j", "k"]-                     [Neighbour "i" 0, Neighbour "j" 0, Neighbour "k" 0]-                     (map fromFormatToIx input)-           `shouldBe` Just expectedSpec+             [Neighbour "i" 0, Neighbour "j" 0, Neighbour "k" 0]+             (map fromFormatToIx input)+        `shouldBe` Just expectedSpec    where     expectedSpec = Specification expectation True@@ -522,6 +612,8 @@ prop_extract_synth_inverse :: F.Name -> Int -> Bool prop_extract_synth_inverse v o =      convIxToNeighbour [v] (offsetToIx v o) == Neighbour v o++unlines' = Text.init . Text.unlines  -- Local variables: -- mode: haskell
+ tests/Camfort/Specification/Units/Analysis/ConsistentSpec.hs view
@@ -0,0 +1,163 @@+-- TODO: Fix this+module Camfort.Specification.Units.Analysis.ConsistentSpec (spec) where++import System.FilePath ((</>))++import Control.Lens++import Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++import Language.Fortran.Util.ModFile (ModFile, emptyModFiles)++import Camfort.Analysis hiding (describe)+import Camfort.Analysis.ModFile (genModFiles)+import Camfort.Input (readParseSrcDir)+import Camfort.Specification.Units.Analysis (compileUnits)+import Camfort.Specification.Units.Analysis.Consistent (checkUnits)+import Camfort.Specification.Units.Monad+  (LiteralsOpt(..), unitOpts0, uoLiterals, runUnitAnalysis, UnitEnv(..))++spec :: Test.Spec+spec =+  describe "consistency analysis" $ do+    it "reports (simple) inconsistent units" $+       "example-inconsist-1.f90" `unitsCheckReportIs` exampleInconsist1CheckReport+    it "Polymorphic non-zero literal is not OK" $+       "inconsistLitInPolyFun.f90" `unitsCheckReportIs` inconsistLitInPolyFunReport+    it "Recursive Multiplication is not OK" $+       "inconsistRecMult.f90" `unitsCheckReportIs` inconsistRecMultReport+    describe "reports with varying Literal Modes" $ do+      it "LitMixed" $+        unitsCheckReportNoMod LitMixed    "inconsist3.f90" inconsist3LitMixedReport+      it "LitPoly" $+        unitsCheckReportNoMod LitPoly     "inconsist3.f90" inconsist3LitPolyReport+      it "LitUnitless" $+        unitsCheckReportNoMod LitUnitless "inconsist3.f90" inconsist3LitUnitlessReport+    describe "cross-module" $+      it "basic inconsistent" $+        unitsCheckReportWithMod ["cross-module-a/crossmoduleprovider.f90"] "cross-module-a/crossmoduleuser.f90"+          crossModuleInconsistBasicReport+    describe "literals" $ do+      it "nonzero literal with explicitly annotated polymorphic units-variable" $+        "literal-nonzero-inconsist1.f90" `unitsCheckReportIs` literalNonZeroInconsist1Report+      it "nonzero literal is unitless in poly-context" $+        "literal-nonzero-inconsist2.f90" `unitsCheckReportIs` literalNonZeroInconsist2Report+      it "monomorphism restriction is important (do-loop)" $+        "literal-nonzero-inconsist3.f90" `unitsCheckReportIs` literalNonZeroInconsist3Report+      -- it "monomorphism restriction is important (do-loop with zero-start)" $+      --   "literal-nonzero-inconsist4.f90" `unitsCheckReportIs` literalNonZeroInconsist4Report+      it "monomorphism restriction is important (goto)" $+        "literal-nonzero-inconsist5.f90" `unitsCheckReportIs` literalNonZeroInconsist5Report+++fixturesDir :: String+fixturesDir = "tests" </> "fixtures" </> "Specification" </> "Units"++-- | Assert that the report of performing units checking on a file is as expected.+unitsCheckReport :: LiteralsOpt -> [String] -> String -> String -> Expectation+unitsCheckReport lo modNames fileName expectedReport = do+  let file = fixturesDir </> fileName+      modPaths = fmap (fixturesDir </>) modNames+  modFiles <- mapM mkTestModFile modPaths+  [(pf,_)] <- readParseSrcDir modFiles file []++  let uEnv = UnitEnv { unitOpts = uOpts, unitProgramFile = pf }++  report <- runAnalysisT file (logOutputNone True) LogError modFiles $ runUnitAnalysis uEnv $ checkUnits+  let res = report ^?! arResult . _ARSuccess++  show res `shouldBe` expectedReport+  where uOpts = unitOpts0 { uoLiterals = lo }++unitsCheckReportWithMod :: [String] -> String -> String -> Expectation+unitsCheckReportWithMod = unitsCheckReport LitMixed++unitsCheckReportNoMod :: LiteralsOpt -> String -> String -> Expectation+unitsCheckReportNoMod lo = unitsCheckReport lo []++-- | Assert that the report of performing units checking on a file is as expected.+unitsCheckReportIs :: String -> String -> Expectation+unitsCheckReportIs = unitsCheckReport LitMixed []++-- | Helper for producing a basic ModFile from a (terminal) module file.+mkTestModFile :: String -> IO ModFile+mkTestModFile file = head <$> genModFiles emptyModFiles compileUnits unitOpts0 file []++exampleInconsist1CheckReport :: String+exampleInconsist1CheckReport =+  "\ntests/fixtures/Specification/Units/example-inconsist-1.f90: Inconsistent:\n\+  \ - at 7:7: Units 's' and 'm' should be equal\n"++inconsist3LitMixedReport :: String+inconsist3LitMixedReport = inconsist3LitPolyReport++inconsist3LitPolyReport :: String+inconsist3LitPolyReport =+  "\ntests/fixtures/Specification/Units/inconsist3.f90: Inconsistent:\n\+   \ - at 6:3: 'j**2' should have the same units as 'k'\n\+   \ - at 7:7: 'k' should have unit 'a'\n\+   \ - at 8:3: 'j' should have unit '1'\n"++inconsist3LitUnitlessReport :: String+inconsist3LitUnitlessReport =+  "\ntests/fixtures/Specification/Units/inconsist3.f90: Inconsistent:\n\+  \ - at 5:3: 'j' should have unit '1'\n\+  \ - at 6:3: 'j**2' should have the same units as 'k'\n\+  \ - at 7:7: 'k' should have unit 'a'\n"++inconsistLitInPolyFunReport :: String+inconsistLitInPolyFunReport =+  "\ntests/fixtures/Specification/Units/inconsistLitInPolyFun.f90: Inconsistent:\n\+  \ - at 10:11: 'parameter 1 to sqr' should have unit 'm'\n\+  \ - at 15:13: 'z' should have unit '1'\n\+  \ - at 16:11: '(parameter 1 to sqr)**2' should have the same units as 'z'\n"++inconsistRecMultReport :: String+inconsistRecMultReport =+  "\ntests/fixtures/Specification/Units/inconsistRecMult.f90: Inconsistent:\n\+  \'parameter 2 to recur' should have the same units as 'parameter 2 to recur'\n\+  \'result of recur * parameter 2 to recur' should have the same units as 'result of recur'\n\+  \ - at 4:15: 'parameter 2 to recur' should have unit 'm'\n\+  \ - at 10:8: 'parameter 2 to recur' should have the same units as 'result of recur'\n"++crossModuleInconsistBasicReport :: String+crossModuleInconsistBasicReport =+  "\ntests/fixtures/Specification/Units/cross-module-a/crossmoduleuser.f90: Inconsistent:\n\+  \'add' should have the same units as 'parameter 1 to add'\n\+  \'add' should have the same units as 'parameter 2 to add'\n\+  \ - at 9:11: 'parameter 1 to add' should have unit 'm'\n\+  \ - at 9:14: 'parameter 2 to add' should have unit 's'\n"++literalNonZeroInconsist1Report :: String+literalNonZeroInconsist1Report =+  "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist1.f90: Inconsistent:\n\+  \ - at 11:5: 'f_'a' should have unit '1'\n"++literalNonZeroInconsist2Report :: String+literalNonZeroInconsist2Report =+  "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90: Inconsistent:\n\+  \ - at 5:9: 'parameter 1 to f' should have unit 'm'\n\+  \ - at 10:5: 'parameter 1 to f' should have unit '1'\n"++literalNonZeroInconsist3Report :: String+literalNonZeroInconsist3Report =+  "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90: Inconsistent:\n\+  \ - at 7:11: 'parameter 1 to sqr' should have unit 's'\n\+  \ - at 12:3: 'i' should have the same units as 'parameter 1 to sqr'\n\+  \ - at 15:8: 'i' should have unit '1'\n"++literalNonZeroInconsist4Report :: String -- fixme+literalNonZeroInconsist4Report =+  "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90: Inconsistent:\n\+  \- at 7:11: 'parameter 1 to sqr' should have unit 's'\n\+  \- at 15:9: 'i' should have the same units as 'parameter 1 to sqr'\n\+  \- at 17:12: 'i' should have unit '1'\n"++literalNonZeroInconsist5Report :: String+literalNonZeroInconsist5Report =+  "\ntests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90: Inconsistent:\n\+  \ - at 7:11: 'parameter 1 to sqr' should have unit 's'\n\+  \ - at 13:23: 'j' should have unit '1'\n\+  \ - at 15:9: 'i' should have the same units as 'parameter 1 to sqr'\n\+  \ - at 17:12: 'j' should have the same units as 'i'\n"
+ tests/Camfort/Specification/Units/Analysis/CriticalsSpec.hs view
@@ -0,0 +1,54 @@+module Camfort.Specification.Units.Analysis.CriticalsSpec (spec) where++import System.Directory (getCurrentDirectory)+import System.FilePath ((</>))++import Control.Lens++import Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++import Language.Fortran.Util.ModFile (emptyModFiles)++import Camfort.Analysis hiding (describe)+import Camfort.Analysis.ModFile (readParseSrcDir)+import Camfort.Specification.Units.Analysis.Criticals (inferCriticalVariables)+import Camfort.Specification.Units.Monad+  (LiteralsOpt(..), unitOpts0, uoLiterals, UnitEnv(..), runUnitAnalysis)++spec :: Test.Spec+spec = do+  describe "critical-units analysis" $ do+    it "reports critical variables" $+       "example-criticals-1.f90" `unitsCriticalsReportIs` exampleCriticals1CriticalsReport+    it "reports when no additional variables need to be annotated" $+       "example-criticals-2.f90" `unitsCriticalsReportIs` exampleCriticals2CriticalsReport++fixturesDir :: String+fixturesDir = "tests" </> "fixtures" </> "Specification" </> "Units"++-- | Assert that the report of performing units inference on a file is as expected.+unitsCriticalsReportIs :: String -> String -> Expectation+unitsCriticalsReportIs fileName expectedReport = do+  let file = fixturesDir </> fileName+      modFiles = emptyModFiles+  [(pf,_)] <- readParseSrcDir modFiles file []++  let uEnv = UnitEnv { unitOpts = uOpts, unitProgramFile = pf }++  report <- runAnalysisT file (logOutputNone True) LogError modFiles $ runUnitAnalysis uEnv $ inferCriticalVariables+  let res = report ^?! arResult . _ARSuccess++  show res `shouldBe` expectedReport+  where uOpts = unitOpts0 { uoLiterals = LitMixed }+++exampleCriticals1CriticalsReport :: String+exampleCriticals1CriticalsReport =+  "\ntests/fixtures/Specification/Units/example-criticals-1.f90: 2 variable declarations suggested to be given a specification:\n\+  \    tests/fixtures/Specification/Units/example-criticals-1.f90 (3:17)    b\n\+  \    tests/fixtures/Specification/Units/example-criticals-1.f90 (3:20)    c\n"++exampleCriticals2CriticalsReport :: String+exampleCriticals2CriticalsReport =+  "\ntests/fixtures/Specification/Units/example-criticals-2.f90: No additional annotations are necessary.\n"
+ tests/Camfort/Specification/Units/Analysis/InferSpec.hs view
@@ -0,0 +1,214 @@+module Camfort.Specification.Units.Analysis.InferSpec (spec) where++import System.FilePath ((</>))++import Control.Lens++import           Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++import Language.Fortran.Util.ModFile (emptyModFiles)++import Camfort.Analysis hiding (describe)+import Camfort.Analysis.ModFile (readParseSrcDir)+import Camfort.Specification.Units.Analysis.Infer (inferUnits)+import Camfort.Specification.Units.Monad+  (LiteralsOpt(..), unitOpts0, uoLiterals, runUnitAnalysis, UnitEnv(..))++spec :: Test.Spec+spec =+  describe "fixtures integration tests" $ do+    it "infers correctly based on simple addition" $+       "example-simple-1.f90" `unitsInferReportIs` exampleInferSimple1Report+    describe "Polymorphic functions" $+      it "squarePoly1" $+        "squarePoly1.f90" `unitsInferReportIs` squarePoly1Report+    describe "Recursive functions" $+      it "Recursive Addition is OK" $+        "recursive1.f90" `unitsInferReportIs` recursive1Report+    describe "Explicitly annotated parametric polymorphic unit variables" $ do+      it "inside-outside" $+        "insideOutside.f90" `unitsInferReportIs` insideOutsideReport+      it "eapVarScope" $+        "eapVarScope.f90" `unitsInferReportIs` eapVarScopeReport+      it "eapVarApp" $+        "eapVarApp.f90" `unitsInferReportIs` eapVarAppReport+    describe "Implicit parametric polymorphic unit variables" $+      it "inferPoly1" $+        "inferPoly1.f90" `unitsInferReportIs` inferPoly1Report+    describe "Intrinsic functions" $+      it "sqrtPoly" $+        "sqrtPoly.f90" `unitsInferReportIs` sqrtPolyReport+    describe "Intrinsic function transfer (explicit cast)" $+      it "transfer" $+        "transfer.f90" `unitsInferReportIs` transferReport+    describe "GCD of powers" $+      it "gcd1" $+        "gcd1.f90" `unitsInferReportIs` gcd1Report+    describe "literals" $ do+      it "literal-zero" $+        "literal-zero.f90" `unitsInferReportIs` literalZeroReport+      it "literal-nonzero" $+        "literal-nonzero.f90" `unitsInferReportIs` literalNonZeroReport+      it "do-loop1" $+        "do-loop1.f90" `unitsInferReportIs` doLoop1Report+      it "do-loop2" $+        "do-loop2.f90" `unitsInferReportIs` doLoop2Report+++fixturesDir :: String+fixturesDir = "tests" </> "fixtures" </> "Specification" </> "Units"++-- | Assert that the report of performing units inference on a file is as expected.+unitsInferReportIs :: String -> String -> Expectation+unitsInferReportIs fileName expectedReport = do+  let file = fixturesDir </> fileName+      modFiles = emptyModFiles+  [(pf,_)] <- readParseSrcDir modFiles file []++  let uEnv = UnitEnv { unitOpts = uOpts, unitProgramFile = pf }++  report <- runAnalysisT file (logOutputNone True) LogError modFiles $ runUnitAnalysis uEnv $ inferUnits+  let res = report ^?! arResult . _ARSuccess++  show res `shouldBe` expectedReport+  where uOpts = unitOpts0 { uoLiterals = LitMixed }++exampleInferSimple1Report :: String+exampleInferSimple1Report =+  "\ntests/fixtures/Specification/Units/example-simple-1.f90:\n\+  \  3:14 unit s :: x\n\+  \  3:17 unit s :: y\n"++inferReport :: String -> String -> String+inferReport fname res = concat ["\n", fixturesDir </> fname, ":\n", res]++squarePoly1Report :: String+squarePoly1Report = inferReport "squarePoly1.f90"+  "  4:11 unit m**2 :: x\n\+  \  5:11 unit s**2 :: y\n\+  \  7:11 unit m :: a\n\+  \  9:11 unit s :: b\n\+  \  13:3 unit ('a)**2 :: square\n\+  \  14:13 unit 'a :: n\n\+  \  17:3 unit ('b)**2 :: squarep\n\+  \  18:13 unit 'b :: m\n"++recursive1Report :: String+recursive1Report = inferReport "recursive1.f90"+  "  3:14 unit 1 :: x\n\+  \  3:21 unit m :: y\n\+  \  3:28 unit m :: z\n\+  \  7:3 unit 'a :: r\n\+  \  8:16 unit 1 :: n\n\+  \  8:19 unit 'a :: b\n"++insideOutsideReport :: String+insideOutsideReport = inferReport "insideOutside.f90"+  "  5:13 unit 'a :: x\n\+  \  5:16 unit 'a :: k\n\+  \  5:19 unit ('a)**2 :: m\n\+  \  5:22 unit ('a)**2 :: outside\n\+  \  12:15 unit 'a :: y\n\+  \  12:18 unit ('a)**2 :: inside\n"++eapVarScopeReport :: String+eapVarScopeReport = inferReport "eapVarScope.f90"+  "  5:13 unit 'a :: x\n\+  \  5:16 unit ('a)**3 :: k\n\+  \  5:19 unit ('a)**3 :: f\n\+  \  11:13 unit 'a :: y\n\+  \  11:16 unit 'a :: j\n\+  \  11:19 unit 'a :: g\n"++eapVarAppReport :: String+eapVarAppReport = inferReport "eapVarApp.f90"+  "  5:13 unit 'a :: fx\n\+  \  5:17 unit 'a :: fj\n\+  \  5:21 unit ('a)**2 :: fk\n\+  \  5:25 unit ('a)**4 :: fl\n\+  \  5:29 unit ('a)**2 :: f\n\+  \  13:13 unit 'b :: gx\n\+  \  13:17 unit 'b :: gn\n\+  \  13:21 unit 'b :: gm\n\+  \  13:25 unit 'b :: g\n\+  \  20:13 unit m :: hx\n\+  \  20:17 unit m**2 :: h\n\+  \  20:20 unit m**2 :: hy\n"++inferPoly1Report :: String+inferPoly1Report = inferReport "inferPoly1.f90"+  "  4:13 unit 'c :: x1\n\+  \  4:17 unit 'c :: id\n\+  \  8:13 unit 'f :: x2\n\+  \  8:17 unit ('f)**2 :: sqr\n\+  \  12:13 unit 'a :: x3\n\+  \  12:17 unit 'b :: y3\n\+  \  12:21 unit 'a :: fst\n\+  \  16:13 unit 'e :: x4\n\+  \  16:17 unit 'd :: y4\n\+  \  16:21 unit 'd :: snd\n"++sqrtPolyReport :: String+sqrtPolyReport = inferReport "sqrtPoly.f90"+  "  4:11 unit m :: x\n\+  \  6:11 unit s :: y\n\+  \  8:11 unit j :: z\n\+  \  9:14 unit m**2 :: a\n\+  \  10:14 unit s**4 :: b\n\+  \  11:14 unit j**2 :: c\n\+  \  16:3 unit ('a)**2 :: square\n\+  \  17:13 unit 'a :: n\n"++transferReport :: String+transferReport = inferReport "transfer.f90"+  "  4:11 unit m :: x\n\+  \  6:11 unit s :: y\n"++gcd1Report :: String+gcd1Report = inferReport "gcd1.f90"+  "  3:3 unit ('a)**12 :: g\n\+  \  4:13 unit ('a)**2 :: x\n\+  \  4:16 unit ('a)**3 :: y\n"++literalZeroReport :: String+literalZeroReport = inferReport "literal-zero.f90"+  "  3:11 unit m :: a\n\+  \  3:14 unit m :: b\n\+  \  9:3 unit 'a :: f\n\+  \  11:13 unit 'a :: x\n"++literalNonZeroReport :: String+literalNonZeroReport = inferReport "literal-nonzero.f90"+  "  2:11 unit m s :: a\n\+  \  2:14 unit m s :: b\n\+  \  8:3 unit m s :: f\n\+  \  10:13 unit m s :: x\n"++doLoop1Report :: String+doLoop1Report = inferReport "do-loop1.f90"+  "  3:11 unit m :: x\n\+  \  3:14 unit m :: y\n\+  \  4:14 unit m :: i\n\+  \  10:3 unit 1 :: f\n\+  \  11:13 unit 1 :: x\n\+  \  11:16 unit 1 :: y\n\+  \  12:16 unit 1 :: i\n"++doLoop2Report :: String+doLoop2Report = inferReport "do-loop2.f90"+  "  3:11 unit m :: x\n\+  \  3:14 unit m :: y\n\+  \  4:14 unit m :: i\n\+  \  10:3 unit 1 :: f\n\+  \  11:13 unit 1 :: x\n\+  \  11:16 unit 1 :: y\n\+  \  12:16 unit 1 :: i\n\+  \  19:3 unit 1 :: g\n\+  \  20:13 unit 1 :: x\n\+  \  20:16 unit 1 :: y\n\+  \  21:16 unit 1 :: i\n\+  \  28:3 unit 'a :: h\n\+  \  29:13 unit 'a :: x\n\+  \  29:16 unit 'a :: y\n\+  \  30:16 unit 'a :: i\n"
tests/Camfort/Specification/Units/InferenceBackendSpec.hs view
@@ -6,15 +6,17 @@ import qualified Test.Hspec as Test  import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.InferenceBackend-  ( criticalVariables-  , flattenConstraints-  , inconsistentConstraints-  , inferVariables-  , shiftTerms )+import Camfort.Specification.Units.InferenceBackendSBV ( criticalVariables, inconsistentConstraints, inferVariables )+import Camfort.Specification.Units.InferenceBackend ( flattenConstraints, shiftTerms )+import Camfort.Specification.Units.BackendTypes (constraintToDim, dimParamEq, Dim, dimFromList, prop_composition)+import Data.Maybe (fromJust)+import Test.QuickCheck  spec :: Test.Spec spec = do+  describe "Backend Types" $+    it "Substitution composition" $ property $+      prop_composition   describe "Flatten constraints" $     it "testCons1" $       flattenConstraints testCons1 `shouldBe` testCons1_flattened@@ -27,7 +29,8 @@       map shiftTerms (flattenConstraints testCons3) `shouldBe` testCons3_shifted   describe "Consistency" $ do     it "testCons1" $-      inconsistentConstraints testCons1 `shouldBe` Just [ConEq (UnitName "kg") (UnitName "m")]+      (constraintToDim . head . fromJust $ inconsistentConstraints testCons1) `shouldSatisfy`+        dimParamEq (dimFromList [(UnitName "kg", -1), (UnitName "m", 1)])     it "testCons2" $       inconsistentConstraints testCons2 `shouldBe` Nothing     it "testCons3" $@@ -42,12 +45,17 @@     it "testCons5" $       criticalVariables testCons5 `shouldSatisfy` null   describe "Infer Variables" $-    it "testCons5" $+    it "testCons4" $       show (inferVariables testCons5) `shouldBe` show testCons5_infer   describe "Check that (restricted) double to ratios is consistent" $     it "test all in -10/-10 ... 10/10, apart from /0" $       and [testDoubleToRationalSubset x y | x <- [-10..10], y <- [-10..10]] +instance Arbitrary UnitInfo where+  arbitrary = do+    name <- arbitrary+    return $ UnitVar (name, name)+ testCons1 = [ ConEq (UnitName "kg") (UnitName "m")             , ConEq (UnitVar ("x", "x")) (UnitName "m")             , ConEq (UnitVar ("y", "y")) (UnitName "kg")]@@ -102,8 +110,8 @@  testCons4 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse (("simple2_sqr3","sqr"),0,0))             ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitParamPosUse (("simple2_sqr3","sqr"),1,0))-            ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11"))-            ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitVar ("simple2_a22", "simple2_a22"))+            -- ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11"))+            -- ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitVar ("simple2_a22", "simple2_a22"))             ,ConEq (UnitParamPosUse (("simple2_sqr3","sqr"),0,0)) (UnitMul (UnitParamPosUse (("simple2_sqr3","sqr"),1,0)) (UnitParamPosUse (("simple2_sqr3","sqr"),1,0)))]  testCons5 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse (("simple2_sqr3","sqr"),0,0))
− tests/Camfort/Specification/Units/InferenceFrontendSpec.hs 
@@ -1,295 +0,0 @@-module Camfort.Specification.Units.InferenceFrontendSpec (spec) where--import qualified Data.ByteString.Char8 as B-import           Data.Either (rights)-import           Data.Generics.Uniplate.Operations (universeBi)-import           Data.List (nub, sort)-import           Data.Maybe (fromJust, isJust, mapMaybe, maybeToList)--import           Test.Hspec hiding (Spec)-import qualified Test.Hspec as Test--import           Language.Fortran.Parser.Any (fortranParser)-import           Language.Fortran.ParserMonad (fromRight)-import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Analysis as FA--import Camfort.Analysis.Annotations (UA, unitAnnotation)-import Camfort.Specification.Units (chooseImplicitNames)-import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.InferenceFrontend-  ( initInference-  , runInconsistentConstraints-  , runInferVariables-  )-import Camfort.Specification.Units.Monad-  (LiteralsOpt(..), runUnitSolver, unitOpts0, uoDebug, uoLiterals, usConstraints)--spec :: Test.Spec-spec = do-  let showClean = show . nub . sort . head . rights . (:[]) . fst-  describe "Unit Inference Frontend" $ do-    describe "Literal Mode" $ do-      it "litTest1 Mixed" $-        fromJust (head (rights [fst (runUnits LitMixed litTest1 runInconsistentConstraints)])) `shouldSatisfy`-          any (conParamEq (ConEq (UnitVar ("k", "k")) (UnitMul (UnitVar ("j", "j")) (UnitVar ("j", "j")))))-      it "litTest1 Poly" $-        fromJust (head (rights [fst (runUnits LitPoly litTest1 runInconsistentConstraints)])) `shouldSatisfy`-          any (conParamEq (ConEq (UnitVar ("k", "k")) (UnitMul (UnitVar ("j", "j")) (UnitVar ("j", "j")))))-      it "litTest1 Unitless" $-        fromJust (head (rights [fst (runUnits LitUnitless litTest1 runInconsistentConstraints)])) `shouldSatisfy`-          any (conParamEq (ConEq UnitlessLit (UnitVar ("j", "j"))))-      it "Polymorphic non-zero literal is not OK" $-        head (rights [fst (runUnits LitMixed inconsist1 runInconsistentConstraints)]) `shouldSatisfy` isJust--    describe "Polymorphic functions" $-      it "squarePoly1" $-        showClean (runUnits LitMixed squarePoly1 (fmap chooseImplicitNames runInferVariables)) `shouldBe`-          "[((\"a\",\"a\"),m),((\"b\",\"b\"),s),((\"m\",\"m\"),'b),((\"n\",\"n\"),'a),((\"square\",\"square\"),('a)**2),((\"squarep\",\"squarep\"),('b)**2),((\"x\",\"x\"),m**2),((\"y\",\"y\"),s**2)]"-    describe "Recursive functions" $-      it "Recursive Addition is OK" $-        showClean (runUnits LitMixed recursive1 (fmap chooseImplicitNames runInferVariables)) `shouldBe`-          "[((\"b\",\"b\"),'a),((\"n\",\"n\"),1),((\"r\",\"r\"),'a),((\"x\",\"x\"),1),((\"y\",\"y\"),m),((\"z\",\"z\"),m)]"--    describe "Recursive functions" $-      it "Recursive Multiplication is not OK" $-        fromJust (head (rights [fst (runUnits LitMixed recursive2 runInconsistentConstraints)])) `shouldSatisfy`-          any (conParamEq (ConEq (UnitParamPosAbs (("recur", "recur"), 0)) (UnitParamPosAbs (("recur", "recur"), 2))))--    describe "Explicitly annotated parametric polymorphic unit variables" $ do-      it "inside-outside" $-        showClean (runUnits LitMixed insideOutside runInferVariables) `shouldBe`-          "[((\"inside\",\"inside\"),('a)**2),((\"k\",\"k\"),'a),((\"m\",\"m\"),('a)**2),((\"outside\",\"outside\"),('a)**2),((\"x\",\"x\"),'a),((\"y\",\"y\"),'a)]"-      it "eapVarScope" $-        show (sort (fst (runUnitInference LitMixed eapVarScope))) `shouldBe`-          "[(\"f\",('a)**3),(\"g\",'a),(\"j\",'a),(\"k\",('a)**3),(\"x\",'a),(\"y\",'a)]"-      it "eapVarApp" $-        show (sort (fst (runUnitInference LitMixed eapVarApp))) `shouldBe`-          "[(\"f\",('a)**2),(\"fj\",'a),(\"fk\",('a)**2),(\"fl\",('a)**4),(\"fx\",'a),(\"g\",'b),(\"gm\",'b),(\"gn\",'b),(\"gx\",'b),(\"h\",m**2),(\"hx\",m),(\"hy\",m**2)]"--    describe "Implicit parametric polymorphic unit variables" $-      it "inferPoly1" $-        show (sort (fst (runUnitInference LitMixed inferPoly1))) `shouldBe`-          "[(\"fst\",'a),(\"id\",'c),(\"snd\",'d),(\"sqr\",('f)**2),(\"x1\",'c),(\"x2\",'f),(\"x3\",'a),(\"x4\",'e),(\"y3\",'b),(\"y4\",'d)]"--    describe "Intrinsic functions" $-      it "sqrtPoly" $-        show (sort (fst (runUnitInference LitMixed sqrtPoly))) `shouldBe`-          "[(\"a\",m**2),(\"b\",s**4),(\"c\",j**2),(\"n\",'a),(\"x\",m),(\"y\",s),(\"z\",j)]"--runUnits litMode pf m = (r, usConstraints state)-  where-    pf' = FA.initAnalysis . fmap (mkUnitAnnotation . const unitAnnotation) $ pf-    uOpts = unitOpts0 { uoDebug = False, uoLiterals = litMode }-    (r, state, _) = runUnitSolver uOpts pf' $ initInference >> m--runUnitInference litMode pf = case r of-  Right vars -> ([ (FA.varName e, u) | e <- declVariables pf'-                                     , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ]-                , usConstraints state)-  _          -> ([], usConstraints state)-  where-    pf' = FA.initAnalysis . fmap (mkUnitAnnotation . const unitAnnotation) $ pf-    uOpts = unitOpts0 { uoDebug = False, uoLiterals = litMode }-    (r, state, _) = runUnitSolver uOpts pf' $ initInference >> fmap chooseImplicitNames runInferVariables--declVariables :: F.ProgramFile UA -> [F.Expression UA]-declVariables pf = flip mapMaybe (universeBi pf) $ \ d -> case d of-  F.DeclVariable _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _   -> Just v-  F.DeclArray    _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just v-  _                                                             -> Nothing--fortranParser' x = fromRight . fortranParser x--litTest1 = flip fortranParser' "litTest1.f90" . B.pack $ unlines-    [ "program main"-    , "  != unit(a) :: x"-    , "  real :: x, j, k"-    , ""-    , "  j = 1 + 1"-    , "  k = j * j"-    , "  x = x + k"-    , "  x = x * j ! inconsistent"-    , "end program main" ]--squarePoly1 = flip fortranParser' "squarePoly1.f90" . B.pack $ unlines-    [ "! Demonstrates parametric polymorphism through functions-calling-functions."-    , "program squarePoly"-    , "  implicit none"-    , "  real :: x"-    , "  real :: y"-    , "  != unit(m) :: a"-    , "  real :: a"-    , "  != unit(s) :: b"-    , "  real :: b"-    , "  x = squareP(a)"-    , "  y = squareP(b)"-    , "  contains"-    , "  real function square(n)"-    , "    real :: n"-    , "    square = n * n"-    , "  end function"-    , "  real function squareP(m)"-    , "    real :: m"-    , "    squareP = square(m)"-    , "  end function"-    , "end program" ]--recursive1 = flip fortranParser' "recursive1.f90" . B.pack $ unlines-    [ "program main"-    , "  != unit(m) :: y"-    , "  integer :: x = 5, y = 2, z"-    , "  z = recur(x,y)"-    , "  print *, y"-    , "contains"-    , "  real recursive function recur(n, b) result(r)"-    , "    integer :: n, b"-    , "    if (n .EQ. 0) then"-    , "       r = b"-    , "    else"-    , "       r = b + recur(n - 1, b)"-    , "    end if"-    , "  end function recur"-    , "end program main" ]--recursive2 = flip fortranParser' "recursive2.f90" . B.pack $ unlines-    [ "program main"-    , "  != unit(m) :: y"-    , "  integer :: x = 5, y = 2, z"-    , "  z = recur(x,y)"-    , "  print *, y"-    , "contains"-    , "  real recursive function recur(n, b) result(r)"-    , "    integer :: n, b"-    , "    if (n .EQ. 0) then"-    , "       r = b"-    , "    else"-    , "       r = b * recur(n - 1, b) ! inconsistent"-    , "    end if"-    , "  end function recur"-    , "end program main" ]--insideOutside = flip fortranParser' "insideOutside.f90" . B.pack $ unlines-    [ "module insideOutside"-    , "contains"-    , "  function outside(x)"-    , "    != unit 'a :: x"-    , "    real :: x, k, m, outside"-    , "    k = x"-    , "    outside = inside(k) * 2"-    , "    m = outside"-    , "  contains"-    , "    function inside(y)"-    , "      != unit 'a ** 2 :: inside"-    , "      real :: y, inside"-    , "      inside = y * y"-    , "    end function inside"-    , "  end function outside"-    , "end module insideOutside" ]--eapVarScope = flip fortranParser' "eapVarScope.f90" . B.pack $ unlines-    [ "module eapVarScope"-    , "contains"-    , "  function f(x)"-    , "    != unit 'a :: x"-    , "    real :: x, k, f"-    , "    k = g(x) * g(x * x)"-    , "    f = k"-    , "  end function f"-    , "  function g(y)"-    , "    != unit 'a :: y"-    , "    real :: y, j, g"-    , "    j = y"-    , "    g = j"-    , "  end function g"-    , "end module eapVarScope" ]--eapVarApp = flip fortranParser' "eapVarApp.f90" . B.pack $ unlines-    [ "module eapVarApp"-    , "contains"-    , "  function f(fx)"-    , "    != unit 'a :: fx"-    , "    real :: fx, fj, fk, fl, f"-    , "    fj = fx"-    , "    fk = g(fj*fj)"-    , "    fl = fj * g(fj * fj * fj)"-    , "    f = fk"-    , "  end function f"-    , "  function g(gx)"-    , "    != unit 'b :: gx"-    , "    real :: gx, gn, gm, g"-    , "    gm = gx"-    , "    gn = gm"-    , "    g = gn"-    , "  end function g"-    , "  function h(hx)"-    , "    != unit m :: hx"-    , "    real :: hx, h, hy"-    , "    hy = f(hx)"-    , "    h = hy"-    , "  end function h"-    , "end module eapVarApp" ]--inferPoly1 = flip fortranParser' "inferPoly1.f90" . B.pack $ unlines-    [ "module inferPoly1"-    , "contains"-    , "  function id(x1)"-    , "    real :: x1, id"-    , "    id = x1"-    , "  end function id"-    , "  function sqr(x2)"-    , "    real :: x2, sqr"-    , "    sqr = x2 * x2"-    , "  end function sqr"-    , "  function fst(x3,y3)"-    , "    real :: x3, y3, fst"-    , "    fst = x3"-    , "  end function fst"-    , "  function snd(x4,y4)"-    , "    real :: x4, y4, snd"-    , "    snd = y4"-    , "  end function snd"-    , "end module inferPoly1" ]---- This should be inconsistent because of the use of the literal "10"--- in the parametric polymorphic function sqr.-inconsist1 = flip fortranParser' "inconsist1.f90" . B.pack $ unlines-    [ "program inconsist1"-    , "  implicit none"-    , "  real :: a, b"-    , "  != unit(m) :: x"-    , "  real :: x = 1"-    , "  != unit(s) :: t"-    , "  real :: t = 2"-    , "  a = sqr(x) "-    , "  b = sqr(t)"-    , "  contains "-    , "  real function sqr(y)"-    , "    real :: y"-    , "    real :: z = 10"-    , "    sqr = y * y + z"-    , "  end function"-    , "end program inconsist1" ]---- Test intrinsic function sqrt()-sqrtPoly = flip fortranParser' "sqrtPoly.f90" . B.pack $ unlines-    [ "program sqrtPoly"-    , "  implicit none"-    , "  != unit m :: x"-    , "  real :: x"-    , "  != unit s :: y"-    , "  real :: y"-    , "  != unit J :: z"-    , "  real :: z"-    , "  integer :: a"-    , "  integer :: b"-    , "  integer :: c"-    , "  x = sqrt(a)"-    , "  y = sqrt(sqrt(b))"-    , "  z = sqrt(square(sqrt(c)))"-    , "contains"-    , "  real function square(n)"-    , "    real :: n"-    , "    square = n * n"-    , "  end function square"-    , "end program sqrtPoly" ]
− tests/Camfort/Specification/UnitsSpec.hs 
@@ -1,37 +0,0 @@-module Camfort.Specification.UnitsSpec (spec) where--import System.FilePath ((</>))--import Test.Hspec--import Camfort.Input (readParseSrcDir)-import Camfort.Specification.Units (checkUnits)-import Camfort.Specification.Units.Monad-  (LiteralsOpt(..), unitOpts0, uoDebug, uoLiterals)--spec :: Spec-spec =-  describe "fixtures integration tests" $-    describe "units-check" $-      it "reports (simple) inconsistent units" $-         "example-inconsist-1.f90" `unitsCheckReportIs` exampleInconsist1CheckReport--fixturesDir :: String-fixturesDir = "tests" </> "fixtures" </> "Specification" </> "Units"---- | Assert that the report of performing units checking on a file is as expected.-unitsCheckReportIs :: String -> String -> Expectation-fileName `unitsCheckReportIs` expectedReport = do-  let file = fixturesDir </> fileName-  [(pf,_)] <- readParseSrcDir file []-  checkUnits uOpts pf `shouldBe` expectedReport-  where uOpts = unitOpts0 { uoDebug = False, uoLiterals = LitMixed }--exampleInconsist1CheckReport :: String-exampleInconsist1CheckReport =-  "\ntests/fixtures/Specification/Units/example-inconsist-1.f90: Inconsistent:\n\-  \ - at 7:7: 'z' should have unit 's'\n\-  \ - at 7:7: Units 's' and 'm' should be equal\n\n\n\-  \(7:7)-(7:11): s === m\n\-  \(7:3)-(7:11): unit_of(z) === s\n\-  \(1:1)-(8:19): unit_of(z) === s && s === m\n"
tests/Camfort/Transformation/CommonSpec.hs view
@@ -1,11 +1,12 @@ module Camfort.Transformation.CommonSpec (spec) where -import System.FilePath-import System.Directory+import           System.Directory+import           System.FilePath -import Test.Hspec+import           Test.Hspec -import Camfort.Functionality+import           Camfort.Analysis.Logger (LogLevel (..))+import           Camfort.Functionality  samplesBase :: FilePath samplesBase = "tests" </> "fixtures" </> "Transformation"@@ -29,7 +30,16 @@       expectedMod <- runIO $ readSample "cmn.expected.f90"        let outFile = samplesBase </> "common.f90.out"-      runIO $ common (samplesBase </> "common.f90") [] outFile+          commonFile = samplesBase </> "common.f90"++          env = CamfortEnv+            { ceInputSources = commonFile+            , ceIncludeDir = Just (takeDirectory commonFile)+            , ceExcludeFiles = []+            , ceLogLevel = LogDebug+            }++      runIO $ common outFile env        actual    <- runIO $ readSample "common.f90.out"       actualMod <- runIO $ readSample "cmn.f90"
tests/Camfort/Transformation/EquivalenceElimSpec.hs view
@@ -13,20 +13,34 @@    See the License for the specific language governing permissions and    limitations under the License. -}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}  module Camfort.Transformation.EquivalenceElimSpec (spec) where -import System.FilePath-import System.Directory+import           Control.Arrow                          (second)+import           Control.Monad                          (forM_)+import           System.Directory+import           System.FilePath+import           System.IO.Silently                     (capture_) -import Test.Hspec+import           Control.Lens -import Camfort.Transformation.EquivalenceElim-import Camfort.Functionality-import Camfort.Input+import           Test.Hspec +import qualified Language.Fortran.Util.Position         as FU++import           Camfort.Analysis                       hiding (describe)+import           Camfort.Analysis.Logger                hiding (describe)+import           Camfort.Analysis.ModFile               (MFCompiler,+                                                         genModFiles,+                                                         simpleCompiler)+import           Camfort.Analysis.TestUtils+import           Camfort.Functionality+import           Camfort.Input+import           Camfort.Transformation.EquivalenceElim+ samplesBase :: FilePath samplesBase = "tests" </> "fixtures" </> "Transformation" @@ -38,8 +52,16 @@ readActual :: FilePath -> IO String readActual argumentFilename = do   let argumentPath = samplesBase </> argumentFilename-  let outFile = argumentPath `addExtension` "out"-  equivalences argumentPath [] outFile+      outFile = argumentPath `addExtension` "out"++      env = CamfortEnv+        { ceInputSources = argumentPath+        , ceIncludeDir = Nothing+        , ceExcludeFiles = []+        , ceLogLevel = LogInfo+        }++  equivalences outFile env   actual <- readFile outFile   removeFile outFile   return actual@@ -51,14 +73,33 @@       actual <- runIO $ readActual "equiv.f90"       it "it eliminates equivalence statements" $         actual `shouldBe` expected-      -----      let rfun = mapM refactorEquivalences+       let infile = samplesBase </> "equiv.f90"-      report <- runIO $ doRefactor rfun infile [] "equiv.expected.f90"-      it "report is as expected" $-        report `shouldBe` expectedReport -expectedReport =-  "6:3: removed equivalence \n\-  \14:3: added copy due to refactored equivalence\n\-  \15:3: added copy due to refactored equivalence\n"+          input = testInputSources infile & tiIncludeDir .~ Just infile++      it "log is as expected" $+        testSingleFileAnalysis input (generalizePureAnalysis . refactorEquivalences) $ \report -> do+          let infoLogs = report ^.. arMessages . traverse . _MsgInfo++              addCopyMsg = "added copy due to refactored equivalence"+              removeMsg = "removed equivalence"++              expectedLogs =+                [ ((6, 3), removeMsg)+                , ((14, 3), addCopyMsg)+                , ((15, 3), addCopyMsg)+                ]++              spanMatches (pl, pc) (FU.SrcSpan (FU.Position _ pc1 pl1) (FU.Position _ pc2 pl2)) =+                pl == pl1 && pl == pl2 &&+                pc == pc1 && pc == pc2++              matchesExpected (expectedSpan, expectedText) message =+                spanMatches expectedSpan (message ^?! lmOrigin . _Just . oSpan) &&+                expectedText == message ^. lmMsg++          (putStrLn . show $ infoLogs)++          forM_ (zip infoLogs expectedLogs) $ \(message, expectedMessage) ->+            message `shouldSatisfy` matchesExpected expectedMessage
tests/fixtures/Specification/Stencils/example2.f view
@@ -22,7 +22,6 @@                x = a(i-1,j) + a(i,j) + a(i+1,j) + abs(0) c= stencil readOnce, pointed(dim=1)*r2 + pointed(dim=2)*r1 :: a                             b(i,j) = (x + a(i,j-1) + a(i,j+1)) / 5.0-c No specification should be inferred here              b(0,0) = a(i, j)             end if  4       continue
+ tests/fixtures/Specification/Units/do-loop1.f90 view
@@ -0,0 +1,18 @@+program doLoop1+  != unit m :: x+  real :: x, y = 0+  integer :: i+  do i=0,x+     y = y + x+  end do++contains+  real function f(x)+    real :: x, y = 0+    integer :: i+    do i=0,x+       y = y + x+    end do+    f = y+  end function f+end program doLoop1
+ tests/fixtures/Specification/Units/do-loop2.f90 view
@@ -0,0 +1,36 @@+program doLoop2+  != unit m :: x+  real :: x, y = 0,z+  integer :: i+  do i=0,x,2*3+     y = y + x+  end do++contains+  real function f(x)+    real :: x, y = 0+    integer :: i+    do i=0,x+       y = y + x+    end do+    f = y+  end function f++  real function g(x)+    real :: x, y = 0+    integer :: i+    do i=0,x,x/x+       y = y + x+    end do+    g = y+  end function g++  real function h(x)+    real :: x, y = 0+    integer :: i+    do i=0,x,x+       y = y + x+    end do+    h = y+  end function h+end program doLoop2
+ tests/fixtures/Specification/Units/eapVarApp.f90 view
@@ -0,0 +1,24 @@+module eapVarApp+contains+  function f(fx)+    != unit 'a :: fx+    real :: fx, fj, fk, fl, f+    fj = fx+    fk = g(fj*fj)+    fl = fj * g(fj * fj * fj)+    f = fk+  end function f+  function g(gx)+    != unit 'b :: gx+    real :: gx, gn, gm, g+    gm = gx+    gn = gm+    g = gn+  end function g+  function h(hx)+    != unit m :: hx+    real :: hx, h, hy+    hy = f(hx)+    h = hy+  end function h+end module eapVarApp
+ tests/fixtures/Specification/Units/eapVarScope.f90 view
@@ -0,0 +1,15 @@+module eapVarScope+contains+  function f(x)+    != unit 'a :: x+    real :: x, k, f+    k = g(x) * g(x * x)+    f = k+  end function f+  function g(y)+    != unit 'a :: y+    real :: y, j, g+    j = y+    g = j+  end function g+end module eapVarScope
+ tests/fixtures/Specification/Units/example-criticals-1.f90 view
@@ -0,0 +1,5 @@+program example+  implicit none+  integer :: a, b, c+  a = b * c+end program example
+ tests/fixtures/Specification/Units/example-criticals-2.f90 view
@@ -0,0 +1,7 @@+program example+  implicit none+  != unit (s) :: b+  != unit (m) :: c+  integer :: a, b, c+  a = b * c+end program example
+ tests/fixtures/Specification/Units/example-simple-1.f90 view
@@ -0,0 +1,6 @@+program example+  != unit (s) :: x+  integer :: x, y+  x = 5+  y = x + 1+end program example
+ tests/fixtures/Specification/Units/gcd1.f90 view
@@ -0,0 +1,7 @@+module complexity+contains+  real function g(x, y)+    real :: x, y, z+    g = (x*x*x*x*x*x + y*y*y*y)+  end function g+end module complexity
+ tests/fixtures/Specification/Units/inconsist3.f90 view
@@ -0,0 +1,9 @@+program example+  != unit(a) :: x+  real :: x, j, k++  j = 1 + 1+  k = j * j+  x = x + k+  x = x * j ! inconsistent+end program example
+ tests/fixtures/Specification/Units/inconsistLitInPolyFun.f90 view
@@ -0,0 +1,18 @@+! This should be inconsistent because of the use of the literal "10"+! in the parametric polymorphic function sqr.+program example+  implicit none+  real :: a, b+  != unit(m) :: x+  real :: x = 1+  != unit(s) :: t+  real :: t = 2+  a = sqr(x)+  b = sqr(t)+  contains+  real function sqr(y)+    real :: y+    real :: z = 10+    sqr = y * y + z+  end function+end program example
+ tests/fixtures/Specification/Units/inconsistRecMult.f90 view
@@ -0,0 +1,15 @@+program main+  != unit(m) :: y+  integer :: x = 5, y = 2, z+  z = recur(x,y)+  print *, y+contains+  real recursive function recur(n, b) result(r)+    integer :: n, b+    if (n .EQ. 0) then+       r = b+    else+       r = b * recur(n - 1, b) ! inconsistent+    end if+  end function recur+end program main
+ tests/fixtures/Specification/Units/inferPoly1.f90 view
@@ -0,0 +1,19 @@+module inferPoly1+contains+  function id(x1)+    real :: x1, id+    id = x1+  end function id+  function sqr(x2)+    real :: x2, sqr+    sqr = x2 * x2+  end function sqr+  function fst(x3,y3)+    real :: x3, y3, fst+    fst = x3+  end function fst+  function snd(x4,y4)+    real :: x4, y4, snd+    snd = y4+  end function snd+end module inferPoly1
+ tests/fixtures/Specification/Units/insideOutside.f90 view
@@ -0,0 +1,16 @@+module insideOutside+contains+  function outside(x)+    != unit 'a :: x+    real :: x, k, m, outside+    k = x+    outside = inside(k) * 2+    m = outside+  contains+    function inside(y)+      != unit 'a ** 2 :: inside+      real :: y, inside+      inside = y * y+    end function inside+  end function outside+end module insideOutside
+ tests/fixtures/Specification/Units/literal-nonzero-inconsist1.f90 view
@@ -0,0 +1,14 @@+program literalnonzero+  real :: a, b+  a = 2+  b = f(a)++contains+  ! unit 'a :: f+  real function f(x)+    != unit 'a :: x+    real :: x+    x = 1+    f = x+  end function f+end program literalnonzero
+ tests/fixtures/Specification/Units/literal-nonzero-inconsist2.f90 view
@@ -0,0 +1,13 @@+program literalnonzero+  != unit m :: a+  real :: a, b+  a = 2+  b = f(a)++contains+  real function f(x)+    real :: x+    x = 1+    f = x+  end function f+end program literalnonzero
+ tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90 view
@@ -0,0 +1,36 @@+program literalnonzero+  != unit m :: a+  != unit s :: b+  real :: a, b+  a = 2+  a = sqr(a)+  b = sqr(b)++contains+  ! without monomorphism restriction I could write a 'squaring'+  ! function that the units inference system wouldn't recognise: 'a -> 'a+  real function sqr(x)+    real :: x, i+    sqr = 0+    do i=1, x ! disallowed under monomorphism restriction+       sqr = sqr + x+    end do+    ! sqr is now equal to x * x+  end function sqr+end program literalnonzero+++! with monomorphism restriction disabled:+!+! tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90:+!   4:11 unit m :: a+!   4:14 unit s :: b+!   12:3 unit 'a :: sqr+!   13:13 unit 'a :: x+!   13:16 unit 'a :: i+!+! with it enabled (normal):+! tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90: Inconsistent:+!  - at 7:11: 'parameter 1 to sqr' should have unit 's'+!  - at 12:3: 'i' should have the same units as 'parameter 1 to sqr'+!  - at 15:8: 'i' should have unit '1'
+ tests/fixtures/Specification/Units/literal-nonzero-inconsist4.f90 view
@@ -0,0 +1,36 @@+program literalnonzero+  != unit m :: a+  != unit s :: b+  real :: a, b+  a = 2+  a = sqr(a)+  b = sqr(b)++contains+  ! without monomorphism restriction I could write a 'squaring'+  ! function that the units inference system wouldn't recognise: 'a -> 'a+  real function sqr(x)+    real :: x, i+    sqr = 0+    do i=0, x ! disallowed under monomorphism restriction+       sqr = sqr + x+    end do+    ! sqr is now equal to x * x+  end function sqr+end program literalnonzero+++! with monomorphism restriction disabled:+!+! tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90:+!   4:11 unit m :: a+!   4:14 unit s :: b+!   12:3 unit 'a :: sqr+!   13:13 unit 'a :: x+!   13:16 unit 'a :: i+!+! with it enabled (normal):+! tests/fixtures/Specification/Units/literal-nonzero-inconsist3.f90: Inconsistent:+!  - at 7:11: 'parameter 1 to sqr' should have unit 's'+!  - at 12:3: 'i' should have the same units as 'parameter 1 to sqr'+!  - at 15:8: 'i' should have unit '1'
+ tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90 view
@@ -0,0 +1,39 @@+program literalnonzero+  != unit m :: a+  != unit s :: b+  real :: a, b+  a = 2+  a = sqr(a)+  b = sqr(b)++contains+  ! without monomorphism restriction I could write a 'squaring'+  ! function that the units inference system wouldn't recognise: 'a -> 'a+  real function sqr(x)+    real :: x, i = 0, j = 1+    sqr = 0+1   if (i < x) then+       sqr = sqr + x+       i = i + j ! not allowed under monomorphism restriction+       goto 1+    end if+    ! sqr is now equal to x * x+  end function sqr+end program literalnonzero+++! with monomorphism restriction disabled:+!+! tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90:+!   4:11 unit m :: a+!   4:14 unit s :: b+!   12:3 unit 'a :: sqr+!   13:13 unit 'a :: x+!   13:16 unit 'a :: i+!   13:23 unit 'a :: j+!+! with it enabled (normal):+! tests/fixtures/Specification/Units/literal-nonzero-inconsist5.f90: Inconsistent:+!  - at 7:11: 'parameter 1 to sqr' should have unit 's'+!  - at 15:9: 'i' should have the same units as 'parameter 1 to sqr'+!  - at 17:12: 'i' should have unit '1'
+ tests/fixtures/Specification/Units/literal-nonzero.f90 view
@@ -0,0 +1,14 @@+program literalnonzero+  real :: a, b+  a = 2+  b = f(a)++contains+  ! unit m s :: f+  real function f(x)+    != unit m s :: x+    real :: x+    x = 1+    f = x+  end function f+end program literalnonzero
+ tests/fixtures/Specification/Units/literal-zero.f90 view
@@ -0,0 +1,15 @@+program literalzero+  != unit m :: a+  real :: a, b+  a = 2+  b = f(a)++contains+  ! unit 'a :: f+  real function f(x)+    != unit 'a :: x+    real :: x+    x = 0+    f = x+  end function f+end program literalzero
+ tests/fixtures/Specification/Units/recursive1.f90 view
@@ -0,0 +1,15 @@+program main+  != unit(m) :: y+  integer :: x = 5, y = 2, z+  z = recur(x,y)+  print *, y+contains+  real recursive function recur(n, b) result(r)+    integer :: n, b+    if (n .EQ. 0) then+       r = b+    else+       r = b + recur(n - 1, b)+    end if+  end function recur+end program main
+ tests/fixtures/Specification/Units/sqrtPoly.f90 view
@@ -0,0 +1,20 @@+program sqrtPoly+  implicit none+  != unit m :: x+  real :: x+  != unit s :: y+  real :: y+  != unit J :: z+  real :: z+  integer :: a+  integer :: b+  integer :: c+  x = sqrt(a)+  y = sqrt(sqrt(b))+  z = sqrt(square(sqrt(c)))+contains+  real function square(n)+    real :: n+    square = n * n+  end function square+end program sqrtPoly
+ tests/fixtures/Specification/Units/squarePoly1.f90 view
@@ -0,0 +1,21 @@+! Demonstrates parametric polymorphism through functions-calling-functions.+program squarePoly+  implicit none+  real :: x+  real :: y+  != unit(m) :: a+  real :: a+  != unit(s) :: b+  real :: b+  x = squareP(a)+  y = squareP(b)+  contains+  real function square(n)+    real :: n+    square = n * n+  end function+  real function squareP(m)+    real :: m+    squareP = square(m)+  end function+end program
+ tests/fixtures/Specification/Units/transfer.f90 view
@@ -0,0 +1,8 @@+program transfer+  implicit none+  != unit m :: x+  real :: x+  != unit s :: y+  real :: y+  x = x + transfer(x, y)+end program transfer