packages feed

camfort 0.902 → 0.903

raw patch · 69 files changed

+4243/−3213 lines, 69 filesdep +optparse-applicativedep ~GenericPrettydep ~QuickCheckdep ~array

Dependencies added: optparse-applicative

Dependency ranges changed: GenericPretty, QuickCheck, array, binary, bytestring, containers, directory, fgl, filepath, fortran-src, ghc-prim, hmatrix, hspec, lattices, matrix, mtl, partial-order, sbv, syb, syz, text, transformers, uniplate, vector

Files

camfort.cabal view
@@ -1,7 +1,9 @@ name:                   camfort-version:                0.902+version:                0.903 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 author:                 Dominic Orchard, Matthew Danish, Mistral Contrastin, Andrew Rice, Oleg Oshmyan@@ -31,16 +33,19 @@   other-modules:        Camfort.Analysis.Annotations                         Camfort.Analysis.CommentAnnotator                         Camfort.Analysis.Simple+                        Camfort.Specification.Parser                         Camfort.Specification.Stencils.Annotation                         Camfort.Specification.Stencils.CheckBackend                         Camfort.Specification.Stencils.CheckFrontend                         Camfort.Specification.Stencils.Consistency                         Camfort.Specification.Stencils.DenotationalSemantics+                        Camfort.Specification.Stencils.Generate                         Camfort.Specification.Stencils.InferenceBackend                         Camfort.Specification.Stencils.InferenceFrontend                         Camfort.Specification.Stencils.Model                         Camfort.Specification.Stencils.Syntax-                        Camfort.Specification.Stencils.Grammar+                        Camfort.Specification.Stencils.Parser+                        Camfort.Specification.Stencils.Parser.Types                         Camfort.Specification.Stencils.Synthesis                         Camfort.Specification.Stencils                         Camfort.Specification.Units@@ -49,10 +54,10 @@                         Camfort.Specification.Units.Environment                         Camfort.Specification.Units.Monad                         Camfort.Specification.Units.Parser+                        Camfort.Specification.Units.Parser.Types                         Camfort.Specification.Units.Synthesis                         Camfort.Transformation.CommonBlockElim                         Camfort.Transformation.DeadCode-                        Camfort.Transformation.DataTypeIntroduction                         Camfort.Transformation.EquivalenceElim                         Camfort.Helpers                         Camfort.Helpers.Syntax@@ -64,29 +69,30 @@                         Main    build-depends:        base >= 4.6 && < 5,-                        ghc-prim >= 0.3.1.0,-                        containers >= 0.5.0.0,-                        uniplate >= 1.6.10,-                        syz >= 0.2,-                        syb >= 0.4,-                        matrix >=0.2.2,-                        vector >= 0.1,-                        hmatrix >= 0.15,-                        mtl >= 2.1,-                        text >= 0.11.2.3,-                        array >= 0.4,-                        directory >= 1.2,-                        transformers >= 0.4,-                        GenericPretty >= 1.2,-                        QuickCheck >= 2.8,-                        fortran-src == 0.1.0.6,-                        filepath,-                        fgl >= 5.5,-                        bytestring >= 0.10,-                        binary >= 0.8.3.0,-                        lattices >= 1.5,-                        sbv >= 5.14,-                        partial-order >= 0.1.2+                        ghc-prim >= 0.3.1.0 && < 0.6,+                        containers >= 0.5.0.0 && < 0.6,+                        uniplate >= 1.6.10 && < 2,+                        syz >= 0.2 && < 0.3,+                        syb >= 0.4 && < 0.7,+                        matrix >= 0.2.2 && < 0.4,+                        vector >= 0.1 && < 0.12,+                        hmatrix >= 0.15 && < 0.19,+                        mtl >= 2.1 && < 3,+                        text >= 0.11.2.3 && < 2,+                        array >= 0.4 && < 0.6,+                        directory >= 1.2 && < 2,+                        transformers >= 0.4 && < 0.6,+                        GenericPretty >= 1.2 && < 2,+                        QuickCheck >= 2.8 && < 3,+                        fortran-src >= 0.2.0.0 && < 0.3,+                        filepath >= 1.4 && < 2,+                        fgl >= 5.5 && < 6,+                        bytestring >= 0.10 && < 0.11,+                        binary >= 0.8.3.0 && < 0.9,+                        lattices >= 1.5 && < 2,+                        sbv >= 7.0 && < 8,+                        partial-order >= 0.1.2,+                        optparse-applicative >= 0.13.2.0 && < 0.14   default-language: Haskell2010  library@@ -95,6 +101,7 @@   exposed-modules:      Camfort.Analysis.Annotations                         Camfort.Analysis.CommentAnnotator                         Camfort.Analysis.Simple+                        Camfort.Specification.Parser                         Camfort.Specification.Stencils.Annotation                         Camfort.Specification.Stencils.CheckBackend                         Camfort.Specification.Stencils.CheckFrontend@@ -104,7 +111,9 @@                         Camfort.Specification.Stencils.InferenceFrontend                         Camfort.Specification.Stencils.Model                         Camfort.Specification.Stencils.Syntax-                        Camfort.Specification.Stencils.Grammar+                        Camfort.Specification.Stencils.Generate+                        Camfort.Specification.Stencils.Parser+                        Camfort.Specification.Stencils.Parser.Types                         Camfort.Specification.Stencils.Synthesis                         Camfort.Specification.Stencils                         Camfort.Specification.Units@@ -113,10 +122,10 @@                         Camfort.Specification.Units.Environment                         Camfort.Specification.Units.Monad                         Camfort.Specification.Units.Parser+                        Camfort.Specification.Units.Parser.Types                         Camfort.Specification.Units.Synthesis                         Camfort.Transformation.CommonBlockElim                         Camfort.Transformation.DeadCode-                        Camfort.Transformation.DataTypeIntroduction                         Camfort.Transformation.EquivalenceElim                         Camfort.Helpers                         Camfort.Helpers.Syntax@@ -127,28 +136,28 @@                         Camfort.Reprint    build-depends:        base >= 4.6 && < 5,-                        ghc-prim >= 0.3.1.0,-                        containers >= 0.5.0.0,-                        uniplate >= 1.6.10,-                        syz >= 0.2,-                        syb >= 0.4,-                        matrix >=0.2.2,-                        hmatrix >= 0.17.0.1,-                        mtl >= 2.1,-                        text >= 0.11.2.3,-                        array >= 0.4,-                        directory >= 1.2,-                        transformers >= 0.4,-                        vector >= 0.1,-                        GenericPretty >= 1.2,-                        fortran-src == 0.1.0.6,-                        filepath,-                        bytestring >= 0.10,-                        fgl >= 5.5,-                        binary >= 0.8.3.0,-                        lattices >= 1.5,-                        sbv >= 5.14,-                        partial-order >= 0.1.2+                        ghc-prim >= 0.3.1.0 && < 0.6,+                        containers >= 0.5.0.0 && < 0.6,+                        uniplate >= 1.6.10 && < 2,+                        syz >= 0.2 && < 0.3,+                        syb >= 0.4 && < 0.7,+                        matrix >= 0.2.2 && < 0.4,+                        hmatrix >= 0.15 && < 0.19,+                        mtl >= 2.1 && < 3,+                        text >= 0.11.2.3 && < 2,+                        array >= 0.4 && < 0.6,+                        directory >= 1.2 && < 2,+                        transformers >= 0.4 && < 0.6,+                        vector >= 0.1 && < 0.12,+                        GenericPretty >= 1.2 && < 2,+                        fortran-src >= 0.2.0.0 && < 0.3,+                        filepath >= 1.4 && < 2,+                        bytestring >= 0.10 && < 0.11,+                        fgl >= 5.5 && < 6,+                        binary >= 0.8.3.0 && < 0.9,+                        lattices >= 1.5 && < 2,+                        sbv >= 7.0 && < 8,+                        partial-order >= 0.1.2 && < 0.2   default-language: Haskell2010  test-suite spec@@ -156,32 +165,36 @@   main-is:              Spec.hs   hs-source-dirs:       tests   other-modules:        Camfort.Analysis.CommentAnnotatorSpec+                        Camfort.Specification.ParserSpec                         Camfort.Specification.Stencils.CheckSpec                         Camfort.Specification.Stencils.ConsistencySpec                         Camfort.Specification.Stencils.DenotationalSemanticsSpec-                        Camfort.Specification.Stencils.GrammarSpec+                        Camfort.Specification.Stencils.ParserSpec                         Camfort.Specification.Stencils.InferenceBackendSpec                         Camfort.Specification.Stencils.ModelSpec                         Camfort.Specification.StencilsSpec+                        Camfort.Specification.Units.InferenceBackendSpec+                        Camfort.Specification.Units.InferenceFrontendSpec+                        Camfort.Specification.Units.ParserSpec                         Camfort.Specification.UnitsSpec                         Camfort.Transformation.CommonSpec                         Camfort.Transformation.EquivalenceElimSpec   build-depends:        base >= 4.6 && < 5,-                        containers >= 0.5,-                        filepath >= 1.4,-                        directory >= 1.2,-                        hspec >= 2.2,-                        QuickCheck >= 2.8,-                        fortran-src == 0.1.0.6,-                        uniplate >= 1.6.10,-                        mtl >= 2.1,-                        bytestring >= 0.10,-                        array >= 0.4,-                        hmatrix >= 0.15,-                        text >= 0.11.2.3,-                        binary >= 0.8.3.0,-                        lattices >= 1.5,-                        sbv >= 5.14,-                        partial-order >= 0.1.2,+                        containers >= 0.5.0.0 && < 0.6,+                        filepath >= 1.4 && < 2,+                        directory >= 1.2 && < 2,+                        hspec >= 2.2 && < 3,+                        QuickCheck >= 2.8 && < 3,+                        fortran-src >= 0.2.0.0 && < 0.3,+                        uniplate >= 1.6.10 && < 2,+                        mtl >= 2.1 && < 3,+                        bytestring >= 0.10 && < 0.11,+                        array >= 0.4 && < 0.6,+                        hmatrix >= 0.15 && < 0.19,+                        text >= 0.11.2.3 && < 2,+                        binary >= 0.8.3.0 && < 0.9,+                        lattices >= 1.5 && < 2,+                        sbv >= 7.0 && < 8,+                        partial-order >= 0.1.2 && < 0.2,                         camfort   default-language: Haskell2010
src/Camfort/Analysis/Annotations.hs view
@@ -18,23 +18,41 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -module Camfort.Analysis.Annotations where+module Camfort.Analysis.Annotations+  (+  -- * 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.Generics.Uniplate.Operations import Data.Maybe (isJust) -import Data.Map.Lazy hiding (map)-import Debug.Trace- import Camfort.Specification.Units.Environment-import qualified Camfort.Specification.Units.Parser as P+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.Grammar as StencilComment+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@@ -50,14 +68,50 @@     , deleteNode    :: Bool     -- Stencil specification annotations     -- TODO: move these into their own annotation-    , stencilSpec    :: Maybe-    -- If defined, either an unprocessed syntax tree-         (Either StencilComment.Specification-           -- Or a parser AST of a RegionEnv or SpecDecls-           (Either StencilSpec.RegionEnv StencilSpec.SpecDecls))+    , 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@@ -96,5 +150,8 @@ onPrev :: (a -> a) -> FA.Analysis a -> FA.Analysis a onPrev f ann = ann { FA.prevAnnotation = f (FA.prevAnnotation ann) } -modifyAnnotation :: F.Annotated f => (a -> a) -> f a -> f a-modifyAnnotation f x = F.setAnnotation (f (F.getAnnotation x)) x+-- | Build a Fortran comment string appropriate for the Fortran version.+buildCommentText :: F.MetaInfo -> Int -> String -> String+buildCommentText mi col text | isModernFortran = replicate col ' ' ++ "!" ++ text+                             | otherwise       = "c" ++ text+  where isModernFortran = F.miVersion mi >= Fortran90
src/Camfort/Analysis/CommentAnnotator.hs view
@@ -16,112 +16,109 @@  {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternGuards #-} -module Camfort.Analysis.CommentAnnotator ( annotateComments-                                         , Logger-                                         , ASTEmbeddable(..)-                                         , Linkable(..)-                                         , AnnotationParseError(..)-                                         , AnnotationParser-                                         , failWith-                                         ) where+module Camfort.Analysis.CommentAnnotator+  ( annotateComments+  , isComment+  , ASTEmbeddable(..)+  , Linkable(..)+  ) where -import Control.Monad.Writer.Strict (Writer(..), tell)-import Data.Generics.Uniplate.Operations+ import Data.Data (Data)-import Debug.Trace+import Data.Generics.Uniplate.Operations  import Language.Fortran.AST import Language.Fortran.Util.Position -type Logger = Writer [ String ]-type AnnotationParser ast = String -> Either AnnotationParseError ast--data AnnotationParseError =-    NotAnnotation-  | ProbablyAnnotation String-  deriving (Eq, Show)---- A parser that throws an annotation parsing error-failWith :: AnnotationParser ast-failWith = Left . ProbablyAnnotation+import Camfort.Specification.Parser ( looksLikeASpec+                                    , runParser+                                    , SpecParseError+                                    , SpecParser) -annotateComments :: forall a ast . (Data a, Linkable a, ASTEmbeddable a ast)-                                 => AnnotationParser ast-                                 -> ProgramFile a-                                 -> Logger (ProgramFile a)-annotateComments parse pf = do-    pf' <- transformBiM (writeASTProgramUnits parse) =<< transformBiM (writeASTBlocks parse) pf+annotateComments :: forall m e a ast .+  (Monad m, Data a, Linkable a, ASTEmbeddable a ast)+  => SpecParser e ast+  -> (SrcSpan -> SpecParseError e -> m ())+  -> ProgramFile a+  -> m (ProgramFile a)+annotateComments parser handleErr pf = do+    pf' <- transformBiM writeASTProgramUnits =<< transformBiM writeASTBlocks pf     return . descendBi linkProgramUnits $ descendBi linkBlocks pf'   where-    writeASTBlocks :: (Data a, ASTEmbeddable a ast) => AnnotationParser ast -> Block a -> Logger (Block a)-    writeASTBlocks parse b@(BlComment a srcSpan (Comment comment)) =-      case parse comment of-        Right ast -> return $ setAnnotation (annotateWithAST a ast) b-        Left NotAnnotation -> return b-        Left (ProbablyAnnotation err) -> parserWarn srcSpan err >> return b-    writeASTBlocks _ b = return b+    writeAST a d srcSpan comment =+      if looksLikeASpec parser comment+      then case runParser parser comment of+             Left  err -> handleErr srcSpan err >> pure d+             Right ast -> pure $ setAnnotation (annotateWithAST a ast) d+      else pure d -    writeASTProgramUnits :: (Data a, ASTEmbeddable a ast) => AnnotationParser ast -> ProgramUnit a -> Logger (ProgramUnit a)-    writeASTProgramUnits parse pu@(PUComment a srcSpan (Comment comment)) =-      case parse comment of-        Right ast -> return $ setAnnotation (annotateWithAST a ast) pu-        Left NotAnnotation -> return pu-        Left (ProbablyAnnotation err) -> parserWarn srcSpan err >> return pu-    writeASTProgramUnits _ pu = return pu+    writeASTProgramUnits :: ProgramUnit a -> m (ProgramUnit a)+    writeASTProgramUnits pu@(PUComment a srcSpan (Comment comment)) =+      writeAST a pu srcSpan comment+    writeASTProgramUnits pu = pure pu +    writeASTBlocks :: Block a -> m (Block a)+    writeASTBlocks b@(BlComment a srcSpan (Comment comment)) =+      writeAST a b srcSpan comment+    writeASTBlocks b = pure b++    -- | Link all comments to first non-comment in the list.+    joinComments [ ] = [ ]+    joinComments dss@(d:ds)+      | isComment d =+        let (comments, rest) = span isComment dss+            -- Given a list of comments and a list of non-comment blocks which occur+            -- afterward in the code, then link them together (either forward or backward)+            -- returning a pair of processed blocks and unprocessed blocks++            -- pre-condition: first parameter is a list of comments++            -- default uses 'link' to associate every comment to the first following block+            linkMulti = (map (fmap $ flip linker (head rest)) comments, rest)+        in if null rest -- Does the group end with comments+             then comments+             else let (procs, unprocs) = linkMulti+                  in procs ++ joinComments unprocs+      | otherwise = descendBi joinComments d+                    : joinComments ds+     {-| Link all comment blocks to first non-comment block in the list. |-}     linkBlocks :: (Data a, Linkable a) => [ Block a ] -> [ Block a ]-    linkBlocks [ ] = [ ]-    linkBlocks blocks@(b:bs)-      | BlComment{} <- b =-        let (comments, rest) = span isComment blocks-        in if null rest -- Does the group of blocks end with comments-             then comments-             else let (bs, bs') = linkMultiple comments rest-                  in bs ++ linkBlocks bs'-      | otherwise = (descendBi linkBlocks b) : linkBlocks bs-      where-        isComment BlComment{} = True-        isComment _           = False+    linkBlocks = joinComments      {-| Link all comment 'program units' to first non-comment program unit in the list. |-}     linkProgramUnits :: (Data a, Linkable a) => [ ProgramUnit a ] -> [ ProgramUnit a ]-    linkProgramUnits [ ] = [ ]-    linkProgramUnits programUnits@(pu:pus)-      | PUComment{} <- pu =-        let (comments, rest) = span isComment programUnits-        in if null rest -- Does the group of blocks end with comments-             then comments-             else let (procPUs, unprocPUs) = linkMultiplePUs comments rest-                  in procPUs ++ linkProgramUnits unprocPUs-      | otherwise = (descendBi linkProgramUnits pu) : linkProgramUnits pus-      where-        isComment PUComment{} = True-        isComment _           = False+    linkProgramUnits = joinComments  class ASTEmbeddable a ast where   annotateWithAST :: a -> ast -> a +-- | Instances of this class can be combined with 'Block' and 'ProgramUnit'. class Linkable a where+  -- ^ Combine an @a@ with a 'Block'   link   :: a   -> Block a -> a+  -- ^ Combine an @a@ with a 'ProgramUnit'   linkPU :: a -> ProgramUnit a -> a -  -- Given a list of comments and a list of non-comment blocks which occur-  -- afterward in the code, then link them together (either forward or backward)-  -- returning a pair of processed blocks and unprocessed blocks+-- | Interface for types that can be combined with 'Linkable' types.+class Linked a where+  linker :: (Linkable b) => b -> a b -> b -  -- pre-condition: first parameter is a list of comments+instance Linked Block where+  linker = link -  -- default uses 'link' to associate every comment to the first following block-  linkMultiple :: [Block a] -> [Block a] -> ([Block a], [Block a])-  linkMultiple comments blocks =-     (map (fmap $ flip link (head blocks)) comments, blocks)+instance Linked ProgramUnit where+  linker = linkPU -  linkMultiplePUs :: [ProgramUnit a] -> [ProgramUnit a] -> ([ProgramUnit a], [ProgramUnit a])-  linkMultiplePUs comments pus = -- trace (show (map (fmap (const ())) comments, (map (fmap (const ())) pus))) $-     (map (fmap $ flip linkPU (head pus)) comments, pus)+-- | Interface for types that can have comments.+class HasComment a where+  isComment :: a -> Bool -parserWarn :: SrcSpan -> String -> Logger ()-parserWarn srcSpan err = tell [ "Error " ++ show srcSpan ++ ": " ++ err ]+instance HasComment (Block a) where+  isComment BlComment{} = True+  isComment _           = False++instance HasComment (ProgramUnit a) where+  isComment PUComment{} = True+  isComment _           = False
src/Camfort/Analysis/Simple.hs view
@@ -30,6 +30,6 @@ {-| Counts the number of declarations (of variables) in a whole program -}  countVariableDeclarations ::-    forall a . Data a => Filename -> F.ProgramFile a -> (Int, F.ProgramFile a)-countVariableDeclarations _ x =-    (sum [1 | x <- universeBi x :: [F.Declarator a]], x)+    forall a . Data a => F.ProgramFile a -> (Int, F.ProgramFile a)+countVariableDeclarations x =+    (sum [1 | _ <- universeBi x :: [F.Declarator a]], x)
src/Camfort/Functionality.hs view
@@ -21,19 +21,34 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-} -module Camfort.Functionality where+module Camfort.Functionality (+  -- * Datatypes+    AnnotationType(..)+  -- * Commands+  , ast+  , countVarDecls+  -- ** Stencil Analysis+  , stencilsCheck+  , stencilsInfer+  , stencilsSynth+  -- ** Unit Analysis+  , unitsCriticals+  , unitsCheck+  , unitsInfer+  , unitsSynth+  , unitsCompile+  -- ** Refactorings+  , common+  , dead+  , equivalences+  ) where -import System.FilePath import Control.Monad--import Data.Generics.Uniplate.Operations-import Data.Data-import Data.Binary-import Data.Text (pack, unpack, split)+import System.FilePath (takeDirectory)  import Camfort.Analysis.Simple-import Camfort.Transformation.DataTypeIntroduction import Camfort.Transformation.DeadCode import Camfort.Transformation.CommonBlockElim import Camfort.Transformation.EquivalenceElim@@ -44,165 +59,104 @@ import Camfort.Helpers import Camfort.Input -import qualified Language.Fortran.Parser.Any as FP import Language.Fortran.Util.ModFile import qualified Camfort.Specification.Stencils as Stencils import qualified Data.Map.Strict as M --- CamFort optional flags-data Flag = Version-         | Input String-         | Output String-         | Excludes String-         | IncludeDir String-         | Literals LiteralsOpt-         | StencilInferMode Stencils.InferMode-         | Doxygen-         | Ford-         | FVersion String-         | RefactorInPlace-         | Debug deriving (Data, Show, Eq) -type Options = [Flag]+data AnnotationType = ATDefault | Doxygen | Ford --- Extract excluces information from options-instance Default String where-    defaultValue = ""-getExcludes :: Options -> String-getExcludes opts = head ([ e | Excludes e <- universeBi opts ] ++ [""]) --- Separates the comma-separated filenames-getExcludedFiles :: Options -> [String]-getExcludedFiles = map unpack . split (==',') . pack . getExcludes+-- | Retrieve the marker character compatible with the given+-- type of annotation.+markerChar :: AnnotationType -> Char+markerChar Doxygen   = '<'+markerChar Ford      = '!'+markerChar ATDefault = '=' + -- * Wrappers on all of the features-ast d excludes _ _ = do+ast d excludes = do     xs <- readParseSrcDir d excludes-    print (map (\(_, _, p) -> p) xs)+    print . fmap fst $ xs -countVarDecls inSrc excludes _ _ = do+countVarDecls inSrc excludes = do     putStrLn $ "Counting variable declarations in '" ++ inSrc ++ "'"-    doAnalysisSummary countVariableDeclarations inSrc excludes Nothing+    doAnalysisSummary countVariableDeclarations inSrc excludes -dead inSrc excludes outSrc _ = do+dead inSrc excludes outSrc = do     putStrLn $ "Eliminating dead code in '" ++ inSrc ++ "'"     report <- doRefactor (mapM (deadCode False)) inSrc excludes outSrc     putStrLn report -common inSrc excludes outSrc _ = do+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 -equivalences inSrc excludes outSrc _ = do+equivalences inSrc excludes outSrc = do     putStrLn $ "Refactoring equivalences blocks in '" ++ inSrc ++ "'"     report <- doRefactor (mapM refactorEquivalences) inSrc excludes outSrc     putStrLn report -datatypes inSrc excludes outSrc _ = do-    putStrLn $ "Introducing derived data types in '" ++ inSrc ++ "'"-    report <- doRefactor dataTypeIntro inSrc excludes outSrc-    putStrLn report- {- Units feature -}-optsToUnitOpts :: [Flag] -> IO UnitOpts-optsToUnitOpts = foldM (\ o f -> do-  case f of-    Literals m   -> return $ o { uoLiterals    = m }-    Debug        -> return $ o { uoDebug       = True }-    IncludeDir d -> do-      -- Figure out the camfort mod files and parse them.-      modFileNames <- filter isModFile `fmap` rGetDirContents' d-      assocList <- forM modFileNames $ \ modFileName -> do-        eResult <- decodeFileOrFail (d ++ "/" ++ modFileName) -- FIXME, directory manipulation-        case eResult of-          Left (offset, msg) -> do-            putStrLn $ modFileName ++ ": Error at offset " ++ show offset ++ ": " ++ msg-            return (modFileName, emptyModFile)-          Right modFile -> do-            putStrLn $ modFileName ++ ": successfully parsed precompiled file."-            return (modFileName, modFile)-      return $ o { uoModFiles = M.fromList assocList `M.union` uoModFiles o }-    _            -> return o-    ) unitOpts0--getModFiles :: [Flag] -> IO ModFiles-getModFiles = foldM (\ modFiles f -> do-  case f of-    IncludeDir d -> do-      -- Figure out the camfort mod files and parse them.-      modFileNames <- filter isModFile `fmap` rGetDirContents' d-      addedModFiles <- forM modFileNames $ \ modFileName -> do-        eResult <- decodeFileOrFail (d ++ "/" ++ modFileName) -- FIXME, directory manipulation-        case eResult of-          Left (offset, msg) -> do-            putStrLn $ modFileName ++ ": Error at offset " ++ show offset ++ ": " ++ msg-            return emptyModFile-          Right modFile -> do-            putStrLn $ modFileName ++ ": successfully parsed precompiled file."-            return modFile-      return $ addedModFiles ++ modFiles-    _            -> return modFiles-    ) emptyModFiles--isModFile = (== modFileSuffix) . fileExt+optsToUnitOpts :: LiteralsOpt -> Bool -> Maybe String -> IO UnitOpts+optsToUnitOpts m debug = maybe (pure o1)+  (fmap (\modFiles -> o1 { uoModFiles = M.fromList modFiles }) . getModFilesWithNames)+  where o1 = unitOpts0 { uoLiterals = m+                       , uoDebug = debug+                       , uoModFiles = M.empty } -unitsCheck inSrc excludes _ opt = do+unitsCheck inSrc excludes m debug incDir = do     putStrLn $ "Checking units for '" ++ inSrc ++ "'"-    uo <- optsToUnitOpts opt+    uo <- optsToUnitOpts m debug incDir     let rfun = concatMap (LU.checkUnits uo)-    doAnalysisReportWithModFiles rfun putStrLn inSrc excludes =<< getModFiles opt+    doAnalysisReportWithModFiles rfun putStrLn inSrc incDir excludes -unitsInfer inSrc excludes _ opt = do+unitsInfer inSrc excludes m debug incDir = do     putStrLn $ "Inferring units for '" ++ inSrc ++ "'"-    uo <- optsToUnitOpts opt+    uo <- optsToUnitOpts m debug incDir     let rfun = concatMap (LU.inferUnits uo)-    doAnalysisReportWithModFiles rfun putStrLn inSrc excludes =<< getModFiles opt+    doAnalysisReportWithModFiles rfun putStrLn inSrc incDir excludes -unitsCompile inSrc excludes outSrc opt = do+unitsCompile inSrc excludes m debug incDir outSrc = do     putStrLn $ "Compiling units for '" ++ inSrc ++ "'"-    uo <- optsToUnitOpts opt+    uo <- optsToUnitOpts m debug incDir     let rfun = LU.compileUnits uo-    putStrLn =<< doCreateBinary rfun inSrc excludes outSrc =<< getModFiles opt+    putStrLn =<< doCreateBinary rfun inSrc incDir excludes outSrc -unitsSynth inSrc excludes outSrc opt = do++unitsSynth inSrc excludes m debug incDir outSrc annType = do     putStrLn $ "Synthesising units for '" ++ inSrc ++ "'"-    let marker-         | Doxygen `elem` opt = '<'-         | Ford `elem` opt = '!'-         | otherwise = '='-    uo <- optsToUnitOpts opt+    let marker = markerChar annType+    uo <- optsToUnitOpts m debug incDir     let rfun =           mapM (LU.synthesiseUnits uo marker)-    report <- doRefactorWithModFiles rfun inSrc excludes outSrc =<< getModFiles opt+    report <- doRefactorWithModFiles rfun inSrc incDir excludes outSrc     putStrLn report -unitsCriticals inSrc excludes _ opt = do+unitsCriticals inSrc excludes m debug incDir = do     putStrLn $ "Suggesting variables to annotate with unit specifications in '"              ++ inSrc ++ "'"-    uo <- optsToUnitOpts opt+    uo <- optsToUnitOpts m debug incDir     let rfun = mapM (LU.inferCriticalVariables uo)-    doAnalysisReportWithModFiles rfun (putStrLn . fst) inSrc excludes =<< getModFiles opt+    doAnalysisReportWithModFiles rfun (putStrLn . fst) inSrc incDir excludes  {- Stencils feature -}-stencilsCheck inSrc excludes _ _ = do+stencilsCheck inSrc excludes = do    putStrLn $ "Checking stencil specs for '" ++ inSrc ++ "'"-   let rfun = \f p -> (Stencils.check f p, p)-   doAnalysisSummary rfun inSrc excludes Nothing+   let rfun p = (Stencils.check p, p)+   doAnalysisSummary rfun inSrc excludes -stencilsInfer inSrc excludes outSrc opt = do-   putStrLn $ "Infering stencil specs for '" ++ inSrc ++ "'"-   let rfun = Stencils.infer (getOption opt) '='-   doAnalysisSummary rfun inSrc excludes (Just outSrc)+stencilsInfer inSrc excludes inferMode = do+   putStrLn $ "Inferring stencil specs for '" ++ inSrc ++ "'"+   let rfun = Stencils.infer inferMode '='+   doAnalysisSummary rfun inSrc excludes -stencilsSynth inSrc excludes outSrc opt = do+stencilsSynth inSrc excludes inferMode annType outSrc = do    putStrLn $ "Synthesising stencil specs for '" ++ inSrc ++ "'"-   let marker-        | Doxygen `elem` opt = '<'-        | Ford `elem` opt = '!'-        | otherwise = '='-   let rfun = Stencils.synth (getOption opt) marker+   let rfun = Stencils.synth inferMode (markerChar annType)    report <- doRefactor rfun inSrc excludes outSrc    putStrLn report
src/Camfort/Helpers.hs view
@@ -17,23 +17,31 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} -module Camfort.Helpers where+module Camfort.Helpers+  (+    -- * Datatypes and Aliases+    Directory+  , FileOrDir+  , Filename+  , SourceText+    -- * Directory Helpers+  , checkDir+  , getDir+  , isDirectory+    -- * Misc Helpers+  , collect+  , descendBiReverseM+  , descendReverseM+  ) where -import GHC.Generics-import Data.Generics.Zipper-import Data.Generics.Aliases import Data.Generics.Uniplate.Operations import qualified Data.Generics.Str as Str import Data.Data-import Data.Maybe-import Data.Monoid-import Data.List (elemIndices, group, sort, nub)+import Data.List (elemIndices, union) import qualified Data.ByteString.Char8 as B import System.Directory-import Data.List (union) import qualified Data.Map.Lazy as Map hiding (map, (\\)) import Control.Monad.Writer.Strict @@ -64,83 +72,6 @@ isDirectory :: FileOrDir -> IO Bool isDirectory s = doesDirectoryExist s --- Helpers-fanout :: (a -> b) -> (a -> c) -> a -> (b, c)-fanout f g x = (f x, g x)--(<>) :: (a -> b) -> (a -> c) -> a -> (b, c)-f <> g = fanout f g--(><) :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)-f >< g = \(x, y) -> (f x, g y)---- Lookup functions over relation s--lookups :: Eq a => a -> [(a, b)] -> [b]-lookups _ [] = []-lookups x ((a, b):xs) = if (x == a) then b : lookups x xs-                                    else lookups x xs--lookups' :: Eq a => a -> [((a, b), c)] -> [(b, c)]-lookups' _ [] = []-lookups' x (((a, b), c):xs) = if (x == a) then (b, c) : lookups' x xs-                                          else lookups' x xs--{-| Computes all pairwise combinations -}-pairs :: [a] -> [(a, a)]-pairs []     = []-pairs (x:xs) = (zip (repeat x) xs) ++ (pairs xs)--{-| Functor composed with list functor -}-mfmap :: Functor f => (a -> b) -> [f a] -> [f b]-mfmap f = map (fmap f)--{-| An infix `map` operation.-}-each = flip (map)--{-| Is the Ordering an EQ? -}-cmpEq :: Ordering -> Bool-cmpEq EQ = True-cmpEq _  = False--cmpFst :: (a -> a -> Ordering) -> (a, b) -> (a, b) -> Ordering-cmpFst c (x1, y1) (x2, y2) = c x1 x2--cmpSnd :: (b -> b -> Ordering) -> (a, b) -> (a, b) -> Ordering-cmpSnd c (x1, y1) (x2, y2) = c y1 y2--{-| used for type-level annotations giving documentation -}-type (:?) a (b :: k) = a---- Helper function, reduces a list two elements at a time with a partial operation-foldPair :: (a -> a -> Maybe a) -> [a] -> [a]-foldPair f [] = []-foldPair f [a] = [a]-foldPair f (a:(b:xs)) = case f a b of-                          Nothing -> a : (foldPair f (b : xs))-                          Just c  -> foldPair f (c : xs)---class PartialMonoid x where-  -- Satisfies equations:-   --   pmappend x pmempty = Just x-   --   pmappend pempty x  = Just x-   --   (pmappend y z) >>= (\w -> pmappend x w) = (pmappend x y) >>= (\w -> pmappend w z)--   emptyM  :: x-   appendM :: x -> x -> Maybe x--normalise :: (Ord t, PartialMonoid t) => [t] -> [t]-normalise = nub . reduce . sort-  where reduce = foldPair appendM--normaliseNoSort :: (Ord t, PartialMonoid t) => [t] -> [t]-normaliseNoSort = nub . reduce-  where reduce = foldPair appendM--normaliseBy :: Ord t => (t -> t -> Maybe t) -> [t] -> [t]-normaliseBy plus = nub . (foldPair plus) . sort- #if __GLASGOW_HASKELL__ < 800 instance Monoid x => Monad ((,) x) where     return a = (mempty, a)@@ -148,39 +79,6 @@                    in (mappend x x', b) #endif --- Data-type generic reduce traversal-reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a]-reduceCollect k x = execWriter (transformBiM (\y -> do case k y of-                                                         Just x -> tell [x]-                                                         Nothing -> return ()-                                                       return y) x)---- Data-type generic comonad-style traversal with zipper (contextual traversal)-everywhere :: (Zipper a -> Zipper a) -> Zipper a -> Zipper a-everywhere k z = everywhere' z-  where-    everywhere' = enterRight . enterDown . k--    enterDown z =-        case (down' z) of-          Just dz -> let dz' = everywhere' dz-                     in case (up $ dz') of-                          Just uz -> uz-                          Nothing -> dz'-          Nothing -> z--    enterRight z =-         case (right z) of-           Just rz -> let rz' = everywhere' rz-                      in case (left $ rz') of-                           Just lz -> lz-                           Nothing -> rz'-           Nothing -> z---zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a)-zfmap f x = zeverywhere (mkT f) x- -- Data-generic generic descend but processes children in reverse order -- (good for backwards analysis) data Reverse f a = Reverse { unwrapReverse :: f a }@@ -192,7 +90,7 @@     foldMap f (Reverse x) = foldMap f x  instance Traversable (Reverse Str.Str) where-    traverse f (Reverse Str.Zero) = pure $ Reverse Str.Zero+    traverse _ (Reverse Str.Zero) = pure $ Reverse Str.Zero     traverse f (Reverse (Str.One x)) = (Reverse . Str.One) <$> f x     traverse f (Reverse (Str.Two x y)) = (\y x -> Reverse $ Str.Two x y)                              <$> (fmap unwrapReverse . traverse f . Reverse $ y)
src/Camfort/Helpers/Syntax.hs view
@@ -25,29 +25,32 @@ syntax that are useful between different analyses and transformations.  -}-module Camfort.Helpers.Syntax where+module Camfort.Helpers.Syntax+  (+  -- * Variable renaming helpers+    caml+  -- * Comparison and ordering+  , AnnotationFree(..)+  , af+  -- * Accessor functions for extracting various pieces of information+  --   out of syntax trees+  , extractVariable+  -- * SrcSpan Helpers+  , afterAligned+  , deleteLine+  , dropLine+  , linesCovered+  , toCol0+  ) where  -- Standard imports import Data.Char-import Data.List-import Data.Monoid-import Control.Monad.State.Lazy-import Debug.Trace  -- Data-type generics imports-import Data.Data import Data.Generics.Uniplate.Data-import Data.Generics.Uniplate.Operations-import Data.Generics.Zipper-import Data.Typeable --- CamFort specific functionality-import Camfort.Analysis.Annotations- import qualified Language.Fortran.AST as F import qualified Language.Fortran.Util.Position as FU-import Language.Fortran.Util.FirstParameter-import Language.Fortran.Util.SecondParameter  -- * Comparison and ordering @@ -58,12 +61,9 @@  {-| short-hand constructor for 'AnnotationFree' -} af = AnnotationFree-{-| short-hand deconstructor for 'AnnotationFree' -}-unaf = annotationBound  -- variable renaming helpers caml (x:xs) = toUpper x : xs-lower = map toLower  -- Here begins varioous 'Eq' instances for instantiations of 'AnnotationFree' @@ -110,18 +110,18 @@ -- SrcSpan helpers  dropLine :: FU.SrcSpan -> FU.SrcSpan-dropLine (FU.SrcSpan s1 (FU.Position o c l)) =-    FU.SrcSpan s1 (FU.Position o 0 (l+1))+dropLine (FU.SrcSpan s1 (FU.Position o _ l)) =+    FU.SrcSpan s1 (FU.Position o 1 (l+1))  deleteLine :: FU.SrcSpan -> FU.SrcSpan-deleteLine (FU.SrcSpan (FU.Position ol cl ll) (FU.Position ou cu lu)) =-    FU.SrcSpan (FU.Position ol (cl-1) ll) (FU.Position ou 0 (lu+1))+deleteLine (FU.SrcSpan (FU.Position ol cl ll) (FU.Position ou _ lu)) =+    FU.SrcSpan (FU.Position ol (cl-1) ll) (FU.Position ou 1 (lu+1))  linesCovered :: FU.Position -> FU.Position -> Int linesCovered (FU.Position _ _ l1) (FU.Position _ _ l2) = l2 - l1 + 1 -toCol0 (FU.Position o c l) = FU.Position o 0 l+toCol0 (FU.Position o _ l) = FU.Position o 1 l  afterAligned :: FU.SrcSpan -> FU.Position-afterAligned (FU.SrcSpan (FU.Position o cA lA) (FU.Position _ cB lB)) =+afterAligned (FU.SrcSpan (FU.Position o cA _) (FU.Position _ _ lB)) =     FU.Position o cA (lB+1)
src/Camfort/Helpers/Vec.hs view
@@ -25,9 +25,32 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -module Camfort.Helpers.Vec where+module Camfort.Helpers.Vec+  (+    -- * Datatypes+    EqT(..)+  , ExistsEqT(..)+  , Nat(..)+  , Natural(..)+  , Vec(..)+  , VecBox(..)+  , VecList(..)+  -- ** Vector Operations+  , (!!)+  , findIndex+  , fromList+  , fromLists+  , length+  , lengthN+  , proveEqSize+  , proveNonEmpty+  , replace+  , toList+  , zip+  , zipWith+  ) where -import Prelude hiding (length, zipWith, take, drop, (!!))+import Prelude hiding (length, zip, zipWith, take, drop, (!!))  import Data.Proxy @@ -45,13 +68,6 @@ data NatBox where NatBox :: Natural n -> NatBox deriving instance Show NatBox --- Conversions to and from the type-representation--- of natural numbers-toNatBox :: Int -> NatBox-toNatBox 0 = NatBox Zero-toNatBox n = case toNatBox (n-1) of-              (NatBox n) -> NatBox (Succ n)- class IsNatural (n :: Nat) where    fromNat :: Proxy n -> Int @@ -67,14 +83,14 @@  length :: Vec n a -> Int length Nil = 0-length (Cons x xs) = 1 + length xs+length (Cons _ xs) = 1 + length xs  lengthN :: Vec n a -> Natural n lengthN Nil = Zero-lengthN (Cons x xs) = Succ $ lengthN xs+lengthN (Cons _ xs) = Succ $ lengthN xs  instance Functor (Vec n) where-  fmap f Nil         = Nil+  fmap _ Nil         = Nil   fmap f (Cons x xs) = Cons (f x) (fmap f xs)  deriving instance Eq a => Eq (Vec n a)@@ -96,7 +112,7 @@   foldr f acc (Cons x xs) = foldr f (f x acc) xs  zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c-zipWith f Nil Nil = Nil+zipWith _ Nil Nil = Nil zipWith f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith f xs ys)  zip :: Vec n a -> Vec n b -> Vec n (a,b)@@ -112,11 +128,11 @@       | otherwise = go (acc + 1) p xs  (!!) :: Vec n a -> Int -> a-Cons x v' !! 0 = x+Cons x _  !! 0 = x Cons _ v' !! n = v' !! (n - 1)  replace :: Int -> a -> Vec n a -> Vec n a-replace 0 a (Cons x xs) = Cons a xs+replace 0 a (Cons _ xs) = Cons a xs replace n a (Cons x xs) = Cons x (replace (n-1) a xs) replace _ _ Nil = error "Found asymmetry is beyond the limits." @@ -138,15 +154,6 @@ toList Nil = [ ] toList (Cons x xs) = x : toList xs --- | Apply length preserving list operation.-applyListOp :: ([ a ] -> [ a ]) -> Vec n a -> Vec n a-applyListOp f v =-  case fromList . f . toList $ v of-    VecBox v' ->-      case proveEqSize v v' of-        Just ReflEq -> v'-        Nothing -> error "List operation was not length preserving."- proveEqSize :: Vec n a -> Vec m b -> Maybe (EqT m n) proveEqSize Nil Nil = return ReflEq proveEqSize (Cons _ xs) (Cons _ ys) = do@@ -158,14 +165,7 @@ proveNonEmpty v =   case v of     Nil -> Nothing-    (Cons x xs) -> Just $ ExistsEqT ReflEq--hasSize :: Vec m a -> Natural n -> Maybe (EqT m n)-hasSize Nil Zero = return ReflEq-hasSize (Cons _ xs) (Succ n) = do-  ReflEq <- xs `hasSize` n-  return ReflEq-hasSize _ _ = Nothing+    (Cons _ _) -> Just $ ExistsEqT ReflEq  {- Vector list repreentation where the size 'n' is existential quantified -} data VecList a where VL :: [Vec n a] -> VecList a@@ -184,4 +184,4 @@           where -- At the moment the pre-condition is 'assumed', and therefore             -- force used unsafeCoerce: TODO, rewrite             preCondition :: forall n n1 a . Vec n a -> [Vec n1 a] -> EqT n n1-            preCondition xs x = unsafeCoerce ReflEq+            preCondition _ _ = unsafeCoerce ReflEq
src/Camfort/Input.hs view
@@ -1,312 +1,248 @@-{--   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+{- |+Module      :  Camfort.Input+Description :  Handles input of code base and passing the files on to core functionality.+Copyright   :  Copyright 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-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.+Maintainer  :  dom.orchard@gmail.com -} -{-2--Handles input of code base (files and directories)- and passing them into the core functionality+{-# LANGUAGE DoAndIfThenElse #-} --}+module Camfort.Input+  (+    -- * Classes+    Default(..)+    -- * Datatypes and Aliases+  , FileProgram+    -- * Builders for analysers and refactorings+  , callAndSummarise+  , doAnalysisReportWithModFiles+  , doAnalysisSummary+  , doRefactor+  , doRefactorAndCreate+  , doRefactorWithModFiles+    -- * Source directory and file handling+  , doCreateBinary+  , readParseSrcDir+  , getModFilesWithNames+  ) where -{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE ScopedTypeVariables #-}+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) -module Camfort.Input where+import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Parser.Any as FP+import           Language.Fortran.Util.ModFile  import Camfort.Analysis.Annotations import Camfort.Helpers import Camfort.Output -import qualified Language.Fortran.Parser.Any as FP-import qualified Language.Fortran.AST as F-import Language.Fortran.Util.ModFile--import qualified Data.ByteString.Char8 as B-import Data.Data-import Data.Char (toUpper)-import Data.Maybe-import Data.Generics.Uniplate.Operations-import Data.List (foldl', nub, (\\), elemIndices, intercalate)-import Data.Monoid-import Data.Text.Encoding.Error (replace)-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)--import System.Directory---- Class for default values of some type 't'+-- | Class for default values of some type 't' class Default t where     defaultValue :: t --- From a '[t]' extract the first occurence of an 'opt' value.--- If one does not exist, return the default 'opt'-getOption :: forall t opt . (Data opt, Data t, Default opt) => [t] -> opt-getOption [] = defaultValue-getOption (x : xs) =-    case universeBi x :: [opt] of-      []        -> getOption xs-      (opt : _) -> opt+-- | 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, "/"]  -- * Builders for analysers and refactorings -{-| Performs an analysis provided by its first parameter which generates-    information 's', which is then combined together (via a monoid) -}-doAnalysisSummary :: (Monoid s, Show' s) => (Filename -> F.ProgramFile A -> (s, F.ProgramFile A))-                        -> FileOrDir -> [Filename] -> Maybe FileOrDir -> IO ()-doAnalysisSummary aFun inSrc excludes outSrc = do-  if excludes /= [] && excludes /= [""]-    then putStrLn $ "Excluding " ++ intercalate "," excludes-                                 ++ " from " ++ inSrc ++ "/"-    else return ()+-- | 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, ps') = callAndSummarise aFun ps+  let (out, _) = callAndSummarise aFun ps   putStrLn . show' $ out +-- | Perform an analysis that produces information of type @s@.+callAndSummarise :: (Monoid s)+  => (FileProgram -> (s, a))+  -> [(FileProgram, SourceText)]+  -> (s, [a]) callAndSummarise aFun =-  foldl' (\(n, pss) (f, _, ps) -> let (n', ps') = aFun f ps-                                  in (n `mappend` n', ps' : pss)) (mempty, [])+  foldl' (\(n, pss) (ps, _) ->+            let (n', ps') = aFun ps+            in (n `mappend` n', ps' : pss)) (mempty, []) +-- | 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 -{-| Performs an analysis which reports to the user,-    but does not output any files -}-doAnalysisReport :: ([(Filename, F.ProgramFile A)] -> r)-                       -> (r -> IO out)-                       -> FileOrDir -> [Filename] -> IO out-doAnalysisReport rFun sFun inSrc excludes = do-  if excludes /= [] && excludes /= [""]-      then putStrLn $ "Excluding " ++ intercalate "," excludes-                    ++ " from " ++ inSrc ++ "/"-      else return ()-  ps <- readParseSrcDir inSrc excludes------  let report = rFun (map (\(f, inp, ast) -> (f, ast)) ps)+  let report = rFun . fmap fst $ ps   sFun report----- -doAnalysisReportWithModFiles :: ([(Filename, F.ProgramFile A)] -> r)-                             -> (r -> IO out)-                             -> FileOrDir-                             -> [Filename]-                             -> ModFiles-                             -> IO out-doAnalysisReportWithModFiles rFun sFun inSrc excludes mods = do-  if excludes /= [] && excludes /= [""]-      then putStrLn $ "Excluding " ++ intercalate "," excludes-                    ++ " from " ++ inSrc ++ "/"-      else return ()-  ps <- readParseSrcDirWithModFiles inSrc excludes mods------  let report = rFun (map (\(f, inp, ast) -> (f, ast)) ps)-  sFun report-------{-| Performs a refactoring provided by its first parameter, on the directory-    of the second, excluding files listed by third,-    output to the directory specified by the fourth parameter -}---- Refactoring where just a single list of filename/program file--- pairs is returned (the case when no files are being added)-doRefactor ::-     ([(Filename, F.ProgramFile A)] -> (String, [(Filename, F.ProgramFile A)]))-  -> FileOrDir -> [Filename] -> FileOrDir -> IO String-doRefactor rFun inSrc excludes outSrc = do-    if excludes /= [] && excludes /= [""]-    then putStrLn $ "Excluding " ++ intercalate "," excludes-           ++ " from " ++ inSrc ++ "/"-    else return ()-    ps <- readParseSrcDir inSrc excludes-    let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)-    let outputs = reassociateSourceText ps ps'-    outputFiles inSrc outSrc outputs-    return report+-- | 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 -doRefactorWithModFiles :: ([(Filename, F.ProgramFile A)] -> (String, [(Filename, F.ProgramFile A)]))-                       -> FileOrDir-                       -> [Filename]-                       -> FileOrDir-                       -> ModFiles-                       -> IO String-doRefactorWithModFiles rFun inSrc excludes outSrc mods = do-    if excludes /= [] && excludes /= [""]-    then putStrLn $ "Excluding " ++ intercalate "," excludes-           ++ " from " ++ inSrc ++ "/"-    else return ()-    ps <- readParseSrcDirWithModFiles inSrc excludes mods-    let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)-    let outputs = reassociateSourceText ps ps'-    outputFiles inSrc outSrc outputs-    return 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 --- For refactorings which create some files too--- i.e., for refactoring functions that return a--- pair of lists of filename/program file pairs is-doRefactorAndCreate ::-     ([(Filename, F.ProgramFile A)]-     -> (String, [(Filename, F.ProgramFile A)], [(Filename, F.ProgramFile A)]))+-- | Perform a refactoring that may create additional files.+doRefactorAndCreate+  :: ([FileProgram] -> (String, [FileProgram], [FileProgram]))   -> FileOrDir -> [Filename] -> FileOrDir -> IO String doRefactorAndCreate rFun inSrc excludes outSrc = do-    if excludes /= [] && excludes /= [""]-    then putStrLn $ "Excluding " ++ intercalate "," excludes-           ++ " from " ++ inSrc ++ "/"-    else return ()-    ps <- readParseSrcDir inSrc excludes-    let (report, ps', ps'') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)-    let outputs = reassociateSourceText ps ps'-    let outputs' = map (\(f, pf) -> (f, B.empty, pf)) ps''-    outputFiles inSrc outSrc outputs-    outputFiles inSrc outSrc outputs'-    return report+  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''+  outputFiles inSrc outSrc outputs+  outputFiles inSrc outSrc outputs'+  pure report --- For refactorings which create some files too--- i.e., for refactoring functions that return a--- pair of lists of filename/program file pairs is-type FileProgram = (Filename, F.ProgramFile A)-doRefactorAndCreateBinary :: ([FileProgram] -> (String, [FileProgram], [(Filename, B.ByteString)]))-                             -> FileOrDir -> [Filename] -> FileOrDir -> IO String-doRefactorAndCreateBinary rFun inSrc excludes outSrc = do-    if excludes /= [] && excludes /= [""]-    then putStrLn $ "Excluding " ++ intercalate "," excludes-                    ++ " from " ++ inSrc ++ "/"-    else return ()-    ps <- readParseSrcDir inSrc excludes-    let (report, ps', bins) = rFun (map (\ (f, inp, ast) -> (f, ast)) ps)-    let outputs = reassociateSourceText ps ps'-    outputFiles inSrc outSrc outputs-    outputFiles inSrc outSrc bins-    return report+-- | For refactorings which create additional files.+type FileProgram = F.ProgramFile A -doCreateBinary :: ([FileProgram] -> (String, [(Filename, B.ByteString)]))-               -> FileOrDir-               -> [Filename]-               -> FileOrDir-               -> ModFiles-               -> IO String-doCreateBinary rFun inSrc excludes outSrc mods = do-    if excludes /= [] && excludes /= [""]-    then putStrLn $ "Excluding " ++ intercalate "," excludes-                    ++ " from " ++ inSrc ++ "/"-    else return ()-    ps <- readParseSrcDirWithModFiles inSrc excludes mods-    let (report, bins) = rFun (map (\ (f, inp, ast) -> (f, ast)) ps)-    outputFiles inSrc outSrc bins-    return report+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 -reassociateSourceText :: [(Filename, SourceText, a)]-                   -> [(Filename, F.ProgramFile Annotation)]-                   -> [(Filename, SourceText, F.ProgramFile Annotation)]-reassociateSourceText ps ps' = zip3 (map fst ps') (map snd3 ps) (map snd ps')-  where snd3 (a, b, c) = b+reassociateSourceText :: [SourceText]+                      -> [F.ProgramFile Annotation]+                      -> [(F.ProgramFile Annotation, SourceText)]+reassociateSourceText ps ps' = zip ps' ps  -- * Source directory and file handling -{-| Read files from a direcotry, excluding those listed-    by the second parameter -}--- * Source directory and file handling-readParseSrcDir :: FileOrDir -> [Filename]-                   -> IO [(Filename, SourceText, F.ProgramFile A)]-readParseSrcDir inp excludes = do-    isdir <- isDirectory inp-    files <- if isdir-             then do-               files <- rGetDirContents inp-               -- Compute alternate list of excludes with the-               -- the directory appended-               let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes-               return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes'-             else return [inp]-    mapMaybeM readParseSrcFile files--mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]-mapMaybeM f = fmap catMaybes . (mapM f)+-- | Read files from a directory.+readParseSrcDir :: FileOrDir  -- ^ Directory to read from.+                -> [Filename] -- ^ Excluded files.+                -> IO [(FileProgram, SourceText)]+readParseSrcDir inp excludes =+  readParseSrcDirWithModFiles inp Nothing excludes  readParseSrcDirWithModFiles :: FileOrDir+                            -> Maybe FileOrDir                             -> [Filename]-                            -> ModFiles-                            -> IO [(Filename, SourceText, F.ProgramFile A)]-readParseSrcDirWithModFiles inp excludes mods = do-    isdir <- isDirectory inp-    files <- if isdir-             then do-               files <- rGetDirContents inp-               -- Compute alternate list of excludes with the-               -- the directory appended-               let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes-               return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes'-             else return [inp]-    mapMaybeM (readParseSrcFileWithModFiles mods) files--{-| Read a specific file, and parse it -}-readParseSrcFile :: Filename-                 -> IO (Maybe (Filename, SourceText, F.ProgramFile A))-readParseSrcFile f = do-    inp <- flexReadFile f-    let result = FP.fortranParserWithModFiles [] inp f-    case result of-      Right ast  -> return $ Just (f, inp, fmap (const unitAnnotation) ast)-      Left error -> (putStrLn $ show error) >> return Nothing+                            -> 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 -readParseSrcFileWithModFiles :: ModFiles+readParseSrcFileWithModFiles :: Maybe FileOrDir                              -> Filename-                             -> IO (Maybe (Filename, SourceText, F.ProgramFile A))-readParseSrcFileWithModFiles mods f = do-    inp <- flexReadFile f-    let result = FP.fortranParserWithModFiles mods inp f-    case result of-      Right ast  -> return $ Just (f, inp, fmap (const unitAnnotation) ast)-      Left error -> (putStrLn $ show error) >> return Nothing-------rGetDirContents :: FileOrDir -> IO [String]-rGetDirContents d = do-    ds <- getDirectoryContents d-    let ds' = ds \\ [".", ".."] -- remove '.' and '..' entries-    rec ds'-      where-        rec []     = return []-        rec (x:xs) = do xs' <- rec xs-                        g <- doesDirectoryExist (d ++ "/" ++ x)-                        if g then-                           do x' <- rGetDirContents (d ++ "/" ++ x)-                              return $ (map (\y -> x ++ "/" ++ y) x') ++ xs'-                        else if isFortran x-                             then return (x : xs')-                             else return xs'+                             -> 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 --- A version that lists all files, not just Fortran ones-rGetDirContents' :: FileOrDir -> IO [String]-rGetDirContents' d = do-    ds <- getDirectoryContents d-    fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries-      where-        f x = do-          g <- doesDirectoryExist (d ++ "/" ++ x)-          if g then do-            x' <- rGetDirContents (d ++ "/" ++ x)-            return $ map (\ y -> x ++ "/" ++ y) x'-          else return [x]+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 -{-| predicate on which fileextensions are Fortran files -}-isFortran x = fileExt x `elem` (exts ++ extsUpper)-  where exts = [".f", ".f90", ".f77", ".cmn", ".inc"]-        extsUpper = map (map toUpper) exts+-- | 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] -{-| extract a filename's extension -}-fileExt x = let ix = elemIndices '.' x-            in if null ix then ""-               else Prelude.drop (Prelude.last ix) x+-- | 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 --- | Read file using ByteString library and deal with any weird characters.-flexReadFile :: String -> IO B.ByteString-flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile+-- | Retrieve the ModFiles from a directory.+getModFiles :: FileOrDir -> IO ModFiles+getModFiles = fmap (fmap snd) . getModFilesWithNames
src/Camfort/Output.hs view
@@ -20,10 +20,16 @@  {- Provides support for outputting source files and analysis information -} -module Camfort.Output where+module Camfort.Output+  (+    -- * Classes+    OutputFiles(..)+  , Show'(..)+    -- * Refactoring+  , refactoring+  ) where  import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.PrettyPrint as PP import qualified Language.Fortran.Util.Position as FU import qualified Language.Fortran.ParserMonad as FPM@@ -33,16 +39,11 @@ import Camfort.Helpers import Camfort.Helpers.Syntax -import System.FilePath import System.Directory  import qualified Data.ByteString.Char8 as B import Data.Generics import Data.Functor.Identity-import Data.List hiding (zip)-import Data.Generics.Uniplate.Data-import Data.Generics.Zipper-import Debug.Trace import Control.Monad  import Control.Monad.Trans.Class@@ -68,8 +69,6 @@   outputFiles :: FileOrDir -> FileOrDir -> [t] -> IO ()   outputFiles inp outp pdata = do       outIsDir <- isDirectory outp-      inIsDir  <- isDirectory inp-      inIsFile <- doesFileExist inp       if outIsDir then do           -- Output to a directory, create if missing           createDirectoryIfMissing True outp@@ -96,7 +95,7 @@     newDir ++ listDiffL oldDir oldFilename   where     listDiffL []     ys = ys-    listDiffL xs     [] = []+    listDiffL _      [] = []     listDiffL (x:xs) (y:ys)         | x==y      = listDiffL xs ys         | otherwise = ys@@ -108,16 +107,16 @@   isNewFile _ = True  -- When there is a file to be reprinted (for refactoring)-instance OutputFiles (Filename, SourceText, F.ProgramFile Annotation) where-  mkOutputText f' (f, input, ast@(F.ProgramFile (F.MetaInfo version _) _)) =+instance OutputFiles (F.ProgramFile Annotation, SourceText) where+  mkOutputText _ (ast@(F.ProgramFile (F.MetaInfo version _) _), input) =      -- If we are create a file, call the pretty printer directly      if B.null input       then B.pack $ PP.pprintAndRender version ast (Just 0)       -- Otherwise, applying the refactoring system with reprint       else runIdentity $ reprint (refactoring version) ast input -  outputFile (f, _, _) = f-  isNewFile (_, inp, _) = B.null inp+  outputFile (pf, _) = F.pfGetFilename pf+  isNewFile (_, inp) = B.null inp  {- Specifies how to do specific refactorings   (uses generic query extension - remember extQ is non-symmetric) -}@@ -142,16 +141,15 @@                      -> F.ProgramUnit Annotation                      -> StateT FU.Position (State Int) (SourceText, Bool) -- Output comments-refactorProgramUnits v inp e@(F.PUComment ann span (F.Comment comment)) = do+refactorProgramUnits _ inp (F.PUComment ann span (F.Comment comment)) = do     cursor <- get     if pRefactored ann      then    let (FU.SrcSpan lb ub) = span-                 lb'      = leftOne lb-                 (p0, _)  = takeBounds (cursor, lb') inp+                 (p0, _)  = takeBounds (cursor, lb) inp                  nl       = if null comment then B.empty else B.pack "\n"              in (put ub >> return (B.concat [p0, B.pack comment, nl], True))      else return (B.empty, False)-  where leftOne (FU.Position f c l) = FU.Position f (c-1) (l-1)+ refactorProgramUnits _ _ _ = return (B.empty, False)  refactoringsForBlocks :: FPM.FortranVersion@@ -166,22 +164,20 @@                -> F.Block Annotation                -> StateT FU.Position (State Int) (SourceText, Bool) -- Output comments-refactorBlocks v inp e@(F.BlComment ann span (F.Comment comment)) = do+refactorBlocks _ inp (F.BlComment ann span (F.Comment comment)) = do     cursor <- get     if pRefactored ann      then    let (FU.SrcSpan lb ub) = span-                 lb'      = leftOne lb-                 (p0, _)  = takeBounds (cursor, lb') inp+                 (p0, _)  = takeBounds (cursor, lb) inp                  nl       = if null comment then B.empty else B.pack "\n"-             in (put ub >> return (B.concat [p0, B.pack comment, nl], True))+             in put ub >> return (B.concat [p0, B.pack comment, nl], True)      else return (B.empty, False)-  where leftOne (FU.Position f c l) = FU.Position f (c-1) (l-1)  -- Refactor use statements refactorBlocks v inp b@(F.BlStatement _ _ _ u@F.StUse{}) = do     cursor <- get     case refactored $ F.getAnnotation u of-           Just (FU.Position _ rCol rLine) -> do+           Just (FU.Position _ rCol _) -> do                let (FU.SrcSpan lb _) = FU.getSpan u                let (p0, _) = takeBounds (cursor, lb) inp                let out  = B.pack $ PP.pprintAndRender v b (Just (rCol -1))@@ -194,11 +190,11 @@  -- Common blocks, equivalence statements, and declarations can all -- be refactored by the default refactoring-refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StEquivalence{}) =+refactorBlocks v inp (F.BlStatement _ _ _ s@F.StEquivalence{}) =     refactorStatements v inp s-refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StCommon{}) =+refactorBlocks v inp (F.BlStatement _ _ _ s@F.StCommon{}) =     refactorStatements v inp s-refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StDeclaration{}) =+refactorBlocks v inp (F.BlStatement _ _ _ s@F.StDeclaration{}) =     refactorStatements v inp s -- Arbitrary statements can be refactored *as blocks* (in order to -- get good indenting)@@ -219,7 +215,7 @@     let a = F.getAnnotation e     case refactored a of       Nothing -> return (B.empty, False)-      Just (FU.Position _ rCol rLine) -> do+      Just (FU.Position _ rCol _) -> do         let (FU.SrcSpan lb ub) = FU.getSpan e         let (pre, _) = takeBounds (cursor, lb) inp         let indent = if newNode a then Just (rCol - 1) else Nothing@@ -243,7 +239,7 @@   case B.uncons xs of     Nothing -> 0     Just ('\n', xs) -> 1 + countLines xs-    Just (x, xs)    -> countLines xs+    Just (_, xs)    -> countLines xs  {- 'removeNewLines xs n' removes at most 'n' new lines characters from the input string xs, returning the new string and the number of new@@ -265,6 +261,6 @@            case B.uncons xs of                Nothing -> (xs, 0)                Just (x, xs) -> (B.cons x xs', n)-                   where (xs', n') = removeNewLines xs n+                   where (xs', _) = removeNewLines xs n  unpackFst (x, y) = (B.unpack x, y)
src/Camfort/Reprint.hs view
@@ -16,16 +16,17 @@  {-# LANGUAGE RankNTypes #-} -module Camfort.Reprint where+module Camfort.Reprint+  ( reprint+  , subtext+  , takeBounds+  ) where  import Data.Generics.Zipper -import Camfort.Analysis.Annotations import Camfort.Helpers-import Camfort.Helpers.Syntax  import qualified Data.ByteString.Char8 as B-import Data.Functor.Identity import Data.Data import Control.Monad.Trans.State.Lazy import qualified Language.Fortran.Util.Position as FU@@ -40,7 +41,7 @@   -- A refactoring takes a 'Typeable' value--- into a stateful SourceText (ByteString) transformer,+-- into a stateful SourceText (B.ByteString) transformer, -- which returns a pair of a stateful computation of an updated SourceText -- paired with a boolean flag denoting whether a refactoring has been -- performed.  The state contains a FU.Position which is the "cursor"@@ -66,7 +67,7 @@   -- Otherwise go with the normal algorithm   | otherwise = do    -- Create an initial cursor at the start of the file-   let cursor0 = FU.Position 0 0 1+   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@@ -132,13 +133,45 @@ -- Given a lower-bound and upper-bound pair of FU.Positions, split the -- incoming SourceText based on the distanceF between the FU.Position pairs takeBounds :: (FU.Position, FU.Position) -> SourceText -> (SourceText, SourceText)-takeBounds (l, u) = takeBounds' ((ll, lc), (ul, uc)) B.empty+takeBounds (l, u) = subtext (ll, lc) (ll, lc) (ul, uc)   where (FU.Position _ lc ll) = l         (FU.Position _ uc ul) = u-takeBounds' ((ll, lc), (ul, uc)) tk inp  =-    if (ll == ul && lc == uc) || (ll > ul) then (B.reverse tk, inp)-    else-      case B.uncons inp of-       Nothing         -> (B.reverse tk, inp)-       Just ('\n', ys) -> takeBounds' ((ll+1, 0), (ul, uc)) (B.cons '\n' tk) ys-       Just (x, xs)    -> takeBounds' ((ll, lc+1), (ul, uc)) (B.cons x tk) xs++{-|+  Split a text.++  Returns a tuple containing:+    1. the bit of input text between upper and lower bounds+    2. the remaining input text++  Takes:+    1. current cursor position+    2. lower bound+    3. upper bound+    4. input text++-}+subtext :: (Int, Int) -> (Int, Int) -> (Int, Int) -> B.ByteString -> (B.ByteString, B.ByteString)+subtext cursor (lowerLn, lowerCol) (upperLn, upperCol) =+    subtext' B.empty cursor+  where+    subtext' acc (cursorLn, cursorCol) input++      | cursorLn <= lowerLn && (cursorCol >= lowerCol ==> cursorLn < lowerLn) =+        case B.uncons input of+          Nothing -> (B.reverse acc, input)+          Just ('\n', input') -> subtext' acc (cursorLn+1, 1) input'+          Just (_, input')    -> subtext' acc (cursorLn, cursorCol+1) input'++      | cursorLn <= upperLn && (cursorCol >= upperCol ==> cursorLn < upperLn) =+        case B.uncons input of+          Nothing -> (B.reverse acc, input)+          Just ('\n', input') -> subtext' (B.cons '\n' acc) (cursorLn+1, 1) input'+          Just (x, input')    -> subtext' (B.cons x acc) (cursorLn, cursorCol+1) input'++      | otherwise =+        (B.reverse acc, input)++-- | Logical implication operator.+(==>) :: Bool -> Bool -> Bool; infix 2 ==>+a ==> b = a <= b
+ src/Camfort/Specification/Parser.hs view
@@ -0,0 +1,108 @@+{- |+Module      :  Camfort.Specification.Parser+Description :  Functionality common to all specification parsers.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++{-# LANGUAGE FlexibleContexts #-}++module Camfort.Specification.Parser+  (+  -- * Specification Parsers+    SpecParser+  , looksLikeASpec+  , mkParser+  , runParser+  -- ** Errors+  , SpecParseError+  , parseError+  ) where++import           Control.Monad.Except (throwError)+import           Data.List (isPrefixOf)+import qualified Data.Text as T++data SpecParseError e+  = ParseError e+  | InvalidSpecificationCharacter Char+  | MissingSpecificationCharacter+  deriving (Eq)++instance (Show e) => Show (SpecParseError e) where+  show (InvalidSpecificationCharacter c) =+    "Invalid character at start of specification: " ++ show c+  show MissingSpecificationCharacter = "missing start of specification"+  show (ParseError e) = show e++-- | Embed an error as a specification parse error.+parseError :: e -> SpecParseError e+parseError = ParseError++invalidSpecificationCharacter :: Char -> SpecParseError e+invalidSpecificationCharacter = InvalidSpecificationCharacter++missingSpecificationCharacter :: SpecParseError e+missingSpecificationCharacter = MissingSpecificationCharacter++-- | Parser for specifications of type @r@ that may fail with error type @e@.+data SpecParser e r = SpecParser+  {+    -- | The underlying parser.+    parser       :: String -> Either e r+    -- | A list of keywords that indicate the type of specification (e.g., @"stencil"@ or @"access"@).+  , specKeywords :: [String]+  }++-- | Does the character indicate the start of an abritrary specification?+--+-- These characters are used to help distinguish specifications+-- from normal comments.+isSpecStartChar :: Char -> Bool+isSpecStartChar = (`elem` "=!<>")++-- | Run the given parser on a string to produce a specification+-- (or a reason why it couldn't be parsed).+runParser :: SpecParser e r -> String -> Either (SpecParseError e) r+runParser p s = case stripInitial s of+                  Right s' -> case parser p s' of+                                Left  e -> throwError $ parseError e+                                Right r -> pure r+                  Left e   -> throwError e+  where stripInitial = stripAnnChar . stripLeadingWhiteSpace+        stripAnnChar [] =+          throwError missingSpecificationCharacter+        stripAnnChar (c:cs) | isSpecStartChar c = pure (stripLeadingWhiteSpace cs)+                            | otherwise         =+                                throwError $ invalidSpecificationCharacter c++-- | Define a specification parser.+mkParser :: (String -> Either e r) -- ^ Parser with error type @e@ and result type @r@.+         -> [String]               -- ^ Keywords that indicate the type of specification.+         -> SpecParser e r+mkParser = SpecParser++-- | Remove any whitespace characters at the beginning of the string.+stripLeadingWhiteSpace :: String -> String+stripLeadingWhiteSpace = T.unpack . T.strip . T.pack++-- | Check if a comment is probably an attempt at a specification+-- that can be parsed by the given parser.+looksLikeASpec :: SpecParser e r -> String -> Bool+looksLikeASpec p text+  | length (stripLeadingWhiteSpace text) >= 2 =+  case stripLeadingWhiteSpace text of+    -- Check the leading character is '=' for specification+    c:cs -> isSpecStartChar c && testAnnotation cs+    _    -> False+  | otherwise = False+  where+    testAnnotation inp = case specKeywords p of+                           [] -> True+                           ks -> any (inp `hasPrefix`) ks+    hasPrefix []       _   = False+    hasPrefix (' ':xs) str = hasPrefix xs str+    hasPrefix xs       str = str `isPrefixOf` xs
src/Camfort/Specification/Stencils.hs view
@@ -17,6 +17,8 @@ module Camfort.Specification.Stencils  (InferMode, infer, check, synth) where +import Control.Arrow ((***), first, second)+ import Camfort.Specification.Stencils.CheckFrontend hiding (LogLine) import Camfort.Specification.Stencils.InferenceFrontend import Camfort.Specification.Stencils.Synthesis@@ -31,28 +33,33 @@  import Data.List ++-- | Helper for retrieving analysed blocks.+getBlocks = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis+ -------------------------------------------------- --         Stencil specification inference      -- --------------------------------------------------  -- Top-level of specification inference-infer :: InferMode -> Char -> Filename+infer :: InferMode+      -> Char       -> F.ProgramFile Annotation       -> (String, F.ProgramFile Annotation)-infer mode marker filename pf =+infer mode marker pf =     -- Append filename to any outputs     if null output-       then ("", fmap FA.prevAnnotation pf'')-       else ("\n" ++ filename ++ "\n" ++ output, fmap FA.prevAnnotation pf'')+       then ("", infer1)+       else ("\n" ++ filename ++ "\n" ++ output, infer1)     where+      filename = F.pfGetFilename pf       output = intercalate "\n"              . filter (not . white)-             . map (formatSpec Nothing nameMap) $ results+             . map formatSpecNoComment $ infer2       white = all (\x -> (x == ' ') || (x == '\t'))-      (pf'', results) = stencilInference nameMap mode marker-                      . FAB.analyseBBlocks $ pf'-      nameMap = FAR.extractNameMap pf'-      pf'     = FAR.analyseRenames . FA.initAnalysis $ pf+      infer' = stencilInference mode marker . getBlocks $ pf+      infer1 = fmap FA.prevAnnotation . fst $ infer'+      infer2 = snd infer'  -------------------------------------------------- --         Stencil specification synthesis      --@@ -61,39 +68,46 @@ -- Top-level of specification synthesis synth :: InferMode       -> Char-      -> [(Filename, F.ProgramFile A)]-      -> (String, [(Filename, F.ProgramFile Annotation)])-synth mode marker = foldr buildOutput ("", [])+      -> [F.ProgramFile A]+      -> (String, [F.ProgramFile Annotation])+synth mode marker = first normaliseMsg . foldr buildOutput (("",""), [])   where-    buildOutput (f, pf) (r, pfs) = (r ++ r', (f, pf') : pfs)-      where (r', pf') = synthPF mode marker f pf+    buildOutput pf =+      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 =+      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 -synthPF :: InferMode -> Char -> Filename-      -> F.ProgramFile Annotation-      -> (String, F.ProgramFile Annotation)-synthPF _ marker _ pf =-    -- Append filename to any outputs-    ("", fmap FA.prevAnnotation pf'')-    where-      (pf'', _) = stencilInference nameMap Synth marker-                . FAB.analyseBBlocks $ pf'-      nameMap = FAR.extractNameMap pf'-      pf'     = FAR.analyseRenames . FA.initAnalysis $ pf+    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."++ -------------------------------------------------- --         Stencil specification checking       -- -------------------------------------------------- -check :: Filename -> F.ProgramFile Annotation -> String-check filename pf =+check :: F.ProgramFile Annotation -> String+check pf =     -- Append filename to any outputs     if null output then "" else "\n" ++ filename ++ "\n" ++ output     where-     output  = intercalate "\n" results-     -- Applying checking mechanism-     results  = stencilChecking nameMap . FAB.analyseBBlocks $ pf'-     nameMap = FAR.extractNameMap pf'-     pf'      = FAR.analyseRenames . FA.initAnalysis $ pf+     filename = F.pfGetFilename pf+     output = show . stencilChecking . getBlocks $ pf  -- Local variables: -- mode: haskell
src/Camfort/Specification/Stencils/Annotation.hs view
@@ -17,11 +17,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -module Camfort.Specification.Stencils.Annotation where+module Camfort.Specification.Stencils.Annotation () where  import Camfort.Analysis.Annotations import Camfort.Analysis.CommentAnnotator-import qualified Camfort.Specification.Stencils.Grammar as Gram+import qualified Camfort.Specification.Stencils.Parser.Types as Gram  import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA@@ -31,12 +31,12 @@ -- Instances for embedding parsed specifications into the AST instance ASTEmbeddable (FA.Analysis Annotation) Gram.Specification where   annotateWithAST ann ast =-    onPrev (\ann -> ann { stencilSpec = Just $ Left ast }) ann+    onPrev (giveParseSpec 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 b = ann-  linkPU ann pu = ann+  link ann _ = ann+  linkPU ann _ = ann
src/Camfort/Specification/Stencils/CheckBackend.hs view
@@ -18,51 +18,71 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} -module Camfort.Specification.Stencils.CheckBackend where+module Camfort.Specification.Stencils.CheckBackend+  (+    -- * Classes+    SynToAst(..)+    -- * Errors+  , SynToAstError+  , regionNotInScope+  ) where +import Data.Function (on)+ import Camfort.Specification.Stencils.Syntax import Camfort.Specification.Stencils.Model-import qualified Camfort.Specification.Stencils.Grammar as SYN+import qualified Camfort.Specification.Stencils.Parser.Types as SYN -type ErrorMsg = String+data SynToAstError = RegionNotInScope String+  deriving (Eq) --- Class for functions converting from Grammar parse+regionNotInScope :: String -> SynToAstError+regionNotInScope = RegionNotInScope++instance Show SynToAstError where+  show (RegionNotInScope r) = "Error: region " ++ r ++ " is not in scope."++-- Class for functions converting from Parser parse -- syntax to the AST representation of the Syntax module class SynToAst s t | s -> t where-  synToAst :: (?renv :: RegionEnv) => s -> Either ErrorMsg t+  synToAst :: (?renv :: RegionEnv) => s -> Either SynToAstError t  -- Top-level conversion of declarations-instance SynToAst SYN.Specification (Either RegionEnv SpecDecls) where+instance SynToAst SYN.Specification (Either RegionDecl SpecDecl) where   synToAst (SYN.SpecDec spec vars) = do      spec' <- synToAst spec-     return $ Right [(vars, spec')]+     return $ Right (vars, spec')    synToAst (SYN.RegionDec rvar region) = do      spec' <- synToAst region-     return $ Left [(rvar, spec')]+     return $ Left (rvar, spec')  -- Convert temporal or spatial specifications-instance SynToAst SYN.Spec Specification where-  synToAst (SYN.Spatial mods r) = do-    (modLinear, approx) <- synToAst mods-    r' <- synToAst r-    let s' = Spatial r'-    return $ Specification $ addLinearity modLinear $-       case approx of-        Just SYN.AtMost  -> Bound Nothing (Just s')-        Just SYN.AtLeast -> Bound (Just s') Nothing-        Nothing          -> Exact s'-    where-      addLinearity Linear appr = Once appr-      addLinearity NonLinear appr = Mult appr+instance SynToAst SYN.SpecInner Specification where+  synToAst (SYN.SpecInner spec isStencil) = do+    spec' <- synToAst spec+    return $ Specification spec' isStencil +instance SynToAst (Multiplicity (Approximation SYN.Region)) (Multiplicity (Approximation Spatial)) where+  synToAst (Once a) = fmap Once . synToAst $ a+  synToAst (Mult a) = fmap Mult . synToAst $ a++instance SynToAst (Approximation SYN.Region) (Approximation Spatial) where+  synToAst (Exact s)     = fmap (Exact . Spatial) . synToAst $ s+  synToAst (Bound s1 s2) = (Bound `on` (fmap Spatial)) <$> synToAst s1 <*> synToAst s2++instance SynToAst (Maybe SYN.Region) (Maybe RegionSum) where+  synToAst Nothing  = pure Nothing+  synToAst (Just r) = fmap Just . synToAst $ r+ -- Convert region definitions into the DNF-form used internally instance SynToAst SYN.Region RegionSum where   synToAst = dnf  -- Convert a grammar syntax to Disjunctive Normal Form AST-dnf :: (?renv :: RegionEnv) => SYN.Region -> Either ErrorMsg RegionSum+dnf :: (?renv :: RegionEnv) => SYN.Region -> Either SynToAstError RegionSum +dnf (SYN.RegionConst rconst) = pure . Sum $ [Product [rconst]] -- Distributive law dnf (SYN.And r1 r2) = do     r1' <- dnf r1@@ -76,32 +96,10 @@     r2' <- dnf r2     return $ Sum $ unSum r1' ++ unSum r2' -- Region conversion-dnf (SYN.Forward dep dim reflx)  = return $ Sum [Product [Forward dep dim reflx]]-dnf (SYN.Backward dep dim reflx) = return $ Sum [Product [Backward dep dim reflx]]-dnf (SYN.Centered dep dim reflx) = return $ Sum [Product [Centered dep dim reflx]]-dnf (SYN.Var v)            =+dnf (SYN.Var v)              =     case lookup v ?renv of-      Nothing -> Left $ "Error: region " ++ v ++ " is not in scope."+      Nothing -> Left (RegionNotInScope v)       Just rs -> return rs---- Convert modifier list to modifier info-instance SynToAst [SYN.Mod]-                  (Linearity, Maybe SYN.Mod) where-  synToAst mods = return (linearity, approx)-    where-      linearity = if SYN.ReadOnce `elem` mods then Linear else NonLinear--      approx = find' isApprox mods-      isApprox SYN.AtMost  = Just SYN.AtMost-      isApprox SYN.AtLeast = Just SYN.AtLeast-      isApprox _           = Nothing--find' :: Eq a => (a -> Maybe b) -> [a] -> Maybe b-find' p [] = Nothing-find' p (x : xs) =-  case p x of-    Nothing -> find' p xs-    Just b  -> Just b  -- Local variables: -- mode: haskell
src/Camfort/Specification/Stencils/CheckFrontend.hs view
@@ -14,30 +14,45 @@    limitations under the License. -} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-} -module Camfort.Specification.Stencils.CheckFrontend where+module Camfort.Specification.Stencils.CheckFrontend+  (+    -- * Stencil checking+    stencilChecking+    -- ** Validation Results+  , CheckResult+  , checkFailure+  , checkWarnings+    -- ** Helpers+  , existingStencils+  ) where -import Data.Generics.Uniplate.Operations import Control.Arrow+import Control.Monad.Reader (MonadReader, ReaderT, ask, 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 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 qualified Camfort.Specification.Stencils.Grammar as Gram+import Camfort.Specification.Stencils.Generate+import qualified Camfort.Specification.Stencils.Parser as Parser+import Camfort.Specification.Stencils.Parser.Types (reqRegions) import Camfort.Specification.Stencils.Model-import Camfort.Specification.Stencils.InferenceFrontend hiding (LogLine) import Camfort.Specification.Stencils.Syntax-import Camfort.Analysis.Annotations-import Camfort.Analysis.CommentAnnotator  import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.BBlocks as FAB import qualified Language.Fortran.Analysis.DataFlow as FAD import qualified Language.Fortran.Util.Position as FU@@ -48,73 +63,295 @@ import Data.Int import qualified Data.Set as S +newtype CheckResult = CheckResult [StencilResult]++-- | Retrieve a list of 'StencilResult' from a 'CheckResult'.+--+-- Ensures correct ordering of results.+getCheckResult :: CheckResult -> [StencilResult]+getCheckResult (CheckResult rs) = sort rs++instance Eq CheckResult where+  (==) = (==) `on` getCheckResult++-- | Represents only the check results for invalid stencils.+newtype CheckError  = CheckError { getCheckError :: [StencilCheckError] }++-- | Represents only the check results that resulted in warnings.+newtype CheckWarning = CheckWarning { getCheckWarning :: [StencilCheckWarning] }++-- | Retrieve the checks for invalid stencils from a 'CheckResult'. Result is+-- Nothing if there are no invalid checks.+checkFailure :: CheckResult -> Maybe CheckError+checkFailure c = case catMaybes $ fmap toFailure (getCheckResult c) of+                 [] -> Nothing+                 xs -> Just $ CheckError xs+  where toFailure (SCFail err) = Just err+        toFailure _            = Nothing++checkWarnings :: CheckResult -> Maybe CheckWarning+checkWarnings c = case catMaybes $ fmap toWarning (getCheckResult c) of+                    [] -> Nothing+                    xs -> Just $ CheckWarning xs+  where toWarning (SCWarn warn) = Just warn+        toWarning _             = Nothing++-- | Result of stencil validation.+data StencilResult+  -- | No issues were identified with the stencil at the given position.+  = SCOkay { scSpan :: FU.SrcSpan+           , scSpec :: Specification+           , scVar  :: Variable+           , scBodySpan :: FU.SrcSpan+           }+  -- | Validation of stencil failed. See 'StencilCheckError' for information+  -- on the types of validation errors that can occur.+  | SCFail StencilCheckError+  -- | A warning which shouldn't interrupt other procedures.+  | SCWarn StencilCheckWarning+  deriving (Eq)++class GetSpan a where+  getSpan :: a -> FU.SrcSpan++instance GetSpan StencilResult where+  getSpan SCOkay{scSpan = srcSpan} = srcSpan+  getSpan (SCFail err)             = getSpan err+  getSpan (SCWarn warn)            = getSpan warn++instance GetSpan StencilCheckError where+  getSpan (SynToAstError     _ srcSpan)      = srcSpan+  getSpan (NotWellSpecified  (srcSpan, _) _) = srcSpan+  getSpan (ParseError srcSpan _)             = srcSpan+  getSpan (RegionExists srcSpan _)           = srcSpan++instance GetSpan StencilCheckWarning where+  getSpan (DuplicateSpecification srcSpan) = srcSpan+  getSpan (UnusedRegion srcSpan _)         = srcSpan++instance Ord StencilResult where+  compare = compare `on` getSpan++instance Ord StencilCheckError where+  compare = compare `on` getSpan++-- | Represents a way in which validation of a stencil can fail.+data StencilCheckError+  -- | Error occurred during conversion from parsed representation to AST.+  = SynToAstError SynToAstError FU.SrcSpan+  -- | The existing stencil conflicts with an inferred stencil.+  | NotWellSpecified (FU.SrcSpan, SpecDecls) (FU.SrcSpan, SpecDecls)+  -- | The stencil could not be parsed correctly.+  | ParseError FU.SrcSpan (SpecParseError Parser.SpecParseError)+  -- | A definition for the region alias already exists.+  | RegionExists FU.SrcSpan Variable+  deriving (Eq)++-- | Create a check result informating a user of a 'SynToAstError'.+synToAstError :: SynToAstError -> FU.SrcSpan -> StencilResult+synToAstError err srcSpan = SCFail $ SynToAstError err srcSpan++-- | Create a check result informating a user of a 'NotWellSpecified' error.+notWellSpecified :: (FU.SrcSpan, SpecDecls) -> (FU.SrcSpan, SpecDecls) -> StencilResult+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 srcSpan err = SCFail $ ParseError srcSpan err++-- | Create a check result informating that a region already exists.+regionExistsError :: FU.SrcSpan -> Variable -> StencilResult+regionExistsError srcSpan r = SCFail $ RegionExists srcSpan r++-- | Represents a non-fatal validation warning.+data StencilCheckWarning+  -- | Specification is defined multiple times.+  = DuplicateSpecification FU.SrcSpan+  -- | Region is defined but not used.+  | UnusedRegion FU.SrcSpan Variable+  deriving (Eq)++-- | Create a check result informing a user of a duplicate specification.+duplicateSpecification :: FU.SrcSpan -> StencilResult+duplicateSpecification = SCWarn . DuplicateSpecification++-- | Create a check result informating an unused region.+unusedRegion :: FU.SrcSpan -> Variable -> StencilResult+unusedRegion srcSpan var = SCWarn $ UnusedRegion srcSpan var++specOkay :: FU.SrcSpan -> Specification -> Variable -> FU.SrcSpan -> StencilResult+specOkay spanSpec@(FU.SrcSpan (FU.Position o1 _ _) (FU.Position o2 _ _)) spec var spanBody@(FU.SrcSpan (FU.Position o1' _ _) (FU.Position o2' _ _)) =+  SCOkay { scSpan      = spanSpec+         , scSpec      = spec+         , scBodySpan  = spanBody+         , scVar       = var+         }++-- | Pretty print a message with suitable spacing after the source position.+prettyWithSpan :: FU.SrcSpan -> String -> String+prettyWithSpan srcSpan s = show srcSpan ++ "    " ++ s++instance Show CheckResult where+  show = intercalate "\n" . fmap show . getCheckResult++instance Show CheckError where+  show = intercalate "\n" . fmap show . getCheckError++instance Show CheckWarning where+  show = intercalate "\n" . fmap show . getCheckWarning++instance Show StencilResult where+  show SCOkay{ scSpan = span } = prettyWithSpan span "Correct."+  show (SCFail err)            = show err+  show (SCWarn warn)           = show warn++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]+  show (ParseError srcSpan err) = prettyWithSpan srcSpan (show err)+  show (RegionExists srcSpan name) =+    prettyWithSpan srcSpan ("Region '" ++ name ++ "' already defined")++instance Show StencilCheckWarning where+  show (DuplicateSpecification srcSpan) = prettyWithSpan srcSpan+    "Warning: Duplicate specification."+  show (UnusedRegion srcSpan name)      = prettyWithSpan srcSpan $+    "Warning: Unused region '" ++ name ++ "'"+ -- Entry point-stencilChecking :: FAR.NameMap -> F.ProgramFile (FA.Analysis A) -> [String]-stencilChecking nameMap pf = snd . runWriter $-  do -- Attempt to parse comments to specifications-     pf' <- annotateComments Gram.specParser pf+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' -     -- get map of AST-Block-ID ==> corresponding AST-Block-     let bm    = FAD.genBlockMap pf'-     -- get map of program unit ==> basic block graph-     let bbm   = FAB.genBBlockMap pf'-     -- build the supergraph of global dependency-     let sgr   = FAB.genSuperBBGr bbm-     -- extract the supergraph itself-     let gr    = FAB.superBBGrGraph sgr-     -- get map of variable name ==> { defining AST-Block-IDs }-     let dm    = FAD.genDefMap bm-     let pprint = map (\(span, spec) -> show span ++ "    " ++ spec)-     -- perform reaching definitions analysis-     let rd    = FAD.reachingDefinitions dm gr-     -- create graph of definition "flows"-     let flTo =  FAD.genFlowsToGraph bm dm gr rd-     -- identify every loop by its back-edge-     let beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr-     let ivmap = FAD.genInductionVarMapByASTBlock beMap gr-     let results = let ?flowsGraph = flTo in-                    let ?nameMap = nameMap-                      in descendBiM perProgramUnitCheck pf'-     -- Format output-     let (_, output) = evalState (runWriterT results) (([], Nothing), ivmap)-     tell $ pprint output+  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) -type LogLine = (FU.SrcSpan, String)-type Checker a =-    WriterT [LogLine]-            (State ((RegionEnv, Maybe F.ProgramUnitName), FAD.InductionVarMapByASTBlock)) a+  tell output +data CheckState = CheckState+  { regionEnv     :: RegionEnv+  , checkResult   :: [StencilResult]+  , prog          :: Maybe F.ProgramUnitName+  , ivMap         :: FAD.InductionVarMapByASTBlock+  , regions       :: [(FU.SrcSpan, Variable)]+  , usedRegions   :: [Variable]+  }++addResult :: StencilResult -> Checker ()+addResult r = modify (\s -> s { checkResult = r : checkResult s })++-- | Remove the given regions variables from the tracked unused regions.+informRegionsUsed :: [Variable] -> Checker ()+informRegionsUsed regions = modify+  (\s -> s { usedRegions = usedRegions s `union` regions })++-- | Start tracking a region.+addRegionToTracked :: FU.SrcSpan -> Variable -> Checker ()+addRegionToTracked srcSpan@(FU.SrcSpan (FU.Position o1 _ _) (FU.Position o2 _ _)) r =+  modify (\s -> s { regions = (srcSpan, r) : regions s })++-- | True if the region name is already tracked.+regionExists :: Variable -> Checker Bool+regionExists reg = do+  knownNames <- fmap (fmap snd . regions) get+  pure $ reg `elem` knownNames++startState :: FAD.InductionVarMapByASTBlock -> CheckState+startState ivmap =+  CheckState { regionEnv     = []+             , checkResult   = []+             , prog          = Nothing+             , ivMap         = ivmap+             , regions       = []+             , usedRegions   = []+             }++newtype Checker a =+  Checker { runChecker :: ReaderT (FAD.FlowsGraph A) (State CheckState) a }+  deriving ( Functor, Applicative, Monad+           , MonadReader (FAD.FlowsGraph A)+           , MonadState CheckState+           )+ -- 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 (FA.Analysis A)+parseCommentToAST :: FA.Analysis A -> FU.SrcSpan -> Checker (Either SynToAstError (FA.Analysis A)) parseCommentToAST ann span =-  case stencilSpec (FA.prevAnnotation ann) of-    Just (Left stencilComment) -> do-         ((regionEnv, _), _) <- get-         let ?renv = regionEnv-          in case synToAst stencilComment of-               Left err   -> error $ show span ++ ": " ++ err-               Right ast  -> return $ onPrev-                              (\ann -> ann {stencilSpec = Just (Right ast)}) ann-    _ -> return ann+  case getParseSpec (FA.prevAnnotation ann) of+    Just stencilComment -> do+         informRegionsUsed (reqRegions stencilComment)+         renv <- fmap regionEnv get+         let ?renv = renv+         case synToAst stencilComment of+           Right ast -> do+             pfun <- either (\reg@(var,_) -> do+                        exists <- regionExists var+                        if exists+                          then addResult (regionExistsError span var)+                               >> pure id+                          else addRegionToTracked span var+                               >> pure (giveRegionSpec reg))+                     (pure . giveAstSpec . pure) ast+             pure . pure $ onPrev 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 ann =-  case stencilSpec (FA.prevAnnotation ann) of-    Just (Right (Left regionEnv)) -> modify $ first (first (regionEnv ++))-    _                             -> return ()+  case getRegionSpec (FA.prevAnnotation ann) of+    Just renv -> modify (\s -> s { regionEnv = renv : regionEnv s })+    _         -> pure ()  checkOffsetsAgainstSpec :: [(Variable, Multiplicity [[Int]])]                         -> [(Variable, Specification)]                         -> Bool checkOffsetsAgainstSpec offsetMaps specMaps =-    flip all specToVecList $-      \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+  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) @@ -147,61 +384,36 @@  -- Go into the program units first and record the module name when -- entering into a module-perProgramUnitCheck :: (?nameMap :: FAR.NameMap, ?flowsGraph :: FAD.FlowsGraph A)-   => F.ProgramUnit (FA.Analysis A) -> Checker (F.ProgramUnit (FA.Analysis A))+perProgramUnitCheck ::+   F.ProgramUnit (FA.Analysis A) -> Checker (F.ProgramUnit (FA.Analysis A))+ perProgramUnitCheck p@F.PUModule{} = do-    modify $ first (second (const (Just $ FA.puName p)))+    modify (\s -> s { prog = Just $ FA.puName p })     descendBiM perBlockCheck p perProgramUnitCheck p = descendBiM perBlockCheck p -perBlockCheck :: (?nameMap :: FAR.NameMap, ?flowsGraph :: FAD.FlowsGraph A)-   =>  F.Block (FA.Analysis A) -> Checker (F.Block (FA.Analysis A))+perBlockCheck :: F.Block (FA.Analysis A) -> Checker (F.Block (FA.Analysis A))  perBlockCheck b@(F.BlComment ann span _) = do-  ann' <- parseCommentToAST ann span-  updateRegionEnv ann'-  let b' = F.setAnnotation ann' b-  case (stencilSpec $ FA.prevAnnotation ann', stencilBlock $ FA.prevAnnotation ann') of-    -- Comment contains a specification and an Associated block-    (Just (Right (Right specDecls)), Just block) ->-     case block of-      s@(F.BlStatement _ span' _ (F.StExpressionAssign _ _ lhs _)) ->-       case isArraySubscript lhs of-         Just subs -> do-            -- Create list of relative indices-            ivmap <- snd <$> get-            -- Do analysis-            let realName v   = v `fromMaybe` (v `M.lookup` ?nameMap)-            let lhsN         = fromMaybe [] (neighbourIndex ivmap subs)-            let correctNames = map (first realName)-            let relOffsets = correctNames . fst . runWriter $ genOffsets ivmap lhsN [s]-            let multOffsets = map (\relOffset ->-                  case relOffset of-                    (var, (True, offsets)) -> (var, Mult offsets)-                    (var, (False, offsets)) -> (var, Once offsets)) relOffsets-            let expandedDecls =-                  concatMap (\(vars,spec) -> map (flip (,) spec) vars) specDecls-            -- Model and compare the current and specified stencil specs-            if checkOffsetsAgainstSpec multOffsets expandedDecls-              then tell [ (span, "Correct.") ]-              else do-                let correctNames2 =  map (first (map realName))-                let inferred = correctNames2 . fst . fst . runWriter $ genSpecifications ivmap lhsN [s]-                let sp = replicate 8 ' '-                tell [ (span,-                     "Not well specified.\n"-                  ++ sp ++ "Specification is:\n"-                  ++ sp ++ sp ++ pprintSpecDecls specDecls ++ "\n"-                  ++ sp ++ "but at " ++ show span' ++ " the code behaves as\n"-                  ++ sp ++ sp ++ pprintSpecDecls inferred) ]--            return b'-         Nothing -> return b'+  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+        -- 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+             return b' -      -- Stub, maybe collect stencils inside 'do' block-      F.BlDo{} -> return b'-      _ -> return b'-    _ -> return b'+          -- Stub, maybe collect stencils inside 'do' block+          F.BlDo{} -> return b'+          _ -> return b'+        _ -> return b'  perBlockCheck b@(F.BlDo _ _ _ _ _ _ body _) = do    -- descend into the body of the do-statement@@ -214,6 +426,67 @@   -- Go inside child blocks   mapM_ (descendBiM perBlockCheck) $ children b   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+  -- Work out whether this is a stencil (non empty LHS indices) or not+  let (subs, isStencil) = case maybeSubs of+                             Nothing -> ([], False)+                             Just subs -> (subs, True)++  -- Get the induction variables relative to the current block+  ivmap <- fmap ivMap get+  let ivs = extractRelevantIVS ivmap block++  -- Do analysis; create list of relative indices+  let lhsN         = fromMaybe [] (neighbourIndex ivmap subs)+      relOffsets = fst . runWriter $ genOffsets flowsGraph ivs lhsN [block]+      multOffsets = map (\relOffset ->+          case relOffset of+          (var, (True, offsets)) -> (var, Mult offsets)+          (var, (False, offsets)) -> (var, Once offsets)) relOffsets+      expandedDecls =+          concatMap (\(vars,spec) -> map (flip (,) spec) vars) specDecls++  let userDefinedIsStencils = map (\(_, Specification _ b) -> b) specDecls+  -- Model and compare the current and specified stencil specs+  if all (isStencil ==) userDefinedIsStencils && checkOffsetsAgainstSpec multOffsets expandedDecls+    then mapM_ (\spec@(v,s) -> do+                   specExists <- seenBefore spec+                   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+    addResult (notWellSpecified (span, specDecls) (spanInferred, inferred))+  where+    seenBefore :: (Variable, Specification) -> Checker Bool+    seenBefore (v,spec) = do+          checkLog <- fmap checkResult get+          pure $ any (\x -> case x of+                              SCOkay{ scSpec=spec'+                                    , scBodySpan=bspan+                                    , 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+  where getExistingStencil (SCOkay _ spec var bodySpan) = Just (spec, bodySpan, var)+        getExistingStencil _                            = Nothing  -- Local variables: -- mode: haskell
src/Camfort/Specification/Stencils/Consistency.hs view
@@ -20,7 +20,7 @@               Specification            -> Multiplicity (UnionNF n Offsets)            -> ConsistencyResult-consistent (Specification mult) observedIxs =+consistent (Specification mult _) observedIxs =     -- First do the linearity check     case (specModel, observedIxs) of       (Mult a, Mult b) -> a `consistent'` b@@ -28,7 +28,7 @@       (Once _, Mult _) ->Inconsistent         "Specification is readOnce, but there are repeated indices."       (Mult _, Once _) -> Inconsistent-        "Specification lacks readOnce, but the indices are inuque."+        "Specification lacks readOnce, but the indices are unique."   where     specModel :: Multiplicity (Approximation (UnionNF n (Interval Standard)))     specModel =
+ src/Camfort/Specification/Stencils/Generate.hs view
@@ -0,0 +1,410 @@+{- |+Module      :  Camfort.Specification.Stencils.Generate+Description :  Generate stencils for inference and synthesis+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Camfort.Specification.Stencils.Generate+  (+    EvalLog+  , Neighbour(..)+  , extractRelevantIVS+  , assocsSequence+  , genSpecifications+  , genSubscripts+  , isArraySubscript+  , neighbourIndex+  , isVariableExpr+  , convIxToNeighbour+  , indicesToRelativisedOffsets+  , indicesToSpec+  , neighbourToOffset+  , relativise+  ) 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 qualified Data.IntMap as IM+import qualified Data.Map as M+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.Analysis.DataFlow as FAD+import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Util.Position as FU++import Camfort.Analysis.Annotations (A, Annotation)+import Camfort.Helpers (collect)+import qualified Camfort.Helpers.Vec as V+import Camfort.Specification.Stencils.Model+  (Approximation(..), Multiplicity(..))+import Camfort.Specification.Stencils.Annotation ()+import Camfort.Specification.Stencils.Syntax+  ( absoluteRep+  , fromBool+  , groupKeyBy+  , hasDuplicates+  , isEmpty+  , isUnit+  , setLinearity+  , Specification(..)+  , Variable)++import Camfort.Specification.Stencils.CheckBackend+import Camfort.Specification.Stencils.InferenceBackend+type EvalLog = [(String, Variable)]++{-| Representation for indices as either:+     * neighbour indices+     * constant+     * non neighbour index -}+data Neighbour = Neighbour Variable Int+               | Constant (F.Value ())+               | NonNeighbour deriving (Eq, Show)+++{-| 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.ExpSubscript _ _ (F.ExpValue _ _ (F.ValVariable _)) subs) =+   Just $ F.aStrip subs+isArraySubscript (F.ExpDataRef _ _ e e') =+   isArraySubscript e <> isArraySubscript e'+isArraySubscript _ = Nothing++{-| 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 ivs ixs =+  if NonNeighbour `notElem` neighbours+  then Just neighbours+  else Nothing+    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)++      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]++{-| genSubscripts+   Takes * a flows graph+         * 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)+  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' False _ (F.BlStatement _ _ _ (F.StExpressionAssign _ _ e _))+       | isJust $ isArraySubscript e+       -- Don't pull dependencies through arrays+       = return M.empty++    genSubscripts' _ flowsGraph block = do+       visited <- get+       case FA.insLabel $ F.getAnnotation block of++         Just node+           | node `elem` visited ->+            -- This dependency has already been visited during this traversal+              pure M.empty+           | otherwise -> do+            -- Fresh dependency+            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+            dependencies <- mapM (genSubscripts' False flowsGraph) blocksFlowingIn+            return $ M.unionsWith (++) (genRHSsubscripts blockG : dependencies)++         Nothing -> error $ "Missing a label for: " ++ show block++-- | 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) =>+     FAD.InductionVarMapByASTBlock+  -> 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+    -- For debugging purposes+    errorMsg = show (FU.getSpan f)+            ++ " get IVs associated to labelled index "++{-| Given a list of induction variables and an index, compute+   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 _ (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 _ _ = 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+  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+              -> [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'++-- 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)+  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.ExpFunctionCall _ _+                      (F.ExpValue _ _ (F.ValIntrinsic iname)) subs)+        | iname `elem` ["modulo", "mod", "amod", "dmod"]+        -- We expect that the first parameter to modulo is being treated+        -- as an IxSingle element+        , Just (F.Argument _ _ _ e':_) <- fmap F.aStrip subs = e'+    replaceModulo e = e++    genRHSsubscripts' b =+       collect [ (FA.srcName exp, e)+         | F.ExpSubscript _ _ exp subs <- FA.rhsExprs b+         , isVariableExpr exp+         , let e = F.aStrip subs+         , not (null e)]++-- Given a list of induction variables and an expression, compute its+-- Neighbour representation+expToNeighbour :: forall a. Data a+            => [Variable] -> F.Expression (FA.Analysis a) -> Neighbour++expToNeighbour ivs e@(F.ExpValue _ _ v@(F.ValVariable _))+    | FA.varName e `elem` ivs = Neighbour (FA.varName e) 0+    | otherwise               = Constant (void v)++expToNeighbour _ (F.ExpValue _ _ val) = Constant (void val)++expToNeighbour ivs (F.ExpBinary _ _ F.Addition+                 e@(F.ExpValue _ _ (F.ValVariable _))+                   (F.ExpValue _ _ (F.ValInteger offs)))+    | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs)++expToNeighbour ivs (F.ExpBinary _ _ F.Addition+                  (F.ExpValue _ _ (F.ValInteger offs))+                e@(F.ExpValue _ _ (F.ValVariable _)))+    | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs)++expToNeighbour ivs (F.ExpBinary _ _ F.Subtraction+                 e@(F.ExpValue _ _ (F.ValVariable _))+                   (F.ExpValue _ _ (F.ValInteger offs)))+   | FA.varName e `elem` ivs =+         Neighbour (FA.varName e) (if x < 0 then abs x else (- x))+             where x = read offs++expToNeighbour ivs e =+  -- 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)]+                , let i = FA.varName e+                , i `elem` ivs]++indicesToRelativisedOffsets :: [Variable]+                            -> Variable+                            -> [Neighbour]+                            -> [[F.Index (FA.Analysis Annotation)]]+                            -> Writer EvalLog (Maybe (Bool, [[Int]]))+indicesToRelativisedOffsets ivs a lhs ixs = do+   -- Convert indices to neighbourhood representation+  let rhses = map (map (\ix -> convIxToNeighbour ivs ix) ) ixs++  -- As an optimisation, do duplicate check in front-end first+  -- so that duplicate indices don't get passed into the main engine+  let (rhses', mult) = hasDuplicates rhses++  -- Check that induction variables are used consistently on lhs and rhses+  if not (consistentIVSuse lhs rhses')+    then do tell [("EVALMODE: Inconsistent IV use (tag: inconsistentIV)", "")]+            return Nothing+    else+      -- For the EvalMode, if there are any non-neighbourhood relative+      -- subscripts detected then add this to the eval log+      if hasNonNeighbourhoodRelatives rhses'+      then do tell [("EVALMODE: Non-neighbour relative subscripts\+                    \ (tag: nonNeighbour)","")]+              return Nothing+      else do+        -- Relativize the offsets based on the lhs+        let rhses'' = relativise lhs rhses'+        when (rhses' /= rhses'') $+          tell [("EVALMODE: Relativized spec (tag: relativized)", "")]++        let offsets  = padZeros $ map (fromJust . mapM neighbourToOffset) rhses''+        tell [("EVALMODE: dimensionality=" +++                 show (if null offsets then 0 else length . head $ offsets), a)]+        return (Just (mult, offsets))+  where hasNonNeighbourhoodRelatives = any (elem NonNeighbour)++-- 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++{-| 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 _  (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++      relativiseBy v i (Neighbour u j) | v == u = Neighbour u (j - i)+      relativiseBy _ _ x = x++-- Helper predicates+isVariableExpr :: F.Expression a -> Bool+isVariableExpr (F.ExpValue _ _ (F.ValVariable _)) = True+isVariableExpr _                                  = False++-- Check that induction variables are used consistently+consistentIVSuse :: [Neighbour] -> [[Neighbour]] -> Bool+consistentIVSuse [] _ = True+consistentIVSuse _ [] = True+consistentIVSuse lhs rhses =+     isJust rhsBasis -- There is a consitent RHS+  && (all (`consistentWith` lhs) (fromJust rhsBasis)+   || all (`consistentWith` fromJust rhsBasis) lhs)+    where+      cmp (Neighbour v i) (Neighbour v' _) | v == v'   = Just $ Neighbour v i+                                           | otherwise = Nothing+      -- Cases for constants or non neighbour indices+      cmp n@Neighbour{}  (Constant _) = Just n+      cmp (Constant _) n@Neighbour{}  = Just n+      cmp NonNeighbour{} Neighbour{}  = Nothing+      cmp Neighbour{} NonNeighbour{}  = Nothing+      cmp _ _                         = Just $ Constant (F.ValInteger "")+      rhsBasis = foldrM (zipWithM cmp) (head rhses) (tail rhses)+      -- If there is an induction variable on the RHS, then it also occurs on+      -- the LHS+      consistentWith :: Neighbour -> [Neighbour] -> Bool+      consistentWith (Neighbour rv _) ns = any (matchesIV rv) ns+      consistentWith _                _  = True++      matchesIV :: Variable -> Neighbour -> Bool+      matchesIV v (Neighbour v' _) | v == v' = True+      -- All RHS to contain index ranges+      matchesIV v Neighbour{}      | v  == "" = True+      matchesIV _ (Neighbour v' _) | v' == "" = True+      matchesIV _ _                          = False++-- padZeros makes this rectilinear+padZeros :: [[Int]] -> [[Int]]+padZeros ixss = let m = maximum (map length ixss)+                in map (\ixs -> ixs ++ replicate (m - length ixs) 0) ixss++neighbourToOffset :: Neighbour -> Maybe Int+neighbourToOffset (Neighbour _ o) = Just o+neighbourToOffset (Constant _)    = Just absoluteRep+neighbourToOffset _               = Nothing
− src/Camfort/Specification/Stencils/Grammar.y 
@@ -1,252 +0,0 @@-{ -- -*- Mode: Haskell -*--{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}-module Camfort.Specification.Stencils.Grammar-( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where--import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace)-import Data.List (intersect, sort, isPrefixOf)-import Data.Data-import qualified Data.Text as T--import Debug.Trace--import Camfort.Analysis.CommentAnnotator-import Camfort.Specification.Stencils.Syntax (showL)--}--%monad { Either AnnotationParseError } { >>= } { return }-%name parseSpec SPEC-%tokentype { Token }-%token-  stencil     { TId "stencil" }-  region      { TId "region" }-  readOnce    { TId "readonce" }-  pointed     { TId "pointed" }-  nonpointed  { TId "nonpointed" }-  atMost      { TId "atmost" }-  atLeast     { TId "atleast" }-  dim         { TId "dim" }-  depth       { TId "depth" }-  forward     { TId "forward" }-  backward    { TId "backward" }-  centered    { TId "centered" }-  id          { TId $$ }-  num         { TNum $$ }-  '+'         { TPlus }-  '*'         { TStar }-  '::'        { TDoubleColon }-  '='         { TEqual }-  '('         { TLParen }-  ')'         { TRParen }--%left '+'-%left '*'--%%--SPEC :: { Specification }-: REGIONDEC                 { RegionDec (fst $1) (snd $1) }-| stencil SPECDEC '::' VARS { SpecDec $2 $4 }--REGIONDEC :: { (String, Region) }-: region '::' id '=' REGION { ($3, $5) }--REGION ::                       { Region }-: forward  '(' REGION_ATTRS ')' { applyAttr Forward  $3 }-| backward '(' REGION_ATTRS ')' { applyAttr Backward $3 }-| centered '(' REGION_ATTRS ')' { applyAttr Centered $3 }-| pointed  '(' dim '=' num ')' { Centered 0 (read $5) True }-| REGION '+' REGION             { Or $1 $3 }-| REGION '*' REGION             { And $1 $3 }-| '(' REGION ')'                { $2 }-| id                            { Var $1 }--REGION_ATTRS :: { (Depth Int, Dim Int, Bool) }-  : DEPTH DIM_REFL    { ($1, fst $2, snd $2) }-  | DIM   DEPTH_REFL  { (fst $2, $1, snd $2) }-  | REFL  DEPTH DIM   { ($2, $3, $1) }-  | REFL  DIM DEPTH   { ($3, $2, $1) }--DIM_REFL :: { (Dim Int, Bool) }-DIM_REFL-   : REFL DIM { ($2, $1) }-   | DIM REFL { ($1, $2) }-   | DIM      { ($1, True) }--DEPTH_REFL :: { (Depth Int, Bool) }-DEPTH_REFL-   : DEPTH REFL { ($1, $2) }-   | REFL DEPTH { ($2, $1) }-   | DEPTH      { ($1, True) }--DEPTH :: { Depth Int }-DEPTH : depth '=' num { Depth $ read $3 }--DIM :: { Dim Int }-DIM : dim '=' num { Dim $ read $3 }--REFL :: { Bool }- : nonpointed { False }--SPECDEC :: { Spec }-: APPROXMODS MOD REGION         { Spatial ($1 ++ [$2]) $3 }-| MOD REGION                    { Spatial [$1] $2 }-| APPROXMOD REGION               { Spatial [$1] $2 }-| REGION                         { Spatial [] $1 }--MOD :: { Mod }-: readOnce                          { ReadOnce }---- Even though multiple approx mods is not allowed--- allow them to be parsed so that the validator can--- report a nice error if the user supplies more than one-APPROXMODS :: { [Mod] }-: APPROXMOD APPROXMODS { $1 : $2 }-| APPROXMOD            { [$1] }--APPROXMOD :: { Mod }-: atMost                    { AtMost }-| atLeast                   { AtLeast }--VARS :: { [String] }-: id VARS { $1 : $2 }-| id      { [$1] }--{-newtype Depth a = Depth a-newtype Dim a = Dim a--applyAttr :: (Int -> Int -> Bool -> Region)-          -> (Depth Int, Dim Int, Bool)-          -> Region-applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl--data Specification-  = RegionDec String Region-  | SpecDec Spec [String]-  deriving (Show, Eq, Ord, Typeable, Data)--data Region-  = Forward Int Int Bool-  | Backward Int Int Bool-  | Centered Int Int Bool-  | Or Region Region-  | And Region Region-  | Var String-  deriving (Show, Eq, Ord, Typeable, Data)--data Spec = Spatial [Mod] Region-  deriving (Show, Eq, Ord, Typeable, Data)--data Mod-  = AtLeast-  | AtMost-  | ReadOnce-  deriving (Show, Eq, Ord, Typeable, Data)------------------------------------------------------data Token-  = TDoubleColon-  | TStar-  | TPlus-  | TEqual-  | TComma-  | TLParen-  | TRParen-  | TId String-  | TNum String- deriving (Show)--addToTokens :: Token -> String -> Either AnnotationParseError [ Token ]-addToTokens tok rest = do- tokens <- lexer' rest- return $ tok : tokens--lexer :: String -> Either AnnotationParseError [ Token ]-lexer input | length (stripLeadingWhiteSpace input) >= 2 =-  case stripLeadingWhiteSpace input of-    -- Check the leading character is '=' for specification-    '=':input' -> testAnnotation input'-    '!':input' -> testAnnotation input'-    '>':input' -> testAnnotation input'-    '<':input' -> testAnnotation input'-    _ -> Left NotAnnotation-  where-    stripLeadingWhiteSpace = T.unpack . T.strip . T.pack-    testAnnotation inp =-      -- First test to see if the input looks like an actual-      -- specification of either a stencil or region-      if (inp `hasPrefix` "stencil" || inp `hasPrefix` "region")-      then lexer' inp-      else Left NotAnnotation-    hasPrefix []       str = False-    hasPrefix (' ':xs) str = hasPrefix xs str-    hasPrefix xs       str = isPrefixOf str xs-lexer _ = Left NotAnnotation---lexer' :: String -> Either AnnotationParseError [ Token ]-lexer' []                                              = return []-lexer' (' ':xs)                                        = lexer' xs-lexer' ('\t':xs)                                       = lexer' xs-lexer' (':':':':xs)                                    = addToTokens TDoubleColon xs-lexer' ('*':xs)                                        = addToTokens TStar xs-lexer' ('+':xs)                                        = addToTokens TPlus xs-lexer' ('=':xs)                                        = addToTokens TEqual xs--- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead.-lexer' (',':xs)-  | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs')-  | otherwise                                         = addToTokens TComma xs-lexer' ('(':xs)                                        = addToTokens TLParen xs-lexer' (')':xs)                                        = addToTokens TRParen xs-lexer' (x:xs)-  | isLetter x                                        = aux TId $ \ c -> isAlphaNum c || c == '_'-  | isNumber x                                        = aux TNum isNumber-  | otherwise-     = failWith $ "Not an indentifier " ++ show x- where-   aux f p = (f target :) `fmap` lexer' rest-     where (target, rest) = span p (x:xs)-lexer' x-    = failWith $ "Not a valid piece of stencil syntax " ++ show x-------------------------------------------------------- specParser :: String -> Either AnnotationParseError Specification-specParser :: AnnotationParser Specification-specParser src = do- tokens <- lexer src- parseSpec tokens >>= modValidate---- Check whether modifiers are used correctly-modValidate :: Specification -> Either AnnotationParseError Specification-modValidate (SpecDec (Spatial mods r) vars) =-  do mods' <- modValidate' $ sort mods-     return $ SpecDec (Spatial mods' r) vars--  where    modValidate' [] = return $ []--           modValidate' (AtLeast : AtLeast : xs)-             = failWith "Duplicate 'atLeast' modifier; use at most one."--           modValidate' (AtMost : AtMost : xs)-             = failWith "Duplicate 'atMost' modifier; use at most one."--           modValidate' (ReadOnce : ReadOnce : xs)-             = failWith "Duplicate 'readOnce' modifier; use at most one."--           modValidate' (AtLeast : AtMost : xs)-             = failWith $ "Conflicting modifiers: cannot use 'atLeast' and "-                     ++ "'atMost' together"--           modValidate' (x : xs)-             = do xs' <- modValidate' xs-                  return $ x : xs'-modValidate x = return x--happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = failWith $ "Could not parse specification at: " ++ show t--}
src/Camfort/Specification/Stencils/InferenceBackend.hs view
@@ -18,7 +18,14 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -module Camfort.Specification.Stencils.InferenceBackend where+module Camfort.Specification.Stencils.InferenceBackend+  ( coalesce+  , containedWithin+  , inferFromIndicesWithoutLinearity+  , inferMinimalVectorRegions+  , spansToApproxSpatial+  , Span+  ) where  import Data.List import Data.Maybe@@ -26,7 +33,6 @@  import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.DenotationalSemantics-import Camfort.Helpers import qualified Camfort.Helpers.Vec as V  import Camfort.Specification.Stencils.Syntax@@ -76,21 +82,14 @@   where     (ys, zs) = mkTrivialSpan xs --- TODO: This seems completely redundant. Perhaps DELETE.-inferFromIndices :: V.VecList Int -> Specification-inferFromIndices (V.VL ixs) = Specification $-    case fromBool mult of-      Linear -> Once $ inferCore ixs'-      NonLinear -> Mult $ inferCore ixs'-    where-      (ixs', mult) = hasDuplicates ixs---- Same as inferFromIndices but don't do any linearity checking--- (defaults to NonLinear). This is used when the front-end does--- the linearity check first as an optimimsation.+{-| From a list of vectors of integers, representing relative offsets,+    generate a specification (but does not do any linearity checking)+    (defaults to Mult). Instead let the front-end does+    the linearity check first as an optimimsation.+    Also defaults to the specification being for a stencil -} inferFromIndicesWithoutLinearity :: V.VecList Int -> Specification inferFromIndicesWithoutLinearity (V.VL ixs) =-    Specification . Mult . inferCore $ ixs+    Specification (Mult . inferCore $ ixs) True  inferCore :: [V.Vec n Int] -> Approximation Spatial inferCore subs =@@ -128,6 +127,7 @@ sequenceMaybes xs | all (== Nothing) xs = Nothing                   | otherwise = Just (catMaybes xs) +{-| Coalesce two intervals of vectors into one, if they are contiguous -} coalesce :: Span (V.Vec n Int) -> Span (V.Vec n Int) -> Maybe (Span (V.Vec n Int)) coalesce (V.Nil, V.Nil) (V.Nil, V.Nil) = Just (V.Nil, V.Nil) -- If two well-defined intervals are equal, then they cannot be coalesced@@ -142,7 +142,9 @@     = Just (V.Cons l1 ls1, V.Cons u2 us2)   | (u2 + 1 == l1) && (us1 == us2) && (ls1 == ls2)     = Just (V.Cons l2 ls2, V.Cons u1 us1)-  | otherwise+-- Fall through (also catches cases where the initial size pre-condition+-- has been violated in a use of `Helpers.Vec.fromLists`+coalesce _ _     = Nothing  {-| Collapses the regions into a small set by looking for potential overlaps@@ -164,6 +166,8 @@   = True containedWithin (V.Cons l1 ls1, V.Cons u1 us1) (V.Cons l2 ls2, V.Cons u2 us2)   = (l2 <= l1 && u1 <= u2) && containedWithin (ls1, us1) (ls2, us2)+containedWithin _ _+  = False  -- Local variables: -- mode: haskell
src/Camfort/Specification/Stencils/InferenceFrontend.hs view
@@ -14,27 +14,35 @@    limitations under the License. -} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} -module Camfort.Specification.Stencils.InferenceFrontend where+module Camfort.Specification.Stencils.InferenceFrontend+  (+    -- * Datatypes and Aliases+    InferMode(..)+    -- * Functions+  , stencilInference+  ) where  import Control.Monad.State.Strict import Control.Monad.Reader import Control.Monad.Writer.Strict hiding (Product)  import Camfort.Analysis.CommentAnnotator-+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.Annotation ()-import qualified Camfort.Specification.Stencils.Grammar as Gram+import qualified Camfort.Specification.Stencils.Parser as Parser+import Camfort.Specification.Stencils.Parser.Types (SpecInner) import qualified Camfort.Specification.Stencils.Synthesis as Synth import Camfort.Analysis.Annotations import Camfort.Helpers (collect, descendReverseM, descendBiReverseM)@@ -43,7 +51,6 @@  import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.BBlocks as FAB import qualified Language.Fortran.Analysis.DataFlow as FAD import qualified Language.Fortran.Util.Position as FU@@ -53,14 +60,13 @@ import Data.Generics.Uniplate.Operations import Data.Graph.Inductive.Graph hiding (isEmpty) import qualified Data.Map as M-import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Maybe-import Debug.Trace+import Data.Monoid ((<>))  -- Define modes of interaction with the inference data InferMode =-  DoMode | AssignMode | CombinedMode | EvalMode | Synth+  AssignMode | EvalMode | Synth   deriving (Eq, Show, Data, Read)  instance Default InferMode where@@ -68,35 +74,61 @@  data InferState = IS {      ivMap        :: FAD.InductionVarMapByASTBlock-   , hasSpec      :: [(FU.SrcSpan, Variable)]    , visitedNodes :: [Int]} +data InferEnv = IE+  {+    -- | Known (existing) specifications.+    ieExistingSpecs :: [(Specification, FU.SrcSpan, Variable)]+  , ieFlowsGraph    :: FAD.FlowsGraph A+  , ieInferMode     :: InferMode+  , ieMarker        :: Char+  , ieMetaInfo      :: F.MetaInfo+  } + -- The inferer returns information as a LogLine-type EvalLog = [(String, Variable)] type LogLine = (FU.SrcSpan, Either [([Variable], Specification)] (String,Variable)) -- The core of the inferer works within this monad type Inferer = WriterT [LogLine]-                 (ReaderT (FAD.FlowsGraph A)+                 (ReaderT InferEnv                     (State InferState)) -type Params = (?flowsGraph :: FAD.FlowsGraph A, ?nameMap :: FAR.NameMap)--runInferer :: FAD.InductionVarMapByASTBlock+runInferer :: CheckResult+           -> InferMode+           -> Char+           -> F.MetaInfo+           -> FAD.InductionVarMapByASTBlock            -> FAD.FlowsGraph A            -> Inferer a            -> (a, [LogLine])-runInferer ivmap flTo =-    flip evalState (IS ivmap [] [])-  . flip runReaderT flTo+runInferer cr mode marker mi ivmap flTo =+    flip evalState (IS ivmap [])+  . flip runReaderT env   . runWriterT+  where env = IE+          { ieExistingSpecs = existingStencils cr+          , ieFlowsGraph    = flTo+          , ieInferMode     = mode+          , ieMarker        = marker+          , ieMetaInfo      = mi+          } -stencilInference :: FAR.NameMap-                 -> InferMode+-- | Attempt to convert a 'Parser.Specification' into a 'Specification'.+--+-- Only performs conversions for spatial specifications.+specToSynSpec :: SpecInner -> Maybe Specification+specToSynSpec spec = let ?renv = [] in+                       case synToAst spec of+                         Left err -> Nothing+                         Right x  -> Just x++-- | Main stencil inference code+stencilInference :: InferMode                  -> Char                  -> F.ProgramFile (FA.Analysis A)                  -> (F.ProgramFile (FA.Analysis A), [LogLine])-stencilInference nameMap mode marker pf =+stencilInference mode marker pf =     (F.ProgramFile mi pus', log1)   where     -- Parse specification annotations and include them into the syntax tree@@ -104,550 +136,158 @@     -- decide whether to synthesise or not      -- TODO: might want to output log0 somehow (though it doesn't fit LogLine)-    (pf'@(F.ProgramFile mi pus), log0) =+    (pf'@(F.ProgramFile mi pus), _log0) =          if mode == Synth-          then runWriter (annotateComments Gram.specParser pf)+          then runWriter (annotateComments Parser.specParser (const . const . pure $ ()) pf)           else (pf, [])      (pus', log1)    = runWriter (transformBiM perPU pus)+    checkRes        = stencilChecking pf -    -- Run inference per program unit, placing the flowsmap in scope+    -- Run inference per program unit     perPU :: F.ProgramUnit (FA.Analysis A)           -> Writer [LogLine] (F.ProgramUnit (FA.Analysis A)) -    perPU pu | Just _ <- FA.bBlocks $ F.getAnnotation pu =-         let ?flowsGraph = flTo-             ?nameMap    = nameMap-         in do-              let pum = descendBiM (perBlockInfer mode marker) pu-              let (pu', log) = runInferer ivMap flTo pum-              tell log-              return pu'-    perPU pu = return pu+    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 -    -- induction variable map-    ivMap = FAD.genInductionVarMapByASTBlock beMap gr-    -- perform reaching definitions analysis-    rd    = FAD.reachingDefinitions dm gr-    -- create graph of definition "flows"-    flTo =  FAD.genFlowsToGraph bm dm gr rd+            -- perform reaching definitions analysis+            rd = FAD.reachingDefinitions dm gr -    -- identify every loop by its back-edge-    beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr+            Just gr = M.lookup (FA.puName pu) bbm+            -- create graph of definition "flows"+            flTo = FAD.genFlowsToGraph bm dm gr rd +            -- induction variable map+            beMap = FAD.genBackEdgeMap (FAD.dominators gr) gr++            -- identify every loop by its back-edge+            ivMap = FAD.genInductionVarMapByASTBlock beMap gr++            (pu', log) = runInferer checkRes mode marker mi ivMap flTo pum+        tell log+        return pu'++    perPU pu = return pu+     -- 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  {- *** 1 . Core inference over blocks -} -genSpecsAndReport :: Params-  => InferMode -> FU.SrcSpan -> [Neighbour]-  -> [F.Block (FA.Analysis A)]+genSpecsAndReport ::+     FU.SrcSpan -> [Neighbour]+  -> F.Block (FA.Analysis A)   -> Inferer [([Variable], Specification)]-genSpecsAndReport mode span lhs blocks = do-    (IS ivmap _ _) <- get-    let ((specs, visited), evalInfos) = runWriter $ genSpecifications ivmap lhs blocks-    modify (\state -> state { visitedNodes = (visitedNodes state) ++ visited })-    tell [ (span, Left specs) ]-    if mode == EvalMode-      then do-         tell [ (span, Right ("EVALMODE: assign to relative array subscript\-                              \ (tag: tickAssign)","")) ]-         mapM_ (\evalInfo -> tell [ (span, Right evalInfo) ]) evalInfos-         mapM_ (\spec -> if show spec == ""-                          then tell [ (span, Right ("EVALMODE: Cannot make spec\-                                                   \ (tag: emptySpec)","")) ]-                          else return ()) specs-         return specs-      else return specs -+genSpecsAndReport span lhsIxs block = do+  -- Get the induction variables relative to the current block+  (IS ivmap _) <- get+  let ivs = extractRelevantIVS ivmap block --- 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.ExpSubscript _ _ (F.ExpValue _ _ (F.ValVariable _)) subs) =-   Just $ F.aStrip subs-isArraySubscript (F.ExpDataRef _ _ e e') = do-   isArraySubscript e <++> isArraySubscript e'- where-   Nothing <++> Nothing = Nothing-   Nothing <++> Just xs = Just xs-   Just xs <++> Nothing  = Just xs-   Just xs <++> Just ys  = Just (xs ++ ys)-isArraySubscript _ = Nothing+  mode         <- fmap ieInferMode ask+  flowsGraph   <- fmap ieFlowsGraph ask+  -- Generate specification for the+  let ((specs, visited), evalInfos) = runWriter $ genSpecifications flowsGraph ivs lhsIxs block+  -- Remember which nodes were visited during this traversal+  modify (\state -> state { visitedNodes = visitedNodes state ++ visited })+  -- Report the specifications+  tell [ (span, Left specs) ] -fromJustMsg _ (Just x) = x-fromJustMsg msg Nothing = error msg+  -- Evaluation mode information reporting:+  when (mode == EvalMode) $ do+    tell [ (span, Right ("EVALMODE: assign to relative array subscript\+                         \ (tag: tickAssign)","")) ]+    forM_ evalInfos $ \evalInfo ->+      tell [ (span, Right evalInfo) ]+    forM_ specs $ \spec ->+      when (show spec == "") $+      tell [ (span, Right ("EVALMODE: Cannot make spec\+                           \ (tag: emptySpec)","")) ]+  return specs  -- Traverse Blocks in the AST and infer stencil specifications-perBlockInfer :: Params-               => InferMode -> Char -> F.Block (FA.Analysis A)-               -> Inferer (F.Block (FA.Analysis A))--perBlockInfer Synth _ b@(F.BlComment ann _ _) = do-  -- If we have a comment that is actually a specification then record that-  -- this has been assigned so that we don't generate extra specifications-  -- that overlap with user-given oones-  ann' <- return $ FA.prevAnnotation ann-  -- Check if we have a spec-  case (stencilSpec ann', stencilBlock ann') of-    -- Comment contains an (uncoverted) specification and an associated block-    (Just (Left (Gram.SpecDec _  vars)), Just block) ->-     -- Is the block an assignment-     case block of-      F.BlStatement _ span _ F.StExpressionAssign{} -> do-         -- Then update the list of spans+vars that have specifications-         state <- get-         put (state { hasSpec = hasSpec state ++ zip (repeat span) vars })-    _ -> return ()-  return b--perBlockInfer mode marker b@(F.BlStatement ann span@(FU.SrcSpan lp _) _ stmnt)-  | mode == AssignMode || mode == CombinedMode || mode == EvalMode || mode == Synth = do--    (IS ivmap hasSpec visitedStmts) <- get-    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....-      let lhses = [lhs | (F.StExpressionAssign _ _ lhs _)-                           <- universe stmnt :: [F.Statement (FA.Analysis A)]]-      specs <- forM lhses $ \lhs -> do-         -- ... apply the following:-         case lhs of-          -- Assignment to a variable-          (F.ExpValue _ _ (F.ValVariable v)) -> genSpecsAndReport mode span [] [b]-          _ -> 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 mode span lhs [b]-                 Nothing  -> if mode == EvalMode-                             then do-                               tell [(span , Right ("EVALMODE: LHS is an array\-                                                   \ subscript we can't handle \-                                                   \(tag: LHSnotHandled)",""))]-                               return []-                             else return []-             -- Not an assign we are interested in-             _ -> return []-      if mode == Synth && not (null specs) && specs /= [[]]-      then-        let specComment = Synth.formatSpec (Just (tabs ++ '!':marker:" ")) ?nameMap (span, Left (concat specs'))-            specs' = map (mapMaybe noSpecAlready) specs-            noSpecAlready (vars, spec) =-               if null vars'-               then Nothing-               else Just (vars', spec)-               where vars' = filter (\v -> not ((span, realName v) `elem` hasSpec)) vars-            realName v = v `fromMaybe` (v `M.lookup` ?nameMap)-            tabs  = take (FU.posColumn lp  - 1) (repeat ' ')-            (FU.SrcSpan loc _) = span-            span' = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0})-            ann'  = ann { FA.prevAnnotation = (FA.prevAnnotation ann) { refactored = Just loc } }-        in return $ F.BlComment ann' span' (F.Comment specComment)-      else return b--perBlockInfer mode marker b@(F.BlDo ann span lab cname lab' mDoSpec body tlab) = do-    if (mode == DoMode || mode == CombinedMode) && isStencilDo b-      then genSpecsAndReport mode span [] body-      else return []--    -- descend into the body of the do-statement (in reverse order)-    body' <- mapM (descendBiReverseM (perBlockInfer mode marker)) (reverse body)-    return $ F.BlDo ann span lab cname lab' mDoSpec body' tlab--perBlockInfer mode marker b = do-    -- Go inside child blocks-    b' <- descendReverseM (descendBiReverseM (perBlockInfer mode marker)) $ b-    return b'---- Combiantor 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 <- sequence . map strength . M.toList $ maps-    return . catMaybes . map strength $ assocs-  where-    strength :: Monad m => (a, m b) -> m (a, b)-    strength (a, mb) = mb >>= (\b -> return (a, b))--genSpecifications :: Params-  => FAD.InductionVarMapByASTBlock-  -> [Neighbour]-  -> [F.Block (FA.Analysis A)]-  -> Writer EvalLog ([([Variable], Specification)], [Int])-genSpecifications ivs lhs blocks = do-    let (subscripts, visitedNodes) = subscriptsOnRhs ?nameMap blocks-    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)--      splitUpperAndLower = concatMap splitUpperAndLower'-      splitUpperAndLower' (vs, Specification (Mult (Bound (Just l) (Just u))))-        | isUnit l =-         [(vs, Specification (Mult (Bound Nothing (Just u))))]-        | otherwise =-         [(vs, Specification (Mult (Bound (Just l) Nothing))),-          (vs, Specification (Mult (Bound Nothing (Just u))))]-      splitUpperAndLower' (vs, Specification (Once (Bound (Just l) (Just u))))-        | isUnit l =-         [(vs, Specification (Mult (Bound Nothing (Just u))))]-        | otherwise =-         [(vs, Specification (Once (Bound (Just l) Nothing))),-          (vs, Specification (Once (Bound Nothing (Just u))))]-      splitUpperAndLower' x = [x]--{-| subscriptsOnRhs-   Takes * a name map-         * 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 -}-subscriptsOnRhs :: Params-  => FAR.NameMap-  -> [F.Block (FA.Analysis A)]-  -> (M.Map Variable [[F.Index (FA.Analysis A)]], [Int])-subscriptsOnRhs nameMap blocks =-    (subscripts', visitedNodes)-  where-    (maps, visitedNodes) = runState (mapM (genSubscripts True) blocks) []-    subscripts = M.unionsWith (++) maps-    subscripts' = filterOutFuns ?nameMap subscripts--genOffsets :: Params-  => FAD.InductionVarMapByASTBlock-  -> [Neighbour]-  -> [F.Block (FA.Analysis A)]-  -> Writer EvalLog [(Variable, (Bool, [[Int]]))]-genOffsets ivs lhs blocks = do-    let (subscripts, _) = subscriptsOnRhs ?nameMap blocks-    assocsSequence $ mkOffsets subscripts-  where-    mkOffsets = M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs)----- Filter out any variable names which do not appear in the name map or--- which in appear in the name map with the same name, indicating they--- are an instric function, e.g., abs-filterOutFuns nameMap m =-  M.filterWithKey (\k _ ->-     case k `M.lookup` nameMap of-        Nothing           -> False-        Just k' | k == k' -> False-        _                 -> True) m---- 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 :: Params-  => Bool-  -> F.Block (FA.Analysis A)-  -> State [Int] (M.Map Variable [[F.Index (FA.Analysis A)]])-genSubscripts False (F.BlStatement _ _ _ (F.StExpressionAssign _ _ e _))-    | isArraySubscript e /= Nothing-    -- Don't pull dependencies through arrays-    = return M.empty--genSubscripts _ block = do-    visited <- get-    case (FA.insLabel $ F.getAnnotation block) of--      Just node-        | node `elem` visited ->-          -- This dependency has already been visited during this traversal-          return $ M.empty-        | otherwise -> do-          -- Fresh dependency-          put $ node : visited-          let blocksFlowingIn = mapMaybe (lab ?flowsGraph) $ pre ?flowsGraph node-          dependencies <- mapM (genSubscripts False) blocksFlowingIn-          return $ M.unionsWith (++) (genRHSsubscripts block : dependencies)--      Nothing -> error $ "Missing a label for: " ++ show block---- Get all RHS subscript which are translated induction variables--- return as a map from (program) variables to a list of relative indices and--- a flag marking whether there are any duplicate indices-genRHSsubscripts ::-     F.Block (FA.Analysis A)-  -> M.Map Variable [[F.Index (FA.Analysis A)]]-genRHSsubscripts b = genRHSsubscripts' (transformBi replaceModulo b)-  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 e@(F.ExpFunctionCall _ _-                      (F.ExpValue _ _ (F.ValIntrinsic iname)) subs)-        | iname `elem` ["modulo", "mod", "amod", "dmod"]-        -- We expect that the first parameter to modulo is being treated-        -- as an IxSingle element-        , Just (F.Argument _ _ _ e':_) <- fmap F.aStrip subs = e'-    replaceModulo e = e--    genRHSsubscripts' b =-       collect [ (FA.varName exp, e)-         | F.ExpSubscript _ _ exp subs <- FA.rhsExprs b-         , isVariableExpr exp-         , let e = F.aStrip subs-         , not (null e)]--getInductionVar :: Maybe (F.DoSpecification (FA.Analysis A)) -> [Variable]-getInductionVar (Just (F.DoSpecification _ _ (F.StExpressionAssign _ _ e _) _ _))-  | isVariableExpr e = [FA.varName e]-getInductionVar _ = []--isStencilDo :: F.Block (FA.Analysis A) -> Bool-isStencilDo (F.BlDo _ _ _ _ _ mDoSpec body _) =- -- Check to see if the body contains any affine use of the induction variable- -- as a subscript- case getInductionVar mDoSpec of-    [] -> False-    [ivar] -> length exprs > 0 &&-               and [ all (\sub -> sub `isNeighbour` [ivar]) subs' |-               F.ExpSubscript _ _ _ subs <- exprs-               , let subs' = F.aStrip subs-               , not (null subs') ]-      where exprs = universeBi upToNextDo :: [F.Expression (FA.Analysis A)]-            upToNextDo = takeWhile (not . isDo) body-            isDo (F.BlDo {}) = True-            isDo _            = False-isStencilDo _  = False--{- *** 2 .Conversion from indexing expressions -}---- padZeros makes this rectilinear-padZeros :: [[Int]] -> [[Int]]-padZeros ixss = let m = maximum (map length ixss)-                in map (\ixs -> ixs ++ replicate (m - length ixs) 0) ixss---- Convert list of indexing expressions to a spec-indicesToSpec :: FAD.InductionVarMapByASTBlock-              -> 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-    let spec = relativeIxsToSpec offsets-    fmap (setLinearity (fromBool mult)) spec--indicesToRelativisedOffsets :: FAD.InductionVarMapByASTBlock-                            -> Variable-                            -> [Neighbour]-                            -> [[F.Index (FA.Analysis Annotation)]]-                            -> Writer EvalLog (Maybe (Bool, [[Int]]))-indicesToRelativisedOffsets ivs a lhs ixs = do-   -- Convert indices to neighbourhood representation-  let rhses = map (map (ixToNeighbour ivs)) ixs--  -- As an optimisation, do duplicate check in front-end first-  -- so that duplicate indices don't get passed into the main engine-  let (rhses', mult) = hasDuplicates rhses--  -- Check that induction variables are used consistently on lhs and rhses-  if not (consistentIVSuse lhs rhses')-    then do tell [("EVALMODE: Inconsistent IV use (tag: inconsistentIV)", "")]-            return Nothing-    else-      -- For the EvalMode, if there are any non-neighbourhood relative-      -- subscripts detected then add this to the eval log-      if hasNonNeighbourhoodRelatives rhses'-      then do tell [("EVALMODE: Non-neighbour relative subscripts\-                    \ (tag: nonNeighbour)","")]-              return Nothing-      else do-        -- Relativize the offsets based on the lhs-        let rhses'' = relativise lhs rhses'-        if rhses' /= rhses''-          then  tell [("EVALMODE: Relativized spec (tag: relativized)", "")]-          else return ()--        let offsets  = padZeros $ map (fromJust . mapM neighbourToOffset) rhses''-        tell [("EVALMODE: dimensionality=" ++-                 show (if null offsets then 0 else length . head $ offsets), a)]-        return (Just $ (mult, offsets))-  where hasNonNeighbourhoodRelatives xs = or (map (any ((==) NonNeighbour)) xs)----- 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--      relativiseBy v i (Neighbour u j) | v == u = Neighbour u (j - i)-      relativiseBy _ _ x = x---- Check that induction variables are used consistently-consistentIVSuse :: [Neighbour] -> [[Neighbour]] -> Bool-consistentIVSuse [] _ = True-consistentIVSuse _ [] = True-consistentIVSuse lhs rhses =-     rhsBasis /= Nothing  -- There is a consitent RHS-  && (all (`consistentWith` lhs) (fromJust rhsBasis)-   || all (`consistentWith` (fromJust rhsBasis)) lhs)-    where-      cmp (Neighbour v i) (Neighbour v' _) | v == v'   = Just $ Neighbour v i-                                           | otherwise = Nothing-      -- Cases for constants or non neighbour indices-      cmp n@(Neighbour {})  (Constant _)   = Just n-      cmp (Constant _) n@(Neighbour {})    = Just n-      cmp (NonNeighbour {}) (Neighbour {}) = Nothing-      cmp (Neighbour {}) (NonNeighbour{})  = Nothing-      cmp _ _                              = Just $ Constant (F.ValInteger "")-      rhsBasis = foldrM (\a b -> mapM (uncurry cmp) $ zip a b) (head rhses) (tail rhses)-      -- If there is an induction variable on the RHS, then it also occurs on-      -- the LHS-      consistentWith :: Neighbour -> [Neighbour] -> Bool-      consistentWith (Neighbour rv _) ns = any (matchesIV rv) ns-      consistentWith _                _  = True--      matchesIV :: Variable -> Neighbour -> Bool-      matchesIV v (Neighbour v' _) | v == v' = True-      -- All RHS to contain index ranges-      matchesIV v Neighbour{}      | v  == "" = True-      matchesIV _ (Neighbour v' _) | v' == "" = True-      matchesIV _ _                          = False---- 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--isNeighbour :: Data a => F.Index (FA.Analysis a) -> [Variable] -> Bool-isNeighbour exp vs =-    case (ixToNeighbour' vs exp) of-        Neighbour _ _ -> True-        _             -> False---- Given a list of induction variables and a list of indices--- map them to a list of constant or neighbourhood indices--- if any are non neighbourhood then return Nothi ng-neighbourIndex :: FAD.InductionVarMapByASTBlock-               -> [F.Index (FA.Analysis Annotation)] -> Maybe [Neighbour]-neighbourIndex ivs ixs =-  if all ((/=) NonNeighbour) neighbours-  then Just neighbours-  else Nothing-    where neighbours = map (ixToNeighbour ivs) ixs+perBlockInfer :: F.Block (FA.Analysis A)+              -> Inferer (F.Block (FA.Analysis A))+perBlockInfer = perBlockInfer' False+-- The primed version, perBlockInfer' has a flag indicating whether+-- the following code is inside a do-loop since we only target+-- array computations inside loops. --- Representation for indices as either:---   * neighbour indices---   * constant---   * non neighbour index-data Neighbour = Neighbour Variable Int-               | Constant (F.Value ())-               | NonNeighbour deriving (Eq, Show)+perBlockInfer' _ b@F.BlComment{} = pure b -neighbourToOffset :: Neighbour -> Maybe Int-neighbourToOffset (Neighbour _ o) = Just o-neighbourToOffset (Constant _)    = Just absoluteRep-neighbourToOffset _               = Nothing+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+    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 --- Given a list of induction variables and an index, compute--- 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)+          noSpecAlready (vars, spec) =+            if null vars'+            then Nothing+            else Just (vars', spec)+            where vars' = filter (\v -> (spec, span, v) `notElem` userSpecs) vars -ixToNeighbour :: FAD.InductionVarMapByASTBlock-              -> F.Index (FA.Analysis Annotation) -> Neighbour--- Range with stride = 1 and no explicit bounds count as reflexive indexing-ixToNeighbour ivmap f = ixToNeighbour' ivsList f+          -- 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   where-    insl = FA.insLabel . F.getAnnotation $ f-    errorMsg = show (ixsspan f)-            ++ " get IVs associated to labelled index "-            ++ show insl-    insl' = fromJustMsg errorMsg insl-    ivsList = S.toList $ fromMaybe S.empty $ IM.lookup insl'  ivmap-    -- For debugging purposes-    ixsspan :: F.Index (FA.Analysis A)  -> FU.SrcSpan-    ixsspan  (F.IxRange _ sp _ _ _) = sp-    ixsspan (F.IxSingle _ sp _ _ ) = sp--ixToNeighbour' _ (F.IxRange _ _ Nothing Nothing Nothing)     = Neighbour "" 0-ixToNeighbour' _ (F.IxRange _ _ Nothing Nothing-                  (Just (F.ExpValue _ _ (F.ValInteger "1")))) = Neighbour "" 0--ixToNeighbour' ivs (F.IxSingle _ _ _ exp)  = expToNeighbour ivs exp-ixToNeighbour' _ _ = NonNeighbour -- indexing expression is a range---- Given a list of induction variables and an expression, compute its--- Neighbour representation-expToNeighbour :: forall a. Data a-            => [Variable] -> F.Expression (FA.Analysis a) -> Neighbour--expToNeighbour ivs e@(F.ExpValue _ _ v@(F.ValVariable _))-    | FA.varName e `elem` ivs = Neighbour (FA.varName e) 0-    | otherwise               = Constant (fmap (const ()) v)--expToNeighbour _ (F.ExpValue _ _ val) = Constant (fmap (const ()) val)--expToNeighbour ivs (F.ExpBinary _ _ F.Addition-                 e@(F.ExpValue _ _ (F.ValVariable _))-                   (F.ExpValue _ _ (F.ValInteger offs)))-    | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs)--expToNeighbour ivs (F.ExpBinary _ _ F.Addition-                  (F.ExpValue _ _ (F.ValInteger offs))-                e@(F.ExpValue _ _ (F.ValVariable _)))-    | FA.varName e `elem` ivs = Neighbour (FA.varName e) (read offs)+    -- Assignment to a variable+    genSpecsFor _ _ (F.ExpValue _ _ (F.ValVariable _)) | inDo = genSpecsAndReport span [] b+    -- Assignment to something else...+    genSpecsFor ivmap mode 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 []+        -- Not an assign we are interested in+        _ -> pure [] -expToNeighbour ivs (F.ExpBinary _ _ F.Subtraction-                 e@(F.ExpValue _ _ (F.ValVariable _))-                   (F.ExpValue _ _ (F.ValInteger offs)))-   | FA.varName e `elem` ivs =-         Neighbour (FA.varName e) (if x < 0 then abs x else (- x))-             where x = read offs+perBlockInfer' _ b@(F.BlDo ann span lab cname lab' mDoSpec body tlab) = do+  -- descend into the body of the do-statement (in reverse order)+  body' <- mapM (descendBiReverseM (perBlockInfer' True)) (reverse body)+  return $ F.BlDo ann span lab cname lab' mDoSpec (reverse body') tlab -expToNeighbour ivs e =-  -- 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)]-                , let i = FA.varName e-                , i `elem` ivs]+perBlockInfer' inDo b =+  -- Go inside child blocks+  descendReverseM (descendBiReverseM (perBlockInfer' inDo)) b  -------------------------------------------------- --- Helper predicates-isUnaryOrBinaryExpr :: F.Expression a -> Bool-isUnaryOrBinaryExpr (F.ExpUnary {})  = True-isUnaryOrBinaryExpr (F.ExpBinary {}) = True-isUnaryOrBinaryExpr _                = False--isVariableExpr :: F.Expression a -> Bool-isVariableExpr (F.ExpValue _ _ (F.ValVariable _)) = True-isVariableExpr _                                  = False-+-- Cute <3 -- Penelope's first code, 20/03/2016. -- iii././//////////////////////. mvnmmmmmmmmmu
src/Camfort/Specification/Stencils/Model.hs view
@@ -65,7 +65,6 @@  import qualified Camfort.Helpers.Vec as V import System.IO.Unsafe-import Debug.Trace  -- Utility container class Container a where@@ -279,11 +278,11 @@                  Nothing -> fail                     "Impossible: Counter example size doesn't \                     \match the original vector size."-        else "EQ branch" `trace` return EQ+        else return EQ   where     counterExample :: ThmResult -> IO [ Int64 ]     counterExample thmRes =-      case getModel thmRes of+      case getModelAssignment thmRes of         Right (False, ce) -> return ce         Right (True, _) -> fail "Returned probable model."         Left str -> fail str
+ src/Camfort/Specification/Stencils/Parser.y view
@@ -0,0 +1,222 @@+{++module Camfort.Specification.Stencils.Parser+  ( specParser+  , SpecParseError+  ) where++import Control.Monad.Except (throwError)+import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace)+import Data.List (intercalate, isInfixOf)++import           Camfort.Specification.Parser+  (SpecParser, mkParser)+import           Camfort.Specification.Stencils.Model+  (Approximation(..), Multiplicity(..))+import           Camfort.Specification.Stencils.Parser.Types+import qualified Camfort.Specification.Stencils.Syntax as Syn++}++%monad { StencilSpecParser } { >>= } { return }+%name parseSpecification SPEC+%tokentype { Token }+%token+  stencil     { TId _ "stencil" }+  access      { TId _ "access" }+  region      { TId _ "region" }+  readOnce    { TId _ "readonce" }+  pointed     { TId _ "pointed" }+  nonpointed  { TId _ "nonpointed" }+  atMost      { TId _ "atmost" }+  atLeast     { TId _ "atleast" }+  dim         { TId _ "dim" }+  depth       { TId _ "depth" }+  forward     { TId _ "forward" }+  backward    { TId _ "backward" }+  centered    { TId _ "centered" }+  id          { TId _ $$ }+  num         { TNum $$ }+  '+'         { TPlus }+  '*'         { TStar }+  '::'        { TDoubleColon }+  '='         { TEqual }+  '('         { TLParen }+  ')'         { TRParen }++%left '+'+%left '*'++%%++SPEC :: { Specification }+: REGIONDEC                 { RegionDec (fst $1) (snd $1) }+| stencil SPECDEC '::' VARS { SpecDec ($2 True) $4 }+| access  SPECDEC '::' VARS { SpecDec ($2 False) $4 }++REGIONDEC :: { (String, Region) }+: region '::' id '=' REGION { ($3, $5) }++REGION ::                       { Region }+: REGIONCONST                   { RegionConst $1 }+| REGION '+' REGION             { Or $1 $3 }+| REGION '*' REGION             { And $1 $3 }+| '(' REGION ')'                { $2 }+| id                            { Var $1 }++REGIONCONST :: { Syn.Region }+: forward  '(' REGION_ATTRS ')' { applyAttr Syn.Forward  $3 }+| backward '(' REGION_ATTRS ')' { applyAttr Syn.Backward $3 }+| centered '(' REGION_ATTRS ')' { applyAttr Syn.Centered $3 }+| pointed  '(' dim '=' num ')'  { Syn.Centered 0 (read $5) True }++REGION_ATTRS :: { (Depth Int, Dim Int, Bool) }+  : DEPTH DIM_REFL    { ($1, fst $2, snd $2) }+  | DIM   DEPTH_REFL  { (fst $2, $1, snd $2) }+  | REFL  DEPTH DIM   { ($2, $3, $1) }+  | REFL  DIM DEPTH   { ($3, $2, $1) }++DIM_REFL :: { (Dim Int, Bool) }+DIM_REFL+   : REFL DIM { ($2, $1) }+   | DIM REFL { ($1, $2) }+   | DIM      { ($1, True) }++DEPTH_REFL :: { (Depth Int, Bool) }+DEPTH_REFL+   : DEPTH REFL { ($1, $2) }+   | REFL DEPTH { ($2, $1) }+   | DEPTH      { ($1, True) }++DEPTH :: { Depth Int }+DEPTH : depth '=' num { Depth $ read $3 }++DIM :: { Dim Int }+DIM : dim '=' num { Dim $ read $3 }++REFL :: { Bool }+ : nonpointed { False }++SPECDEC :: { Syn.IsStencil -> SpecInner }+: MULTIPLICITY { SpecInner $1 }++MULTIPLICITY ::          { Multiplicity (Approximation Region) }+: readOnce APPROXIMATION { Once $2 }+| APPROXIMATION          { Mult $1 }++APPROXIMATION :: { Approximation Region }+: atLeast REGION { Bound (Just $2) Nothing }+| atMost REGION  { Bound Nothing (Just $2) }+| REGION         { Exact $1 }++VARS :: { [String] }+: id VARS { $1 : $2 }+| id      { [$1] }++{++-- ** Errors++data SpecParseError+  -- | Not a valid identifier character.+  = NotAnIdentifier Char+  -- | Tokens do not represent a syntactically valid specification.+  | CouldNotParseSpecification [Token]+  deriving (Eq)++instance Show SpecParseError where+  show (CouldNotParseSpecification ts) =+    "Could not parse specification at: \"" ++ prettyTokens ts ++ "\"\n"+  show (NotAnIdentifier c) = "Invalid character in identifier: " ++ show c++notAnIdentifier :: Char -> SpecParseError+notAnIdentifier = NotAnIdentifier++couldNotParseSpecification :: [Token] -> SpecParseError+couldNotParseSpecification = CouldNotParseSpecification++type StencilSpecParser a = Either SpecParseError a++newtype Depth a = Depth a+newtype Dim a = Dim a++applyAttr :: (Int -> Int -> Bool -> Syn.Region)+          -> (Depth Int, Dim Int, Bool)+          -> Syn.Region+applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl++data Token+  = TDoubleColon+  | TStar+  | TPlus+  | TEqual+  | TComma+  | TLParen+  | TRParen+  | TId String String -- first string contains the original text+                      -- second is normalised (e.g., for keywords)+  | TNum String+ deriving (Show, Eq)++addToTokens :: Token -> String -> StencilSpecParser [ Token ]+addToTokens tok rest = do+ tokens <- lexer rest+ return $ tok : tokens++lexer :: String -> StencilSpecParser [ Token ]+lexer []                                              = return []+lexer (' ':xs)                                        = lexer xs+lexer ('\t':xs)                                       = lexer xs+lexer (':':':':xs)                                    = addToTokens TDoubleColon xs+lexer ('*':xs)                                        = addToTokens TStar xs+lexer ('+':xs)                                        = addToTokens TPlus xs+lexer ('=':xs)                                        = addToTokens TEqual xs+-- Comma hack: drop commas that are not separating numbers,+-- in order to avoid need for 2-token lookahead.+lexer (',':xs)+  | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer (x':xs')+  | otherwise                                         = addToTokens TComma xs+lexer ('(':xs)                                       = addToTokens TLParen xs+lexer (')':xs)                                       = addToTokens TRParen xs+lexer (x:xs)+  | isLetter x                                        =+        aux (\x -> TId x $ fmap toLower x) $ \ c -> isAlphaNum c || c == '_'+  | isPositiveNumber x                                = aux TNum isNumber+  | otherwise+     = throwError $ notAnIdentifier x+ where+   isPositiveNumber x = isNumber x && x /= '0'+   aux f p = (f target :) <$> lexer rest+     where (target, rest) = span p (x:xs)++specParser :: SpecParser SpecParseError Specification+specParser = mkParser (\src -> do+                          tokens <- lexer src+                          parseSpecification tokens)+             ["stencil", "region", "access"]++happyError :: [ Token ] -> StencilSpecParser a+happyError = throwError . couldNotParseSpecification++-- | Pretty-print the tokens, showing the smallest unique prefix of tokens+prettyTokens :: [ Token ] -> String+prettyTokens =+    (++ "... ") . intercalate " " . map prettyToken . takeUniquePrefix 1+  where+    takeUniquePrefix _ [] = []+    takeUniquePrefix n ts =+      if ((take n ts) `isInfixOf` (drop n ts))+      then takeUniquePrefix (n+1) ts+      else take n ts++prettyToken TDoubleColon = "::"+prettyToken TStar        = "*"+prettyToken TPlus        = "+"+prettyToken TEqual       = "="+prettyToken TComma       = ","+prettyToken TLParen      = "("+prettyToken TRParen      = ")"+prettyToken (TId s _)    = s+prettyToken (TNum n)     = n++}
+ src/Camfort/Specification/Stencils/Parser/Types.hs view
@@ -0,0 +1,62 @@+{- |+Module      :  Camfort.Specification.Stencils.Parser.Types+Description :  Defines the representation of stencil specifications resulting from parsing.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++{-# LANGUAGE DeriveDataTypeable #-}++module Camfort.Specification.Stencils.Parser.Types+  ( Specification(..)+  , Region(..)+  , SpecInner(..)+  , reqRegions+  ) where++import Data.Data (Data, Typeable)+import Data.List (nub, sort)++import           Camfort.Specification.Stencils.Model+  (Approximation(..), Multiplicity(..))+import qualified Camfort.Specification.Stencils.Syntax as Syn++data Specification+  = RegionDec String Region+  | SpecDec SpecInner [String]+  deriving (Show, Eq, Typeable, Data)++-- | Regions that are referenced in a specification.+reqRegions :: Specification -> [Syn.Variable]+reqRegions spec = nub . sort $+  case spec of+    RegionDec _ r             -> reqRegions' r+    SpecDec (SpecInner x _) _ ->+      case x of+        Once a -> reqRegionsApprox a+        Mult a -> reqRegionsApprox a+  where+    reqRegionsApprox (Exact r) = reqRegions' r+    reqRegionsApprox (Bound l u) =+      let maybeReqRegions = maybe [] reqRegions'+      in maybeReqRegions l ++ maybeReqRegions u+    reqRegions' :: Region -> [Syn.Variable]+    reqRegions' RegionConst{} = []+    reqRegions' (Or r1 r2)    = reqRegions' r1 ++ reqRegions' r2+    reqRegions' (And r1 r2)   = reqRegions' r1 ++ reqRegions' r2+    reqRegions' (Var v)       = [v]++data Region+  = RegionConst Syn.Region+  | Or Region Region+  | And Region Region+  | Var String+  deriving (Show, Eq, Ord, Typeable, Data)++data SpecInner = SpecInner+    (Multiplicity (Approximation Region))  -- main specification content+    Syn.IsStencil                          -- a bool: stencil or access+  deriving (Show, Eq, Typeable, Data)
src/Camfort/Specification/Stencils/Syntax.hs view
@@ -20,24 +20,41 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -module Camfort.Specification.Stencils.Syntax where+module Camfort.Specification.Stencils.Syntax+  (+    -- * Datatypes and Aliases+    Linearity(..)+  , Region(..)+  , RegionDecl+  , RegionEnv+  , RegionProd(..)+  , RegionSum(..)+  , Spatial(..)+  , SpecDecl+  , SpecDecls+  , Specification(..)+  , IsStencil+  , Variable+    -- * Functions+  , absoluteRep+  , fromBool+  , groupKeyBy+  , hasDuplicates+  , isEmpty+  , isUnit+  , pprintSpecDecls+  , setLinearity+  ) where -import Camfort.Helpers import Camfort.Specification.Stencils.Model ( Multiplicity(..)                                             , peel                                             , Approximation(..)-                                            , lowerBound, upperBound-                                            , fromExact                                             )  import Prelude hiding (sum)  import Data.Data-import Data.Generics.Uniplate.Data import Data.List hiding (sum)-import Data.Function-import Data.Maybe-import Debug.Trace import Control.Applicative  type Variable = String@@ -56,33 +73,34 @@  {- *** 1 . Specification syntax -} +type RegionDecl = (Variable, RegionSum)+type SpecDecl   = ([Variable], Specification)+ -- List of region sums associated to region variables-type RegionEnv = [(String, RegionSum)]+type RegionEnv = [(Variable, RegionSum)]  -- List of specifications associated to variables -- This is not a map so there might be multiple entries for each variable -- use `lookupAggregate` to access it-type SpecDecls = [([String], Specification)]+type SpecDecls = [SpecDecl]  pprintSpecDecls :: SpecDecls -> String pprintSpecDecls =  concatMap (\(names, spec) ->             show spec ++ " :: " ++ intercalate "," names ++ "\n") -lookupAggregate :: Eq a => [([a], b)] -> a -> [b]-lookupAggregate [] _ = []-lookupAggregate ((names, spec) : ss) name =-  if name `elem` names-  then spec : lookupAggregate ss name-  else lookupAggregate ss name- -- Top-level of specifications: may be either spatial or temporal++-- | `isStencil` is used to mark whether a specification is associated+-- | with a stencil computation, or a general array computation+type IsStencil = Bool+ data Specification =-  Specification (Multiplicity (Approximation Spatial))+  Specification (Multiplicity (Approximation Spatial)) IsStencil     deriving (Eq, Data, Typeable)  isEmpty :: Specification -> Bool-isEmpty (Specification mult) = isUnit . peel $ mult+isEmpty (Specification mult _) = isUnit . peel $ mult  -- ********************** -- Spatial specifications:@@ -106,9 +124,9 @@ hasDuplicates xs = (nub xs, nub xs /= xs)  setLinearity :: Linearity -> Specification -> Specification-setLinearity l (Specification mult)-  | l == Linear = Specification $ Once $ peel mult-  | l == NonLinear = Specification $ Mult $ peel mult+setLinearity l (Specification mult isStencil)+  | l == Linear    = Specification (Once $ peel mult) isStencil+  | l == NonLinear = Specification (Mult $ peel mult) isStencil  data Linearity = Linear | NonLinear deriving (Eq, Data, Typeable) @@ -123,11 +141,6 @@     Centered :: Depth -> Dimension -> IsRefl -> Region   deriving (Eq, Data, Typeable) -getDimension :: Region -> Dimension-getDimension (Forward _ dim _) = dim-getDimension (Backward _ dim _) = dim-getDimension (Centered _ dim _) = dim- -- An (arbitrary) ordering on regions for the sake of normalisation instance Ord Region where   (Forward dep dim _) <= (Forward dep' dim' _)@@ -161,14 +174,6 @@  -- Operations on specifications -regionPlus :: Region -> Region -> Maybe Region-regionPlus (Forward dep dim reflx) (Backward dep' dim' reflx')-    | dep == dep' && dim == dim' = Just $ Centered dep dim (reflx || reflx')-regionPlus (Backward dep dim reflx) (Forward dep' dim' reflx')-    | dep == dep' && dim == dim' = Just $ Centered dep dim (reflx || reflx')-regionPlus x y | x == y          = Just x-regionPlus x y                   = Nothing- -- Operations on region specifications form a semiring --  where `sum` is the additive, and `prod` is the multiplicative --  [without the annihilation property for `zero` with multiplication]@@ -233,18 +238,10 @@   one = Sum [Product []]   isUnit s@(Sum ss) = s == zero || s == one || all (== Product []) ss --- Show a list with ',' separator-showL :: Show a => [a] -> String-showL = intercalate "," . map show---- Show lists with '*' or '+' separator (used to represent product of regions)-showProdSpecs, showSumSpecs :: Show a => [a] -> String-showProdSpecs = intercalate "*" . map show-showSumSpecs  = intercalate "+" . map show- -- Pretty print top-level specifications instance Show Specification where-  show (Specification sp) = "stencil " ++ show sp+  show (Specification sp True)  = "stencil " ++ show sp+  show (Specification sp False) = "access " ++ show sp  instance {-# OVERLAPS #-} Show (Multiplicity (Approximation Spatial)) where   show mult@@ -255,12 +252,13 @@         case appr of           Exact s -> linearity ++ optionalSeparator sep (show s)           Bound Nothing Nothing -> "empty"-          Bound Nothing (Just s) -> "atMost, " ++ linearity ++ optionalSeparator sep (show s)-          Bound (Just s) Nothing -> "atLeast, " ++ linearity ++ optionalSeparator sep (show s)+          Bound Nothing (Just s) -> linearity ++ optionalSeparator sep "atMost, " ++ show s+          Bound (Just s) Nothing -> linearity ++ optionalSeparator sep "atLeast, " ++ show s           Bound (Just sL) (Just sU) ->-            "atLeast, " ++ linearity ++ optionalSeparator sep (show sL) ++-            "; atMost, " ++ linearity ++ optionalSeparator sep (show sU)-      optionalSeparator sep "" = ""+            concat [ linearity, optionalSeparator sep (show sL), ";"+                   , if linearity == empty then "" else " " ++ linearity ++ ", "+                   , "atMost, ", show sU ]+      optionalSeparator _   "" = ""       optionalSeparator sep s  = sep ++ s  instance {-# OVERLAPS #-} Show (Approximation Spatial) where@@ -281,19 +279,23 @@  -- Pretty print region sums instance Show RegionSum where-    -- Tweedle-dum-    show (Sum []) = "empty"-    -- Tweedle-dee-    show (Sum [Product []]) = "empty"+    showsPrec _ (Sum []) = showString "empty" -    show (Sum specs) =-      intercalate " + " ppspecs-      where ppspecs = filter (/= "") $ map show specs+    showsPrec p (Sum specs) =+        showParen (p > 6) $ inter specs+      where+        inter [ ] = id+        inter [ x ] = showsPrec 6 x+        inter (x:xs) = showsPrec 6 x . (" + " ++) . inter xs  instance Show RegionProd where-    show (Product []) = ""-    show (Product ss)  =-       intercalate "*" . map (\s -> "(" ++ show s ++ ")") $ ss+    showsPrec _ (Product []) = showString "empty"+    showsPrec p (Product ss)  =+        showParen (p > 7) $ inter ss+      where+        inter [ ] = id+        inter [ x ] = showsPrec 7 x+        inter (x:xs) = showsPrec 7 x . ('*' :) . inter xs  instance Show Region where    show (Forward dep dim reflx)   = showRegion "forward" dep dim reflx
src/Camfort/Specification/Stencils/Synthesis.hs view
@@ -16,13 +16,14 @@  {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections #-} -module Camfort.Specification.Stencils.Synthesis where+module Camfort.Specification.Stencils.Synthesis+  ( formatSpec+  , formatSpecNoComment+  , offsetToIx+  ) where  import Data.List-import Data.Maybe-import qualified Data.Map as M  import Camfort.Specification.Stencils.Syntax @@ -30,39 +31,46 @@  import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Util.Position as FU  import Language.Fortran.Util.Position  -- Format inferred specifications-formatSpec ::-    Maybe String- -> FAR.NameMap+formatSpec :: F.MetaInfo -> Int -> Char  -> (FU.SrcSpan, Either [([Variable], Specification)] (String,Variable))  -> String-formatSpec prefix nm (span, Right (evalInfo,name)) =-     prefix'-  ++ evalInfo-  ++ (if name /= "" then " :: " ++ realName name else "") ++ "\n"-  where-    realName v = v `fromMaybe` (v `M.lookup` nm)-    prefix' = case prefix of-                Nothing -> show span ++ "    "-                Just pr -> pr+formatSpec mi indent marker (span, Right (evalInfo, name)) =+  buildCommentText mi indent $+       marker : " "+    ++ evalInfo+    ++ (if name /= "" then " :: " ++ name else "") ++ "\n" -formatSpec _ _ (_, Left []) = ""-formatSpec prefix nm (span, Left specs) =-  (intercalate "\n" $ map (\s -> prefix' ++ doSpec s) specs)+formatSpec _ _ _ (_, Left []) = ""+formatSpec mi indent marker (span, Left specs) =+  intercalate "\n" $ map commentText specs     where-      prefix' = case prefix of-                   Nothing -> show span ++ "    "-                   Just pr -> pr+      commentText s = buildCommentText mi indent (marker : " " ++ doSpec s)       commaSep                 = intercalate ", "       doSpec (arrayVar, spec)  =-             show (fixSpec spec) ++ " :: " ++ commaSep (map realName arrayVar)-      realName v               = v `fromMaybe` (v `M.lookup` nm)+             show (fixSpec spec) ++ " :: " ++ commaSep arrayVar       fixSpec s                = s+++-- | Format inferred specifications, but do not format as a comment.+formatSpecNoComment ::+  (FU.SrcSpan, Either [([Variable], Specification)] (String,Variable))+  -> String+formatSpecNoComment (span, Right (evalInfo, name)) =+  show span ++ "    " ++ evalInfo ++ (if name /= "" then " :: " ++ name else "") ++ "\n"+formatSpecNoComment (_, Left []) = ""+formatSpecNoComment (span, Left specs) =+  intercalate "\n" . map (\s -> show span ++ "    " ++ doSpec s) $ specs+    where+      commaSep                 = intercalate ", "+      doSpec (arrayVar, spec)  =+             show (fixSpec spec) ++ " :: " ++ commaSep arrayVar+      fixSpec s                = s+  ------------------------ a = (head $ FA.initAnalysis [unitAnnotation]) { FA.insLabel = Just 0 }
src/Camfort/Specification/Units.hs view
@@ -31,26 +31,22 @@  import qualified Data.Map.Strict as M import Data.Data-import Data.Char (isNumber) import Data.List (intercalate, find, sort, group, nub, inits)-import Data.Maybe (fromMaybe, maybeToList, listToMaybe, mapMaybe, isJust, maybe)+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 Control.Monad.State.Strict import GHC.Generics (Generic) -import Camfort.Helpers hiding (lineCol)-import Camfort.Helpers.Syntax-import Camfort.Output+import Camfort.Helpers import Camfort.Analysis.Annotations import Camfort.Input+import Camfort.Reprint (subtext)  -- Provides the types and data accessors used in this module import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad-import Camfort.Specification.Units.InferenceBackend import Camfort.Specification.Units.InferenceFrontend import Camfort.Specification.Units.Synthesis (runSynthesis) @@ -61,22 +57,33 @@ import qualified Language.Fortran.Util.Position as FU import Language.Fortran.Util.ModFile --- For debugging and development purposes-import qualified Debug.Trace as D+-- | 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) -- -- ************************************* -inferCriticalVariables-  :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> (Report, Int)- {-| Infer one possible set of critical variables for a program -}-inferCriticalVariables uo (fname, pf)+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)@@ -99,21 +106,15 @@      errReport exc = logs ++ "\n" ++ fname ++ ":\n" ++ show exc -    -- run inference-    uOpts = uo { uoNameMap = FAR.extractNameMap pfRenamed }-    (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ do-      modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      initInference-      runCriticalVariables+    (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 uo))+    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 uo))+    dmap = extractDeclMap pfRenamed `M.union` combinedDeclMap (M.elems (uoModFiles uOpts))      mmap' = extractModuleMap pfRenamed `M.union` mmap -- post-parsing     -- unique name -> src name across modules@@ -122,27 +123,38 @@                 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 uo+    fromWhereMap = genUniqNameToFilenameMap . M.elems $ uoModFiles uOpts -checkUnits, inferUnits-            :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> Report+checkUnits, inferUnits :: UnitOpts -> F.ProgramFile Annotation -> Report {-| Check units-of-measure for a program -}-checkUnits uo (fname, pf)+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 show constraints)+                           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 cons+        reports = map head . group . sort . map reportError . filter relevantConstraints $ cons         showSS  = (++ ": ") . (" - at "++) . showSrcSpan -    reportError con = (findCon con, pprintConstr (orient (unrename nameMap con)) ++ additionalInfo con)+        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)@@ -150,7 +162,7 @@            else "\n    instead" ++ intercalate "\n" (mapNotFirst (pad 10) (errorInfo con))         -- Create additional info about inconsistencies involving variables         errorInfo con =-            [" '" ++ sName ++ "' is '" ++ pprintUnitInfo (unrename nameMap u) ++ "'"+            [" '" ++ sName ++ "' is '" ++ pprintUnitInfo (unrename u) ++ "'"               | UnitVar (vName, sName) <- universeBi con               , u                       <- findUnitConstrFor con vName ]         -- Find unit information for variable constraints@@ -172,7 +184,7 @@         pad o = (++) (replicate o ' ')          srcSpan con | Just ss <- findCon con = showSrcSpan ss ++ " "-                    | otherwise              = ""+                    | otherwise                   = ""      -- Find a given constraint within the annotated AST. FIXME: optimise @@ -180,14 +192,39 @@     findCon con = lookupWith (eq con) constraints       where eq c1 c2 = or [ conParamEq c1 c2' | c2' <- universeBi c2 ] -    constraints = [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Expression UA]  , c <- maybeToList (getConstraint x) ] ++-                  [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Statement UA]   , c <- maybeToList (getConstraint x) ] ++-                  [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Argument UA]    , c <- maybeToList (getConstraint x) ] ++-                  [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Declarator UA]  , c <- maybeToList (getConstraint x) ] ++-                  -- Why reverse? So that PUFunction and PUSubroutine appear first in the list, before PUModule.-                  reverse [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.ProgramUnit UA]-                                              , c <- maybeToList (getConstraint x) ] +    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@@ -196,13 +233,7 @@      errReport exc = logs ++ "\n" ++ fname ++ ":  " ++ show exc -    -- run inference-    uOpts = uo { uoNameMap = nameMap }-    (eCons, state, logs) = runUnitSolver uOpts pfRenamed $ do-      modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      initInference-      runInconsistentConstraints+    (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@@ -214,13 +245,13 @@                                    _ -> False      -- Use the module map derived from all of the included Camfort Mod files.-    mmap = combinedModuleMap (M.elems (uoModFiles uo))+    mmap = combinedModuleMap (M.elems (uoModFiles uOpts))     pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf-    nameMap = FAR.extractNameMap pfRenamed  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)]@@ -243,11 +274,12 @@  {-| Check and infer units-of-measure for a program     This produces an output of all the unit information for a program -}-inferUnits uo (fname, pf)-  | Right []   <- eVars = checkUnits uo (fname, pf)+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@@ -258,22 +290,14 @@      errReport exc = logs ++ "\n" ++ fname ++ ":  " ++ show exc -    -- run inference-    uOpts = uo { uoNameMap = nameMap }-    (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ do-      modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      initInference-      chooseImplicitNames `fmap` runInferVariables+    (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 uo))+    mmap = combinedModuleMap (M.elems (uoModFiles uOpts))     pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf -    nameMap = FAR.extractNameMap pfRenamed- combinedCompiledUnits :: ModFiles -> CompiledUnits combinedCompiledUnits mfs = CompiledUnits { cuTemplateMap = M.unions tmaps                                           , cuNameParamMap = M.unions nmaps }@@ -298,18 +322,19 @@     f _ = Just . LB.toStrict $ encode cu  compileUnits :: UnitOpts -> [FileProgram] -> (String, [(Filename, B.ByteString)])-compileUnits uo fileprogs = (concat reports, concat bins)+compileUnits uOpts fileprogs = (concat reports, concat bins)   where     (reports, bins) = unzip [ (report, bin) | fileprog <- fileprogs-                                            , let (report, bin) = compileUnits' uo fileprog ]+                                            , let (report, bin) = compileUnits' uOpts fileprog ]  compileUnits' :: UnitOpts -> FileProgram -> (String, [(Filename, B.ByteString)])-compileUnits' uo (fname, pf)+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 uo then debugInfo else []+    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@@ -319,34 +344,26 @@      errReport exc = ( logs ++ "\n" ++ fname ++ ":  " ++ show exc                     , [] )-    -- run inference-    uOpts = uo { uoNameMap = nameMap }-    (eCUnits, state, logs) = runUnitSolver uOpts pfTyped $ do-      modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      initInference-      runCompileUnits-+    (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 uo))-    tenv = combinedTypeEnv (M.elems (uoModFiles uo))+    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 -    nameMap = FAR.extractNameMap pfTyped- synthesiseUnits :: UnitOpts                 -> Char-                -> (Filename, F.ProgramFile Annotation)-                -> (Report, (Filename, F.ProgramFile Annotation))+                -> F.ProgramFile Annotation+                -> (Report, F.ProgramFile Annotation) {-| Synthesis unspecified units for a program (after checking) -}-synthesiseUnits uo marker (fname, pf)-  | Right []   <- eVars = (checkUnits uo (fname, pf), (fname, pf))-  | Right vars <- eVars = (okReport vars, (fname, pfFinal))-  | Left exc   <- eVars = (errReport exc, (fname, pfFinal))+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@@ -357,25 +374,27 @@      errReport exc = logs ++ "\n" ++ fname ++ ":  " ++ show exc -    -- run inference-    uOpts = uo { uoNameMap = nameMap }-    (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ do-      modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo-      initInference-      runInferVariables >>= (runSynthesis marker . chooseImplicitNames)+    (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 uo))+    mmap = combinedModuleMap (M.elems (uoModFiles uOpts))     pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf-    nameMap = FAR.extractNameMap pfRenamed  -------------------------------------------------- -unrename nameMap = transformBi $ \ x -> x `fromMaybe` M.lookup x nameMap+-- 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
src/Camfort/Specification/Units/Environment.hs view
@@ -18,38 +18,58 @@  {- Provides various data types and type class instances for the Units extension -} -module Camfort.Specification.Units.Environment where--import Control.Monad.State.Strict hiding (gets)+module Camfort.Specification.Units.Environment+  (+    -- * Datatypes and Aliases+    Constraint(..)+  , Constraints+  , UnitAnnotation(..)+  , UnitInfo(..)+  , VV, PP+    -- * Helpers+  , conParamEq+  , doubleToRationalSubset+  , mkUnitAnnotation+  , pprintConstr+  , pprintUnitInfo+  , toUnitInfo+    -- * Modules (instances)+  , module Data.Data+  ) where  import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Util.Position as FU -import qualified Camfort.Specification.Units.Parser as P+import qualified Camfort.Specification.Units.Parser.Types as P  import Data.Char import Data.Data import Data.List-import Data.Matrix import Data.Ratio import Data.Binary import GHC.Generics (Generic)-import qualified Debug.Trace as D +import Camfort.Helpers (SourceText)+import qualified Data.ByteString.Char8 as B+ import Text.Printf  -- | A (unique name, source name) variable type VV = (F.Name, F.Name) +-- | A (unique name, source name) program unit name+type PP = (F.Name, F.Name)++type UniqueId = Int+ -- | Description of the unit of an expression. data UnitInfo-  = UnitParamPosAbs (String, Int)         -- an abstract parameter identified by PU name and argument position-  | UnitParamPosUse (String, Int, Int)    -- identify particular instantiation of parameters-  | UnitParamVarAbs (String, VV)          -- an abstract parameter identified by PU name and variable name-  | UnitParamVarUse (String, VV, Int)     -- a particular instantiation of above-  | UnitParamLitAbs Int                   -- a literal with abstract, polymorphic units, uniquely identified-  | UnitParamLitUse (Int, Int)            -- a particular instantiation of a polymorphic literal+  = UnitParamPosAbs (PP, Int)             -- an abstract parameter identified by PU name and argument position+  | UnitParamPosUse (PP, Int, Int)        -- identify particular instantiation of parameters+  | UnitParamVarAbs (PP, VV)              -- an abstract parameter identified by PU name and variable name+  | UnitParamVarUse (PP, VV, Int)         -- a particular instantiation of above+  | UnitParamLitAbs UniqueId              -- a literal with abstract, polymorphic units, uniquely identified+  | 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   | UnitLiteral Int                       -- literal with undetermined but uniquely identified units@@ -67,27 +87,27 @@  instance Show UnitInfo where   show u = case u of-    UnitParamPosAbs (f, i)         -> printf "#<ParamPosAbs %s[%d]>" f i-    UnitParamPosUse (f, i, j)      -> printf "#<ParamPosUse %s[%d] callId=%d>" f i j-    UnitParamVarAbs (f, (v, _))    -> printf "#<ParamVarAbs %s.%s>" f v-    UnitParamVarUse (f, (v, _), j) -> printf "#<ParamVarUse %s.%s callId=%d>" f v j-    UnitParamLitAbs i              -> printf "#<ParamLitAbs litId=%d>" i-    UnitParamLitUse (i, j)         -> printf "#<ParamLitUse litId=%d callId=%d]>" i j-    UnitParamEAPAbs (v, _)         -> v-    UnitParamEAPUse ((v, _), i)    -> printf "#<ParamEAPUse %s callId=%d]>" v i-    UnitLiteral i                  -> printf "#<Literal id=%d>" i-    UnitlessLit                    -> "1"-    UnitlessVar                    -> "1"-    UnitName name                  -> name-    UnitAlias name                 -> name-    UnitVar (vName, _)             -> printf "#<Var %s>" vName-    UnitRecord recs                -> "record (" ++ intercalate ", " (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")"+    UnitParamPosAbs ((f, _), i)         -> printf "#<ParamPosAbs %s[%d]>" f i+    UnitParamPosUse ((f, _), i, j)      -> printf "#<ParamPosUse %s[%d] callId=%d>" f i j+    UnitParamVarAbs ((f, _), (v, _))    -> printf "#<ParamVarAbs %s.%s>" f v+    UnitParamVarUse ((f, _), (v, _), j) -> printf "#<ParamVarUse %s.%s callId=%d>" f v j+    UnitParamLitAbs i                   -> printf "#<ParamLitAbs litId=%d>" i+    UnitParamLitUse (i, j)              -> printf "#<ParamLitUse litId=%d callId=%d]>" i j+    UnitParamEAPAbs (v, _)              -> v+    UnitParamEAPUse ((v, _), i)         -> printf "#<ParamEAPUse %s callId=%d]>" v i+    UnitLiteral i                       -> printf "#<Literal id=%d>" i+    UnitlessLit                         -> "1"+    UnitlessVar                         -> "1"+    UnitName name                       -> name+    UnitAlias name                      -> name+    UnitVar (_, vName)                  -> printf "unit_of(%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))-    UnitMul u1 u2                  -> maybeParenS u1 ++ " " ++ maybeParenS u2-    UnitPow u 1                    -> show u-    UnitPow u 0                    -> "1"-    UnitPow u k                    -> -- printf "%s**%f" (maybeParen u) k+      | k < 0                           -> maybeParen u1 ++ " / " ++ maybeParen (UnitPow u2 (-k))+    UnitMul u1 u2                       -> maybeParenS u1 ++ " " ++ maybeParenS u2+    UnitPow u 1                         -> show u+    UnitPow _ 0                         -> "1"+    UnitPow u k                         -> -- printf "%s**%f" (maybeParen u) k       case doubleToRationalSubset k of           Just r             | e <- showRational r@@ -148,10 +168,6 @@   show (ConEq u1 u2) = show u1 ++ " === " ++ show u2   show (ConConj cs) = intercalate " && " (map show cs) -isVarUnit (UnitVar _)         = True-isVarUnit (UnitParamVarUse _) = True-isVarUnit _                   = False- isUnresolvedUnit (UnitVar _)         = True isUnresolvedUnit (UnitParamVarUse _) = True isUnresolvedUnit (UnitParamVarAbs _) = True@@ -167,29 +183,41 @@  isResolvedUnit = not . isUnresolvedUnit +isConcreteUnit :: UnitInfo -> Bool+isConcreteUnit (UnitPow u _) = isConcreteUnit u+isConcreteUnit (UnitMul u v) = isConcreteUnit u && isConcreteUnit v+isConcreteUnit (UnitAlias _) = True+isConcreteUnit UnitlessLit = True+isConcreteUnit (UnitName _) = True+isConcreteUnit _ = False+ pprintConstr :: Constraint -> String pprintConstr (ConEq u1 u2)+  | isResolvedUnit u1 && isConcreteUnit u1 &&+    isResolvedUnit u2 && isConcreteUnit u2 =+      "Units '" ++ pprintUnitInfo u1 ++ "' and '" ++ pprintUnitInfo u2 +++      "' 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 ++ "'"-pprintConstr (ConConj cs)  = intercalate "\n\t and " (map pprintConstr cs)+pprintConstr (ConConj cs)  = intercalate "\n\t and " (fmap pprintConstr cs)  pprintUnitInfo :: UnitInfo -> String-pprintUnitInfo (UnitVar (_, sName)) = printf "%s" sName+pprintUnitInfo (UnitVar (_, sName))                 = printf "%s" sName pprintUnitInfo (UnitParamVarUse (_, (_, sName), _)) = printf "%s" sName-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 number"-pprintUnitInfo ui = show ui+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 ui                                   = show ui  --------------------------------------------------  -- | Constraint 'parametric' equality: treat all uses of a parametric -- abstractions as equivalent to the abstraction. conParamEq :: Constraint -> Constraint -> Bool-conParamEq (ConEq lhs1 rhs1) (ConEq lhs2 rhs2) = unitParamEq lhs1 lhs2 || unitParamEq rhs1 rhs2 ||-                                                 unitParamEq rhs1 lhs2 || unitParamEq lhs1 rhs2+conParamEq (ConEq lhs1 rhs1) (ConEq lhs2 rhs2) = (unitParamEq lhs1 lhs2 || unitParamEq rhs1 rhs2) ||+                                                 (unitParamEq rhs1 lhs2 || unitParamEq lhs1 rhs2) conParamEq (ConConj cs1) (ConConj cs2) = and $ zipWith conParamEq cs1 cs2 conParamEq _ _ = False @@ -220,21 +248,6 @@     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)--dbgUnitAnnotation (UnitAnnotation _ s c i b p) =-  "{ unitSpec = " ++ show s ++ ", unitConstraint = " ++ show c ++ ", unitInfo = " ++ show i ++ ", unitBlock = " ++-     (case b of-        Nothing -> "Nothing"-        Just (F.BlStatement _ span _ (F.StDeclaration {}))  -> "Just {decl}@" ++ show span-        Just (F.BlStatement _ span _ _) -> "Just {stmt}@" ++ show span-        Just _ -> "Just ...")-   ++ ", unitPU = " ++-     (case p of-        Nothing -> "Nothing"-        Just (F.PUFunction _ span _ _ _ _ _ _ _)  -> "Just {func}@" ++ show span-        Just (F.PUSubroutine _ span _ _ _ _ _) -> "Just {subr}@" ++ show span-        Just _ -> "Just ...")-   ++ "}"  mkUnitAnnotation :: a -> UnitAnnotation a mkUnitAnnotation a = UnitAnnotation a Nothing Nothing Nothing Nothing Nothing
src/Camfort/Specification/Units/InferenceBackend.hs view
@@ -30,29 +30,26 @@  import Data.Tuple (swap) import Data.Maybe (maybeToList)-import Data.List ((\\), findIndex, partition, sortBy, group, intercalate, tails, sort)-import Data.Generics.Uniplate.Operations (rewrite, universeBi)+import Data.List ((\\), findIndex, partition, sortBy, group, tails)+import Data.Generics.Uniplate.Operations (rewrite) import Control.Monad-import Control.Monad.State.Strict import Control.Monad.ST import Control.Arrow (first, second) import qualified Data.Map.Strict as M import qualified Data.Array as A -import Camfort.Analysis.Annotations import Camfort.Specification.Units.Environment  import Numeric.LinearAlgebra (-    atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols,-    takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks,-    ident, flatten, lu, dispf+    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   ) -import qualified Debug.Trace as D  -------------------------------------------------- @@ -74,7 +71,7 @@ criticalVariables [] = [] criticalVariables cons = filter (not . isUnitRHS) $ map (colA A.!) criticalIndices   where-    (unsolvedM, inconsists, colA) = constraintsToMatrix cons+    (unsolvedM, _, colA) = constraintsToMatrix cons     solvedM                       = rref unsolvedM     uncriticalIndices             = concatMap (maybeToList . findIndex (/= 0)) $ H.toLists solvedM     criticalIndices               = A.indices colA \\ uncriticalIndices@@ -124,8 +121,6 @@  -------------------------------------------------- -simplifyConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2))- simplifyUnits :: UnitInfo -> UnitInfo simplifyUnits = rewrite rw   where@@ -136,7 +131,7 @@     rw (UnitPow _ p) | p `approxEq` 0                        = Just UnitlessLit     rw (UnitMul UnitlessLit u)                               = Just u     rw (UnitMul u UnitlessLit)                               = Just u-    rw u                                                     = Nothing+    rw _                                                     = Nothing  flattenUnits :: UnitInfo -> [UnitInfo] flattenUnits = map (uncurry UnitPow) . M.toList@@ -183,7 +178,6 @@     rhs             = map snd shiftedCons     (lhsM, lhsCols) = flattenedToMatrix lhs     (rhsM, rhsCols) = flattenedToMatrix rhs-    colElems        = A.elems lhsCols ++ A.elems rhsCols     augM            = if rows rhsM == 0 || cols rhsM == 0 then lhsM else fromBlocks [[lhsM, rhsM]]     inconsists      = findInconsistentRows lhsM augM @@ -250,16 +244,6 @@ rref :: H.Matrix Double -> H.Matrix Double rref a = snd $ rrefMatrices' a 0 0 [] --- | List of matrices that when multiplied transform input into--- Reduced Row Echelon Form-rrefMatrices :: H.Matrix Double -> [H.Matrix Double]-rrefMatrices a = fst $ rrefMatrices' a 0 0 []---- | Single matrix that transforms input into Reduced Row Echelon form--- when multiplied to the original.-rrefMatrix :: H.Matrix Double -> H.Matrix Double-rrefMatrix a = foldr (<>) (ident (rows a)) . fst $ rrefMatrices' a 0 0 []- -- worker function -- invariant: the matrix a is in rref except within the submatrix (j-k,j) to (n,n) rrefMatrices' a j k mats@@ -297,7 +281,7 @@     -- separate elemRowAdd matrix for each cancellation that are then     -- multiplied together, simply build a single matrix that cancels     -- all of them out at the same time, using the ST Monad.-    findAdds i m ms+    findAdds _ m ms       | isWritten = (new <> m, new:ms)       | otherwise = (m, ms)       where@@ -322,13 +306,6 @@ elemRowMult :: Int -> Int -> Double -> H.Matrix Double elemRowMult n i k = diag (H.fromList (replicate i 1.0 ++ [k] ++ replicate (n - i - 1) 1.0)) -elemRowAdd :: Int -> Int -> Int -> Double -> H.Matrix Double-elemRowAdd n i j k = runSTMatrix $ do-      m <- newMatrix 0 n n-      sequence [ writeMatrix m i' i' 1 | i' <- [0 .. (n - 1)] ]-      writeMatrix m i j k-      return m- elemRowSwap :: Int -> Int -> Int -> H.Matrix Double elemRowSwap n i j   | i == j          = ident n@@ -340,12 +317,6 @@  -- Worker functions: -toDouble :: Rational -> Double-toDouble = fromRational--fromDouble :: Double -> Rational-fromDouble = toRational- findInconsistentRows :: H.Matrix Double -> H.Matrix Double -> [Int] findInconsistentRows coA augA = [0..(rows augA - 1)] \\ consistent   where@@ -359,12 +330,5 @@         coA'  = extractRows ns coA         augA' = extractRows ns augA -    pset = filterM (const [True, False])- extractRows = flip (?) -- hmatrix 0.17 changed interface m @@> i = m `atIndex` i--showCons str = 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)
src/Camfort/Specification/Units/InferenceFrontend.hs view
@@ -31,12 +31,11 @@ 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, catMaybes)+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.Trans.Except import Control.Monad.RWS.Strict  import qualified Language.Fortran.AST as F@@ -51,7 +50,8 @@ import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad import Camfort.Specification.Units.InferenceBackend-import qualified Camfort.Specification.Units.Parser as P+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@@ -65,12 +65,11 @@    -- Parse unit annotations found in comments and link to their   -- corresponding statements in the AST.-  let (linkedPF, parserReport) = runWriter $ annotateComments P.unitParser pf+  let (linkedPF, parserReport) =+        runWriter $ annotateComments unitParser+        (\srcSpan err -> tell $ "Error " ++ show srcSpan ++ ": " ++ show err) pf   modifyProgramFile $ const linkedPF -  -- Send the output of the parser to the logger.-  mapM_ tell parserReport-   -- The following insert* functions examine the AST and insert   -- mappings into the tables stored in the UnitState. @@ -194,7 +193,7 @@         -- 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+        fname = (puName pu, puSrcName pu)  -- | Return the list of parameters paired with its positional index. indexedParams :: F.ProgramUnit UA -> [(Int, VV)]@@ -236,9 +235,9 @@ toUnitVar dmap (vname, sname) = unit   where     unit = case fst `fmap` M.lookup vname dmap of-      Just (DCFunction (F.Named fname))   -> UnitParamVarAbs (fname, (vname, sname))-      Just (DCSubroutine (F.Named fname)) -> UnitParamVarAbs (fname, (vname, sname))-      _                                   -> UnitVar (vname, sname)+      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)  -------------------------------------------------- @@ -258,7 +257,7 @@   where     -- Look through each Program Unit for the comments     checkPU :: F.ProgramUnit UA -> UnitSolver ()-    checkPU pu@(F.PUComment a _ _)+    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@@ -316,55 +315,6 @@           modifyVarUnitMap $ M.unionWith const m           modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m ---- ensure polymorphic variable annotation is used correctly-checkPolymorphicAnnotation :: UnitSolver [String]-checkPolymorphicAnnotation = do-  pf     <- gets usProgramFile-  checks <- mapM checkPU (universeBi pf)-  return . map fst . filter (not . snd) $ checks-  where-    -- Look through each Program Unit for its parameters and annotations-    checkPU :: F.ProgramUnit UA -> UnitSolver (String, Bool)-    checkPU pu = do-        (argPolys, resPolys) <- foldM (checkBlockComment (getNameAndArgs pu)) ([], []) [ b | b@(F.BlComment {}) <- universeBi (F.programUnitBody pu) ]-        return (puName pu, S.fromList resPolys `S.isSubsetOf` S.fromList argPolys)-      where-        getNameAndArgs :: F.ProgramUnit UA -> Maybe (String, [String], Maybe String)-        getNameAndArgs pu = case pu of-          F.PUFunction _ _ _ _ _ args Nothing _ _-            | name <- puName pu -> Just (name, map varName (universeBi args :: [F.Expression UA]), Just name)-          F.PUFunction _ _ _ _ _ args (Just res) _ _-            | name <- puName pu -> Just (name, map varName (universeBi args :: [F.Expression UA]), Just (varName res))-          F.PUSubroutine _ _ _ _ args _ _-            | name <- puName pu -> Just (name, map varName (universeBi args :: [F.Expression UA]), Nothing)-          _                     -> Nothing-    checkBlockComment :: Maybe (String, [String], Maybe String) -> ([String], [String]) -> F.Block UA -> UnitSolver ([String], [String])-    checkBlockComment pinfo (argPolys, resPolys) (F.BlComment a _ _)-      -- Look at unit assignment between variable and spec.-      | Just (pname, args, mres)                     <- pinfo-      , Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec-      , Just b                                       <- mBlock =-        let-          annotVars  = S.fromList [ varName e-                                  | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi b :: [F.Expression UA]-                                  , varSrcName <- vars-                                  , varSrcName == srcName e ]-          extractPolys ast = [ v | P.UnitBasic (v@('\'':_)) <- universeBi ast ]-        in case () of-             () | any (`S.member` annotVars) args -> return (extractPolys unitsAST ++ argPolys, resPolys)-                | Just res <- mres,-                  res `S.member` annotVars        -> return (argPolys, extractPolys unitsAST ++ resPolys)-                | otherwise                       -> return (argPolys, resPolys)-      | otherwise                                             = return (argPolys, resPolys)-      where-        mSpec      = unitSpec (FA.prevAnnotation a)-        mBlock     = unitBlock (FA.prevAnnotation a)----- --------------------------------------------------  -- | Take the unit information from the VarUnitMap and use it to@@ -426,12 +376,6 @@ isLiteral _                                 = False  -- | Is expression a literal and is it zero?-isLiteralZero :: F.Expression UA -> Bool-isLiteralZero (F.ExpValue _ _ (F.ValInteger i)) = readInteger i == Just 0-isLiteralZero (F.ExpValue _ _ (F.ValReal i))    = readReal i    == Just 0-isLiteralZero _                                 = 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@@ -445,7 +389,7 @@ 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 ]+  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@@ -503,7 +447,7 @@   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 ]+  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@@ -545,10 +489,10 @@ -- | Generate constraints from a NameParamMap entry. nameParamConstraints :: F.Name -> UnitSolver Constraints nameParamConstraints fname = do-  let filterForName (NPKParam n _) _ = n == fname-      filterForName _ _              = False+  let filterForName (NPKParam (n, _) _) _ = n == fname+      filterForName _ _                   = False   nlst <- (M.toList . M.filterWithKey filterForName) `fmap` gets usNameParamMap-  return [ ConEq (UnitParamPosAbs (fname, pos)) (foldUnits units) | (NPKParam _ pos, units) <- nlst ]+  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@@ -616,22 +560,6 @@     getBlocks (F.PUModule _ _ _ bs _) = bs     getBlocks _                       = [] --- | Does the constraint contain any Parametric elements?-isParametric :: Constraint -> Bool-isParametric info = not . null $ [ () | UnitParamPosAbs _ <- universeBi info ] ++-                                 [ () | UnitParamVarAbs _ <- universeBi info ] ++-                                 [ () | UnitParamLitAbs _ <- universeBi info ]---- | Does the constraint contain only Parametric elements?-isAllParametric :: Constraint -> Bool-isAllParametric = all f . universeBi-  where-    f i = case i of-      UnitParamPosAbs _ -> True-      UnitParamVarAbs _ -> True-      UnitParamLitAbs _ -> True-      _                 -> False- --------------------------------------------------  -- | Decorate the AST with unit info.@@ -662,11 +590,11 @@     setF2C f u1 u2 = return . maybeSetUnitInfo u1 $ maybeSetUnitConstraintF2 f u1 u2 e  propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA)-propagateFunctionCall e@(F.ExpFunctionCall a s f Nothing)                     = do+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 e@(F.ExpFunctionCall a s f (Just (F.AList a' s' args))) = do+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'))@@ -701,7 +629,9 @@  propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA) propagatePU pu = do-  let name = puName pu+  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@@ -713,9 +643,9 @@   -- the explicit unit annotation as well.   givenCons <- forM (indexedParams pu) $ \ (i, param) -> do     case M.lookup param varMap of-      Just (UnitParamPosAbs {}) -> return . ConEq (UnitParamVarAbs (name, param)) $ UnitParamPosAbs (name, i)-      Just u                    -> return . ConEq u $ UnitParamPosAbs (name, i)-      _                         -> return . ConEq (UnitParamVarAbs (name, param)) $ UnitParamPosAbs (name, i)+      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)@@ -725,22 +655,17 @@   -- 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 (name, 0) `fromMaybe` M.lookup res varMap) pu+              (F.PUFunction {}, (0, res):_) -> setUnitInfo (UnitParamPosAbs (nn, 0) `fromMaybe` M.lookup res varMap) pu               _                             -> pu    return (setConstraint (ConConj cons) pu')  -------------------------------------------------- --- | Check if x contains an abstract parametric reference under the given name.-containsParametric :: Data from => String -> from -> Bool-containsParametric name x = not . null $ [ () | UnitParamPosAbs (name', _) <- universeBi x, name == name' ] ++-                                         [ () | UnitParamVarAbs (name', _) <- universeBi x, name == name' ]- -- | 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+  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@@ -758,7 +683,7 @@     numArgs     = length args     sname       = srcName f     vname       = varName f-    eachArg i u = ConEq (UnitParamPosUse (vname, i, callId)) (instantiate callId u)+    eachArg i u = ConEq (UnitParamPosUse ((vname, sname), i, callId)) (instantiate callId u) intrinsicHelper _ _ _ = []  -- | Generate a unique identifier for a call-site.@@ -811,12 +736,12 @@  -- | Set the UnitInfo field on a piece of AST. setUnitInfo :: F.Annotated f => UnitInfo -> f UA -> f UA-setUnitInfo info = modifyAnnotation (onPrev (\ ua -> ua { unitInfo = Just info }))+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            = modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c }))+setConstraint c            = F.modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c }))  -------------------------------------------------- @@ -833,11 +758,6 @@ maybeSetUnitConstraintF2 f (Just u1) (Just u2) e = setConstraint (f u1 u2) e maybeSetUnitConstraintF2 _ _ _ e                 = e -fmapUnitInfo :: F.Annotated f => (UnitInfo -> UnitInfo) -> f UA -> f UA-fmapUnitInfo f x-  | Just u <- getUnitInfo x = setUnitInfo (f u) x-  | otherwise               = x- -- 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@@ -1063,6 +983,8 @@     , ("cosh", (UnitlessVar, [UnitlessVar]))     , ("dcosh", (UnitlessVar, [UnitlessVar]))     , ("tanh", (UnitlessVar, [UnitlessVar]))-    , ("dtanh", (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/Monad.hs view
@@ -39,13 +39,11 @@ 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 as FA 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, UnitAnnotation, Constraints(..), VV)-import Camfort.Analysis.Annotations (Annotation, A, UA)-import qualified Data.ByteString.Char8 as B+import Camfort.Specification.Units.Environment (UnitInfo, Constraints(..), VV, PP)+import Camfort.Analysis.Annotations (UA)   -- | Some options about how to handle literals.@@ -69,20 +67,19 @@ data UnitOpts = UnitOpts   { uoDebug          :: Bool                      -- ^ debugging mode?   , uoLiterals       :: LiteralsOpt               -- ^ how to handle literals-  , uoNameMap        :: FAR.NameMap               -- ^ map of unique names to original names   , uoModFiles       :: M.Map String ModFile      -- ^ map of included modules   }   deriving (Show, Data, Eq, Ord)  unitOpts0 :: UnitOpts-unitOpts0 = UnitOpts False LitMixed M.empty M.empty+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 F.Name Int -- ^ Function/subroutine name, position of parameter+  = NPKParam PP Int     -- ^ Function/subroutine name, position of parameter   | NPKVariable VV      -- ^ variable   deriving (Ord, Eq, Show, Data, Typeable, Generic)
src/Camfort/Specification/Units/Parser.y view
@@ -1,20 +1,19 @@ { -- -*- Mode: Haskell -*- -{-# LANGUAGE DeriveDataTypeable #-}-module Camfort.Specification.Units.Parser ( unitParser-                                     , UnitStatement(..)-                                     , UnitOfMeasure(..)-                                     , UnitPower(..)-                                     ) where+module Camfort.Specification.Units.Parser+  ( unitParser+  , UnitParseError+  ) where -import Camfort.Analysis.CommentAnnotator-import Data.Data-import Data.List+import Control.Monad.Except (throwError) import Data.Char (isLetter, isNumber, isAlphaNum, toLower)-import qualified Data.Text as T++import Camfort.Specification.Parser (mkParser, SpecParser)+import Camfort.Specification.Units.Parser.Types+ } -%monad { Either AnnotationParseError } { >>= } { return }+%monad { UnitSpecParser } { >>= } { return } %name parseUnit UNIT %tokentype { Token } @@ -26,6 +25,7 @@  num      { TNum $$ }  ','      { TComma }  '-'      { TMinus }+ '*'      { TMult }  '**'     { TExponentiation }  '/'      { TDivision }  '::'     { TDoubleColon }@@ -33,6 +33,7 @@  '('      { TLeftPar }  ')'      { TRightPar } +%left '*' %left '/' %left '**' %%@@ -65,6 +66,7 @@  UEXP_LEVEL1 :: { UnitOfMeasure } : UEXP_LEVEL1 UEXP_LEVEL2             { UnitProduct $1 $2 }+| UEXP_LEVEL1 '*' UEXP_LEVEL2         { UnitProduct $1 $3 } | UEXP '/' UEXP_LEVEL2                { UnitQuotient $1 $3 } | UEXP_LEVEL2                         { $1 } @@ -88,41 +90,25 @@  { -data UnitStatement =-   UnitAssignment (Maybe [String]) UnitOfMeasure- | UnitAlias String UnitOfMeasure-  deriving Data--instance Show UnitStatement where-  show (UnitAssignment (Just ss) uom) = "= unit (" ++ show uom ++ ") :: " ++ (intercalate "," ss)-  show (UnitAssignment Nothing uom) = "= unit (" ++ show uom ++ ")"-  show (UnitAlias s uom) = "= unit :: " ++ s ++ " = " ++ show uom+data UnitParseError+  -- | Not a valid identifier character.+  = NotAnIdentifier Char+  -- | Tokens do not represent a syntactically valid specification.+  | CouldNotParseSpecification [Token]+  deriving (Eq) -data UnitOfMeasure =-   Unitless- | UnitBasic String- | UnitProduct UnitOfMeasure UnitOfMeasure- | UnitQuotient UnitOfMeasure UnitOfMeasure- | UnitExponentiation UnitOfMeasure UnitPower- | UnitRecord [(String, UnitOfMeasure)]-  deriving Data+instance Show UnitParseError where+  show (CouldNotParseSpecification ts) =+    "Could not parse specification at: \"" ++ show ts ++ "\"\n"+  show (NotAnIdentifier c) = "Invalid character in identifier: " ++ show c -instance Show UnitOfMeasure where-  show Unitless = "1"-  show (UnitBasic s) = s-  show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2-  show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2-  show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")"-  show (UnitRecord recs) = "record (" ++ intercalate ", " (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")"+notAnIdentifier :: Char -> UnitParseError+notAnIdentifier = NotAnIdentifier -data UnitPower =-   UnitPowerInteger Integer- | UnitPowerRational Integer Integer- deriving Data+couldNotParseSpecification :: [Token] -> UnitParseError+couldNotParseSpecification = CouldNotParseSpecification -instance Show UnitPower where-  show (UnitPowerInteger i) = show i-  show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2+type UnitSpecParser a = Either UnitParseError a  data Token =    TUnit@@ -131,60 +117,53 @@  | TExponentiation  | TDivision  | TMinus+ | TMult  | TEqual  | TLeftPar  | TRightPar  | TRecord  | TId String  | TNum String- deriving (Show)--lexer :: String -> Either AnnotationParseError [ Token ]-lexer [] = Left NotAnnotation-lexer (c:xs)-  | c `elem` ['=', '!', '>', '<'] =-      -- First test to see if the input looks like an actual unit specification-      if "unit" `isPrefixOf` (T.unpack . T.strip . T.toLower . T.pack $ xs)-      then lexer' xs-      else Left NotAnnotation-  | otherwise = Left NotAnnotation+ deriving (Show, Eq) -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ]+addToTokens :: Token -> String -> UnitSpecParser [ Token ] addToTokens tok rest = do- tokens <- lexer' rest+ tokens <- lexer rest  return $ tok : tokens -lexer' :: String -> Either AnnotationParseError [ Token ]-lexer' [] = Right []-lexer' ['\n']  = Right []-lexer' ['\r', '\n']  = Right []-lexer' ['\r']  = Right [] -- windows-lexer' (' ':xs) = lexer' xs-lexer' ('\t':xs) = lexer' xs-lexer' (':':':':xs) = addToTokens TDoubleColon xs-lexer' ('*':'*':xs) = addToTokens TExponentiation xs-lexer' (',':xs) = addToTokens TComma xs-lexer' ('/':xs) = addToTokens TDivision xs-lexer' ('-':xs) = addToTokens TMinus xs-lexer' ('=':xs) = addToTokens TEqual xs-lexer' ('(':xs) = addToTokens TLeftPar xs-lexer' (')':xs) = addToTokens TRightPar xs-lexer' (x:xs)+lexer :: String -> UnitSpecParser [ Token ]+lexer [] = Right []+lexer ['\n']  = Right []+lexer ['\r', '\n']  = Right []+lexer ['\r']  = Right [] -- windows+lexer (' ':xs) = lexer xs+lexer ('\t':xs) = lexer xs+lexer (':':':':xs) = addToTokens TDoubleColon xs+lexer ('*':'*':xs) = addToTokens TExponentiation xs+lexer (',':xs) = addToTokens TComma xs+lexer ('/':xs) = addToTokens TDivision xs+lexer ('-':xs) = addToTokens TMinus xs+lexer ('*':xs) = addToTokens TMult xs+lexer ('=':xs) = addToTokens TEqual xs+lexer ('(':xs) = addToTokens TLeftPar xs+lexer (')':xs) = addToTokens TRightPar xs+lexer (x:xs)  | isLetter x || x == '\'' = aux (\ c -> isAlphaNum c || c `elem` ['\'','_','-'])                                  (\ s -> if s == "record" then TRecord else TId s)  | isNumber x              = aux isNumber TNum- | otherwise               = failWith $ "Not valid unit syntax at " ++ show (x:xs) ++ "\n"+ | otherwise+     = throwError $ notAnIdentifier x  where    aux p cons =      let (target, rest) = span p xs-     in lexer' rest >>= (\tokens -> return $ cons (x:target) : tokens)+     in lexer rest >>= (\tokens -> return $ cons (x:target) : tokens) -unitParser :: String -> Either AnnotationParseError UnitStatement-unitParser src = do- tokens <- lexer $ map toLower src- parseUnit tokens+unitParser :: SpecParser UnitParseError UnitStatement+unitParser = mkParser (\src -> do+                          tokens <- lexer $ map toLower src+                          parseUnit tokens) ["unit"] -happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = failWith $ "Could not parse unit specification at: " ++ show t ++ "\n"+happyError :: [ Token ] -> UnitSpecParser a+happyError = throwError . couldNotParseSpecification  }
+ src/Camfort/Specification/Units/Parser/Types.hs view
@@ -0,0 +1,64 @@+{- |+Module      :  Camfort.Specification.Units.Parser.Types+Description :  Defines the representation of unit specifications resulting from parsing.+Copyright   :  (c) 2017, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish+License     :  Apache-2.0++Maintainer  :  dom.orchard@gmail.com+Stability   :  experimental+-}++{-# LANGUAGE DeriveDataTypeable #-}++module Camfort.Specification.Units.Parser.Types+  ( UnitStatement(..)+  , UnitOfMeasure(..)+  , UnitPower(..)+  ) where++import Data.Data (Data)+import Data.List (intercalate)++data UnitStatement =+   UnitAssignment (Maybe [String]) UnitOfMeasure+ | UnitAlias String UnitOfMeasure+  deriving (Eq, Data)++instance Show UnitStatement where+  show (UnitAssignment (Just ss) uom)+    = "= unit (" ++ show uom ++ ") :: " ++ intercalate "," ss+  show (UnitAssignment Nothing uom)+    = "= unit (" ++ show uom ++ ")"+  show (UnitAlias s uom)+    = "= unit :: " ++ s ++ " = " ++ show uom++data UnitOfMeasure =+   Unitless+ | UnitBasic String+ | UnitProduct UnitOfMeasure UnitOfMeasure+ | UnitQuotient UnitOfMeasure UnitOfMeasure+ | UnitExponentiation UnitOfMeasure UnitPower+ | UnitRecord [(String, UnitOfMeasure)]+  deriving (Data, Eq)++instance Show UnitOfMeasure where+  show Unitless      = "1"+  show (UnitBasic s) = s+  show (UnitProduct uom1 uom2)+    = show uom1 ++ " " ++ show uom2+  show (UnitQuotient uom1 uom2)+    = show uom1 ++ " / " ++ show uom2+  show (UnitExponentiation uom expt)+    = show uom  ++ "** (" ++ show expt ++ ")"+  show (UnitRecord recs)+    = "record (" ++ intercalate ", "+      (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")"++data UnitPower =+   UnitPowerInteger Integer+ | UnitPowerRational Integer Integer+ deriving (Data, Eq)++instance Show UnitPower where+  show (UnitPowerInteger i)      = show i+  show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2
src/Camfort/Specification/Units/Synthesis.hs view
@@ -14,38 +14,25 @@    limitations under the License. -} -{-# LANGUAGE PatternGuards, ScopedTypeVariables, ImplicitParams, DoAndIfThenElse, ConstraintKinds, TupleSections #-}+{-# LANGUAGE PatternGuards, DoAndIfThenElse, ConstraintKinds, ScopedTypeVariables #-}  module Camfort.Specification.Units.Synthesis   (runSynthesis) where -import Data.Function-import Data.List-import Data.Matrix import Data.Maybe-import Data.Ratio (numerator, denominator)-import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Generics.Uniplate.Operations import Control.Monad.State.Strict hiding (gets)-import Control.Monad.Reader-import Control.Monad.Writer.Strict-import Control.Monad  import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Util.Position as FU-import Language.Fortran.ParserMonad (FortranVersion(Fortran90)) -import qualified Camfort.Specification.Units.Parser as P-import Camfort.Analysis.CommentAnnotator import Camfort.Analysis.Annotations hiding (Unitless) import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad import Camfort.Specification.Units.InferenceFrontend (puName, puSrcName)-import qualified Debug.Trace as D  -- | Insert unit declarations into the ProgramFile as comments. runSynthesis :: Char -> [(VV, UnitInfo)] -> UnitSolver [(VV, UnitInfo)]@@ -64,7 +51,7 @@ -- particular, in order to possibly insert a unit annotation before -- them. synthBlock :: Char -> [(VV, UnitInfo)] -> [F.Block UA] -> F.Block UA -> UnitSolver [F.Block UA]-synthBlock marker vars bs b@(F.BlStatement a ss@(FU.SrcSpan lp up) _ (F.StDeclaration _ _ _ _ decls)) = do+synthBlock marker vars bs b@(F.BlStatement a (FU.SrcSpan lp _) _ (F.StDeclaration _ _ _ _ decls)) = do   pf    <- usProgramFile `fmap` get   gvSet <- usGivenVarSet `fmap` get   newBs <- fmap catMaybes . forM (universeBi decls) $ \ e -> case e of@@ -75,17 +62,18 @@         let newA  = a { FA.prevAnnotation = (FA.prevAnnotation a) {                            prevAnnotation = (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})-        -- Build the text of the comment with the unit annotation.-        let txt   = marker:" " ++ showUnitDecl (FA.srcName e, u)-        let space = FU.posColumn lp - 1-        let newB  = F.BlComment newA newSS . F.Comment . insertSpacing pf space $ commentText pf txt+            -- Create a zero-length span for the new comment node.+            newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0})+            -- Build the text of the comment with the unit annotation.+            txt   = marker:" " ++ showUnitDecl (FA.srcName e, u)+            space = FU.posColumn lp - 1+            (F.ProgramFile mi _) = pf+            newB  = F.BlComment newA newSS . F.Comment $ buildCommentText mi space txt         return $ Just newB       where         vname = FA.varName e         sname = FA.srcName e-    (e :: F.Expression UA) -> return Nothing+    (_ :: F.Expression UA) -> return Nothing   return (b:reverse newBs ++ bs) synthBlock _ _ bs b = return (b:bs) @@ -99,7 +87,7 @@ -- list of program units. We're looking for functions, in particular, -- in order to possibly insert a unit annotation before them. synthProgramUnit :: Char -> [(VV, UnitInfo)] -> [F.ProgramUnit UA] -> F.ProgramUnit UA -> UnitSolver [F.ProgramUnit UA]-synthProgramUnit marker vars pus pu@(F.PUFunction a ss@(FU.SrcSpan lp up) _ _ _ _ mret _ _) = do+synthProgramUnit marker vars pus pu@(F.PUFunction a (FU.SrcSpan lp _) _ _ _ _ mret _ _) = do   pf    <- usProgramFile `fmap` get   gvSet <- usGivenVarSet `fmap` get   let (vname, sname) = case mret of Just e  -> (FA.varName e, FA.srcName e)@@ -113,9 +101,10 @@       -- Create a zero-length span for the new comment node.       let newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0})       -- Build the text of the comment with the unit annotation.-      let txt   = marker:" " ++ showUnitDecl (sname, u)-      let space = FU.posColumn lp - 1-      let newPU = F.PUComment newA newSS . F.Comment . insertSpacing pf space $ commentText pf txt+          txt   = marker:" " ++ showUnitDecl (sname, u)+          space = FU.posColumn lp - 1+          (F.ProgramFile mi _) = pf+          newPU = F.PUComment newA newSS . F.Comment $ buildCommentText mi space txt        -- recursively descend to find program units inside of current one       fmap (:newPU:pus) $ descendBiM (synthProgramUnits marker vars) pu@@ -125,17 +114,5 @@     _ -> fmap (:pus) $ descendBiM (synthProgramUnits marker vars) pu synthProgramUnit marker vars pus pu = fmap (:pus) $ descendBiM (synthProgramUnits marker vars) pu --- Insert the correct comment markers around the given text string, depending on Fortran version.-commentText :: F.ProgramFile UA -> String -> String-commentText pf text | isModernFortran pf = "!" ++ text-                    | otherwise          = "c" ++ text---- Insert a given amount of spacing before the string.-insertSpacing :: F.ProgramFile UA -> Int -> String -> String-insertSpacing pf n | isModernFortran pf = (replicate n ' ' ++)-                   | otherwise          = id- -- Pretty print a unit declaration. showUnitDecl (sname, u) = "unit(" ++ show u ++ ") :: " ++ sname--isModernFortran (F.ProgramFile (F.MetaInfo { F.miVersion = v }) _ ) = v >= Fortran90
src/Camfort/Transformation/CommonBlockElim.hs view
@@ -15,17 +15,20 @@ -} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeSynonymInstances #-} -module Camfort.Transformation.CommonBlockElim where+module Camfort.Transformation.CommonBlockElim+  ( commonElimToModules+  ) where  import Control.Monad import Control.Monad.State.Lazy+import Control.Monad.Writer.Strict (execWriter, tell) -import Debug.Trace import Data.Data+import Data.Function (on) import Data.List-import Data.Ord import qualified Data.Map as M import Data.Generics.Uniplate.Operations @@ -57,11 +60,14 @@ type A1 = FA.Analysis Annotation type CommonState = State (Report, [TLCommon A]) +-- | Type for type-level annotations giving documentation+type (:?) a (b :: k) = a+ -- Top-level functions for eliminating common blocks in a set of files commonElimToModules ::        Directory-    -> [(Filename, F.ProgramFile A)]-    -> (Report, [(Filename, F.ProgramFile A)], [(Filename, F.ProgramFile A)])+    -> [F.ProgramFile A]+    -> (Report, [F.ProgramFile A], [F.ProgramFile A])  -- Eliminates common blocks in a program directory (and convert to modules) commonElimToModules d pfs =@@ -72,17 +78,16 @@     (r', pfM) = introduceModules meta d cg     pfs'' = updateUseDecls pfs' cg -analyseAndRmCommons :: [(Filename, F.ProgramFile A)]-               -> CommonState [(Filename, F.ProgramFile A)]+analyseAndRmCommons :: [F.ProgramFile A]+               -> CommonState [F.ProgramFile A] analyseAndRmCommons = mapM analysePerPF -analysePerPF ::-   (Filename, F.ProgramFile A) -> CommonState (Filename, F.ProgramFile A)-analysePerPF (fname, pf) = do+analysePerPF :: F.ProgramFile A -> CommonState (F.ProgramFile A)+analysePerPF pf = do    let pf' = FA.initAnalysis pf    let (pf'', tenv) = FAT.analyseTypes pf'-   pf''' <- transformBiM (analysePerPU tenv fname) pf''-   return (fname, fmap FA.prevAnnotation pf''')+   pf''' <- transformBiM (analysePerPU tenv (F.pfGetFilename pf)) pf''+   return (fmap FA.prevAnnotation pf''')  analysePerPU ::     FAT.TypeEnv -> Filename -> F.ProgramUnit A1 -> CommonState (F.ProgramUnit A1)@@ -94,7 +99,7 @@ collectAndRmCommons tenv fname pname = transformBiM commons   where     commons :: F.Statement A1 -> CommonState (F.Statement A1)-    commons f@(F.StCommon a s@(FU.SrcSpan p1 _) cgrps) = do+    commons (F.StCommon a s@(FU.SrcSpan p1 _) cgrps) = do         mapM_ commonGroups (F.aStrip cgrps)         let a' = onPrev (\ap -> ap {refactored = Just p1, deleteNode = True}) a         return $ F.StCommon a' (deleteLine s) (F.AList a s [])@@ -105,7 +110,7 @@      -- Process a common group, adding blocks to the common state     commonGroups :: F.CommonGroup A1 -> CommonState ()-    commonGroups (F.CommonGroup a (FU.SrcSpan p1 _) cname exprs) = do+    commonGroups (F.CommonGroup _ (FU.SrcSpan p1 _) cname exprs) = do       let r' = show p1 ++ ": removed common declaration\n"       let tcommon = map typeCommonExprs (F.aStrip exprs)       let info = (fname, (punitName pname, (commonNameFromAST cname, tcommon)))@@ -180,6 +185,7 @@     gcs = groupBy (\x y -> cmpEq $ cmpTLConBNames x y) commons     -- Group within by the different common block variable-type fields     gccs = map (sortBy (\y x -> length x `compare` length y) . group . sortBy cmpVarName) gcs+    cmpEq = (== EQ)  mkTLCommonRenamers :: [TLCommon A] -> [(TLCommon A, RenamerCoercer)] mkTLCommonRenamers commons =@@ -196,8 +202,8 @@                   map (\c -> (c, mkRenamerCoercerTLC c com)) (concat $ tail grp)) gccs     -- Now re-sort based on the file and program unit     commons' = sortBy (cmpFst cmpTLConFName) (sortBy (cmpFst cmpTLConPName) (concat gcrcs))+    cmpFst = (`on` fst) -type NameMap = M.Map F.Name F.Name  -- Nothing represents an overall identity renamer/coercer for efficiency -- a Nothing for a variable represent a variable-level (renamer) identity@@ -205,15 +211,6 @@ type RenamerCoercer =     Maybe (M.Map F.Name (Maybe F.Name, Maybe (F.BaseType, F.BaseType))) -applyRenaming :: (Typeable (t A), Data (t A)) => NameMap -> t A -> t A-applyRenaming r = transformBi rename-  where-    rename :: F.Value A -> F.Value A-    rename vn@(F.ValVariable v) =-        case M.lookup v r of-           Nothing -> vn-           Just v' -> F.ValVariable v'- class Renaming r where     hasRenaming :: F.Name -> r -> Bool @@ -226,11 +223,12 @@     hasRenaming v = any (hasRenaming v)  updateUseDecls ::-  [(Filename, F.ProgramFile A)] -> [TLCommon A] -> [(Filename, F.ProgramFile A)]+  [F.ProgramFile A] -> [TLCommon A] -> [F.ProgramFile A] updateUseDecls fps tcs = map perPF fps   where-    perPF (f, p@(F.ProgramFile (F.MetaInfo v _) _)) =-      (f, transformBi (importIncludeCommons v) $ transformBi (matchPUnit v f) p)+    perPF p@(F.ProgramFile (F.MetaInfo v _) _) =+      transformBi (importIncludeCommons v)+      $ transformBi (matchPUnit v (F.pfGetFilename p)) p     tcrs = mkTLCommonRenamers tcs      inames :: F.Statement A -> Maybe String@@ -241,6 +239,14 @@     importIncludeCommons v p =         foldl (flip (matchPUnit v)) p (reduceCollect inames p) +    -- Data-type generic reduce traversal+    reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a]+    reduceCollect k x = execWriter (transformBiM (\y -> do case k y of+                                                            Just x -> tell [x]+                                                            Nothing -> return ()+                                                           return y) x)++     insertUses :: [F.Block A] -> F.ProgramUnit A -> F.ProgramUnit A     insertUses uses = descendBi insertUses'       where insertUses' :: [F.Block A] -> [F.Block A]@@ -254,11 +260,17 @@                   F.Named pname -> pname                    -- If no subname is available, use the filename                   _             -> fname-        tcrs' = lookups' pname (lookups' fname tcrs)+        tcrs' = lookups pname (lookups fname tcrs)         pos = getUnitStartPosition p         uses = mkUseStatementBlocks pos tcrs'         p' = insertUses uses p+        -- Lookup functions over relation s +        lookups :: Eq a => a -> [((a, b), c)] -> [(b, c)]+        lookups x = map (\((_,b),c) -> (b, c))+          . filter ((==x) . fst . fst)++     -- Given the list of renamed/coercerd variables form common blocks,     -- remove any declaration sites     removeDecls :: PM.FortranVersion -> [RenamerCoercer] -> F.ProgramUnit A -> F.ProgramUnit A@@ -271,7 +283,7 @@     -- statements)     removeDecl :: [RenamerCoercer]                -> F.Statement A -> State [F.Statement A] (F.Statement A)-    removeDecl rcs d@(F.StDeclaration a s@(FU.SrcSpan p1 _) typ attr decls) = do+    removeDecl rcs (F.StDeclaration a s@(FU.SrcSpan p1 _) typ attr decls) = do         modify (++ assgns)         return $ F.StDeclaration a' (deleteLine s) typ attr decls'       where@@ -288,8 +300,8 @@         matchVar :: ([F.Statement A], [F.Declarator A]) -> F.Declarator A                  -> ([F.Statement A], [F.Declarator A])         matchVar (assgns, decls)-                     dec@(F.DeclVariable a s-                    lvar@(F.ExpValue _ _ (F.ValVariable v)) len init) =+                     dec@(F.DeclVariable _ s+                    lvar@(F.ExpValue _ _ (F.ValVariable v)) _ init) =            if hasRenaming v rcs            then case init of                    -- Renaming exists and no default, then remove@@ -339,7 +351,7 @@  renamerToUse :: RenamerCoercer -> [(F.Name, F.Name)] renamerToUse Nothing = []-renamerToUse (Just m) = let entryToPair v (Nothing, _) = []+renamerToUse (Just m) = let entryToPair _ (Nothing, _) = []                             entryToPair v (Just v', _) = [(v, v')]                         in M.foldlWithKey (\xs v e -> entryToPair v e ++ xs) [] m @@ -350,7 +362,7 @@     a = unitAnnotation { refactored = Just pos, newNode = True }     (FU.SrcSpan pos pos') = s     s' = FU.SrcSpan (toCol0 pos) pos'-    mkUseStmnt x@((name, _), r) = F.BlStatement a s' Nothing $+    mkUseStmnt x@((name, _), _) = F.BlStatement a s' Nothing $        F.StUse a s' useName F.Permissive useListA      where useName = F.ExpValue a s' (F.ValVariable (caml (commonName name)))            useListA = case useList of [] -> Nothing@@ -358,13 +370,13 @@            useList = mkUses pos x      mkUses :: FU.Position -> (TCommon A, RenamerCoercer) -> [F.Use A]-    mkUses s ((name, _), r) = map useRenamer (renamerToUse r)+    mkUses _ ((_, _), r) = map useRenamer (renamerToUse r)      useRenamer (v, vR) = F.UseRename a s' (F.ExpValue a s' (F.ValVariable v))                                           (F.ExpValue a s' (F.ValVariable vR))  mkRenamerCoercerTLC :: TLCommon A :? source -> TLCommon A :? target -> RenamerCoercer-mkRenamerCoercerTLC x@(fname, (pname, common1)) (_, (_, common2)) =+mkRenamerCoercerTLC (_, (_, common1)) (_, (_, common2)) =     mkRenamerCoercer common1 common2  mkRenamerCoercer :: TCommon A :? source -> TCommon A :? target -> RenamerCoercer@@ -387,9 +399,15 @@ allCoherentCommons commons =    foldM (\p (c1, c2) -> coherentCommons c1 c2 >>= \p' -> return $ p && p')      True (pairs commons)+   where+    -- Computes all pairwise combinations+    pairs :: [a] -> [(a, a)]+    pairs []     = []+    pairs (x:xs) = zip (repeat x) xs ++ pairs xs + coherentCommons :: TLCommon A -> TLCommon A -> (Report, Bool)-coherentCommons (f1, (p1, (n1, vtys1))) (f2, (p2, (n2, vtys2))) =+coherentCommons (_, (_, (n1, vtys1))) (_, (_, (n2, vtys2))) =     if n1 == n2     then coherentCommons' vtys1 vtys2     else error $ "Trying to compare differently named common blocks: "@@ -411,16 +429,17 @@     -- TODO - give more information in the error coherentCommons' _ _ = ("Common blocks of different field lengths", False) -introduceModules ::-    F.MetaInfo -> Directory -> [TLCommon A]-                            -> (Report, [(Filename, F.ProgramFile A)])+introduceModules :: F.MetaInfo+                 -> Directory+                 -> [TLCommon A]+                 -> (Report, [F.ProgramFile A]) introduceModules meta dir cenv =     mapM (mkModuleFile meta dir . head . head) (groupSortCommonBlock cenv)  mkModuleFile ::-  F.MetaInfo -> Directory -> TLCommon A -> (Report, (Filename, F.ProgramFile A))+  F.MetaInfo -> Directory -> TLCommon A -> (Report, F.ProgramFile A) mkModuleFile meta dir (_, (_, (name, varTys))) =-    (r, (path, F.pfSetFilename path $ F.ProgramFile meta [mod]))+    (r, F.pfSetFilename path $ F.ProgramFile meta [mod])   where     modname = commonName name     path = dir ++ modname ++ ".f90"
− src/Camfort/Transformation/DataTypeIntroduction.hs 
@@ -1,104 +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.--}--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}--module Camfort.Transformation.DataTypeIntroduction where--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.Analysis.Renaming as FAR-import qualified Language.Fortran.Analysis.BBlocks as FAB-import qualified Language.Fortran.Analysis.Types as FAT-import qualified Language.Fortran.Util.Position as FU-import qualified Language.Fortran.ParserMonad as PM-import qualified Language.Fortran.PrettyPrint as PP--import qualified Data.Graph.Inductive.PatriciaTree as G-import qualified Data.Graph.Inductive.Graph as IGr-import qualified Data.Map.Lazy as M-import Data.Generics.Uniplate.Operations--import qualified Data.Set as S-import Control.Monad.State.Lazy--import Camfort.Helpers-import Camfort.Helpers.Syntax-import Camfort.Analysis.Annotations--import qualified Data.IntMap as IM---- Array-subscript interference graphs, in a map from--- the array variable to the interference graph-type IGraphs = M.Map F.Name (G.Gr F.Name Int)---- Top-level-dataTypeIntro ::-  [(Filename, F.ProgramFile A)] -> (Report, [(Filename, F.ProgramFile A)])-dataTypeIntro pfs = (r, [])-  where-    r = buildInterferenceGraph pfs---- Stub, coalesce LVA information--- TODO, build interference graph-buildInterferenceGraph :: [(Filename, F.ProgramFile A)] -> String-buildInterferenceGraph = show . (foldr IM.union IM.empty) . map analysePerPF---- Stub, generate LVA information-analysePerPF ::-   (Filename, F.ProgramFile A) -> FAD.InOutMap (S.Set F.Name)-analysePerPF (fname, pf) = undefined-  where-    -- (report, pf'') = transformBiM (perStmt lva) pf-    -- initialise analysis-    pf'   = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ 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-    -- live variables-    lva   = FAD.liveVariableAnalysis gr---- Core of the transformation happens here on assignment statements---perStmt :: FAD.InOutMap -> S.Set F.Name---           -> F.Statement (FA.Analysis A) -> State IGraphs (F.Statement (FA.Analysis A))-perStmt lva x =-  case (FA.insLabel (F.getAnnotation x)) of-    Just label -> case (IM.lookup label lva) of-      Just (lva_in, _) -> undefined -- transformBiM (perStmt lva_in) x--{--perExpr :: FAD.InOutMap (S.Set F.Name)-        -> F.Expression (FA.Analysis A) -> State IGraphs (F.Expression (FA.Analysis A))-perExpr lva_in x@(F.ExpSubscript _ _ (F.ExpValue _ _ (F.ValVariable arrVar)) subs) = do-  let subscript_vars = [v | (F.ValVariable v) <- universeBi (F.aStrip subs) ]-  let intefering = [(v, w) | v <- subscript_vars,-                             w <- subscript_vars, v `S.member` lva_in && w `S.member` lva_in]-  igraphs <- get-  case (M.lookup arrVar igraphs) of-     Just igraph -> return x-          -- TODO: update graph here-     Nothing -> do-        let g0 = IGr.mkGraph undefined -- [(0, u),(1, v)] [(0, 1, ())]-        let m = M.fromList [(arrVar, g0)]-        put (m `M.union` igraphs)-        return x-perExpr _ x = return x--}
src/Camfort/Transformation/DeadCode.hs view
@@ -16,7 +16,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -module Camfort.Transformation.DeadCode where+module Camfort.Transformation.DeadCode+  ( deadCode+  ) where  import Camfort.Analysis.Annotations import qualified Language.Fortran.Analysis.DataFlow as FAD@@ -32,20 +34,17 @@ import qualified Data.Set as S import Data.Generics.Uniplate.Operations import Data.Maybe-import GHC.Generics -import Debug.Trace  -- 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 -> (Filename, F.ProgramFile A)-                 -> (Report, (Filename, F.ProgramFile A))-deadCode flag (fname, pf) = (report, (fname, fmap FA.prevAnnotation pf'))+deadCode :: Bool -> F.ProgramFile A -> (Report, F.ProgramFile A)+deadCode flag pf = (report, fmap FA.prevAnnotation pf')   where-    (report, pf'') = deadCode' flag lva pf'+    (report, _) = deadCode' flag lva pf'     -- initialise analysis     pf'   = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ pf     -- get map of program unit ==> basic block graph@@ -71,7 +70,7 @@ perStmt :: Bool         -> FAD.InOutMap (S.Set F.Name)         -> F.Statement (FA.Analysis A) -> (Report, F.Statement (FA.Analysis A))-perStmt flag lva x@(F.StExpressionAssign a sp@(FU.SrcSpan s1 s2) e1 e2)+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
src/Camfort/Transformation/EquivalenceElim.hs view
@@ -16,9 +16,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -module Camfort.Transformation.EquivalenceElim where+module Camfort.Transformation.EquivalenceElim+  ( refactorEquivalences+  ) where -import Data.Data import Data.List import qualified Data.Map as M import Data.Generics.Uniplate.Operations@@ -30,20 +31,17 @@ import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis as FA -import Camfort.Output import Camfort.Helpers import Camfort.Helpers.Syntax import Camfort.Analysis.Annotations import Camfort.Transformation.DeadCode -import Debug.Trace  type A1 = FA.Analysis Annotation type RmEqState = ([[F.Expression A1]], Int, Report) -refactorEquivalences ::-    (Filename, F.ProgramFile A) -> (Report, (Filename, F.ProgramFile A))-refactorEquivalences (fname, pf) = do+refactorEquivalences :: F.ProgramFile A -> (Report, F.ProgramFile A)+refactorEquivalences pf = do    -- initialise analysis    let pf'   = FAR.analyseRenames . FA.initAnalysis $ pf    -- calculate types@@ -53,7 +51,7 @@    -- Lastly deadcode eliminate any redundant copy statements    -- generated by the refactoring (but don't dead code elim    -- existing code)-   deadCode True (fname, fmap FA.prevAnnotation pf''')+   deadCode True (fmap FA.prevAnnotation pf''')   where     refactoring :: FAT.TypeEnv -> F.ProgramFile A1 -> (Report, F.ProgramFile A1)     refactoring tenv pf = (report, pf')@@ -69,8 +67,8 @@     return $ concat blockss  addCopysPerBlock :: FAT.TypeEnv -> F.Block A1 -> State RmEqState [F.Block A1]-addCopysPerBlock tenv x@(F.BlStatement a0 s0 lab-                 (F.StExpressionAssign a sp@(FU.SrcSpan s1 s2) dstE srcE))+addCopysPerBlock tenv x@(F.BlStatement _ _ _+                 (F.StExpressionAssign a sp@(FU.SrcSpan s1 _) dstE _))   | not (pRefactored $ FA.prevAnnotation a) = do     -- Find all variables/cells that are equivalent to the target     -- of this assignment@@ -132,7 +130,7 @@                      argst  = Just (F.AList a sp args)                      args   = map (F.Argument a sp Nothing) [srcE', dstE']        -- Types are equal, simple a assignment-       Just t -> F.StExpressionAssign a sp dstE' srcE'+       Just _ -> F.StExpressionAssign a sp dstE' srcE'   where      -- Set position to be at col = 0      sp   = FU.SrcSpan (toCol0 pos) (toCol0 pos)@@ -146,7 +144,7 @@ perBlockRmEquiv = transformBiM perStatementRmEquiv  perStatementRmEquiv :: F.Statement A1 -> State RmEqState (F.Statement A1)-perStatementRmEquiv f@(F.StEquivalence a sp@(FU.SrcSpan spL spU) equivs) = do+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)@@ -161,7 +159,7 @@     (equivs, _, _) <- get     return (inGroup x equivs)   where-    inGroup x [] = []+    inGroup _ [] = []     inGroup x (xs:xss) =         if AnnotationFree x `elem` map AnnotationFree xs         then xs
src/Main.hs view
@@ -15,139 +15,367 @@  {-# LANGUAGE DoAndIfThenElse #-} -module Main where--import System.Console.GetOpt-import System.Environment+module Main (main) where -import Camfort.Helpers+import Camfort.Input (defaultValue) import Camfort.Functionality+import Camfort.Specification.Stencils.InferenceFrontend (InferMode(..))+import Camfort.Specification.Units.Monad (LiteralsOpt(LitMixed)) -import Data.Text (pack, unpack, split)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>)) -{-| The entry point to CamFort. Displays user information, and-    handlers which functionality is being requested -}-main = do-  args <- getArgs-  putStrLn ""-  if length args >= 2 then+import Options.Applicative -    let (func : (inp : _)) = args-    in case lookup func functionality of-         Just (fun, _) -> do-           (opts, _) <- compilerOpts args -           (numReqArgs, outp) <--               if RefactorInPlace `elem` opts-                -- Does not check to see if an output directory-                -- is also specified since flags come last and therefore-                -- override any specification of an output directory-                -- (which would come earlier).-               then return (2, inp)-               else-                 if func `elem` outputNotRequired-                 then if length args >= 3 && (head (args !! 2) == '-')-                      then return (2, "")-                      else -- case where an unnecessary output is specified-                           return (3, "")-                 else if length args >= 3-                      then return (3, args !! 2)-                      else fail $ usage ++ "\nThis mode requires an output\-                                           \ file/directory to be specified\n\-                                           \ or use the --inplace flag to set\-                                           \ the ouput location to be the input\-                                           \ location."+-- | Commands supported by CamFort.+data Command = CmdCount ReadOptions+             | CmdAST ReadOptions+             | CmdStencilsCheck ReadOptions+             | CmdStencilsInfer StencilsOptions+             | CmdStencilsSynth StencilsSynthOptions+             | CmdUnitsSuggest UnitsOptions+             | CmdUnitsCheck UnitsOptions+             | CmdUnitsInfer UnitsOptions+             | CmdUnitsSynth UnitsSynthOptions+             | CmdUnitsCompile UnitsWriteOptions+             | CmdRefactCommon RefactOptions+             | CmdRefactDead RefactOptions+             | CmdRefactEquivalence RefactOptions+             | CmdTopVersion -           let excluded_files = map unpack . split (==',') . pack . getExcludes-           fun inp (excluded_files opts) outp opts-         Nothing -> putStrLn fullUsageInfo -  else do-    putStrLn introMsg-    if length args == 1-     then putStrLn $ usage ++ "Please specify an input file/directory"-     else putStrLn fullUsageInfo+-- | Options for reading files.+data ReadOptions = ReadOptions+  { inputSource :: String+  , exclude     :: Maybe [String]+  } --- * Options for CamFort  and information on the different modes -fullUsageInfo = usageInfo (usage ++ menu ++ "\nOptions:") options+-- | Options for writing to files.+--+-- User can choose to either specify which file to write, or have+-- the input files be written over.+data WriteOptions = WriteFile { _outputFile :: String }+                  | WriteInplace -options :: [OptDescr Flag]-options =-     [ Option ['v','?'] ["version"] (NoArg Version)-         "show version number"-     , Option [] ["inplace"] (NoArg RefactorInPlace)-         "refactor in place (replaces input files)"-     , Option ['e']     ["exclude"] (ReqArg Excludes "FILES")-         "files to exclude (comma separated list, no spaces)"-     , Option ['l']     ["units-literals"] (ReqArg (Literals . read) "ID")-         "units-of-measure literals mode. ID = Unitless, Poly, or Mixed"-     , Option ['m']     ["stencil-inference-mode"]-                (ReqArg (StencilInferMode . read . (++ "Mode")) "ID")-                "stencil specification inference mode. ID = Do, Assign, or Both"-     , Option ['I']     ["include-dir"]-                (ReqArg IncludeDir "DIR")-                "directory to search for precompiled files"-     , Option []        ["debug"] (NoArg Debug)-         "enable debug mode"-     , Option []        ["doxygen"] (NoArg Doxygen)-         "synthesise annotations compatible with Doxygen"-     , Option []        ["ford"] (NoArg Ford)-         "synthesise annotations compatible with Ford"-     ] -compilerOpts :: [String] -> IO ([Flag], [String])-compilerOpts argv =-  case getOpt Permute options argv of-    (o,n,[]  ) -> return (o,n)-    (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))-  where header = introMsg ++ usage ++ menu ++ "\nOptions:"+-- | Options used by stencil commands.+data StencilsOptions = StencilsOptions+  { soReadOptions  :: ReadOptions+  , soInferMode    :: InferMode+  } --- * Which modes do not require an output-outputNotRequired = ["count", "ast"-                  , "stencils-infer", "stencils-check"-                  , "units-infer", "units-check", "units-suggest"] -functionality = analyses ++ refactorings+-- | Options used by all unit commands.+data UnitsOptions = UnitsOptions+  { uoReadOptions :: ReadOptions+  , literals      :: LiteralsOpt+  , debug         :: Bool+  , includeDir    :: Maybe String+  } -{-| List of refactorings provided in CamFort -}-refactorings :: [(String-               , (FileOrDir -> [Filename] -> FileOrDir -> Options -> IO ()-               , String))]-refactorings =-    [("common", (common, "common block elimination")),-     ("equivalence", (equivalences, "equivalence elimination")),-     ("dead", (dead, "dead-code elimination")),-     ("datatype", (datatypes, "derived data type introduction"))] -{-| List of analses provided by CamFort -}-analyses :: [(String-           , (FileOrDir -> [Filename] -> FileOrDir -> Options -> IO ()-           , String))]-analyses =-    [-     ("count", (countVarDecls, "count variable declarations")),-     ("ast", (ast, "print the raw AST -- for development purposes")),-     ("stencils-check", (stencilsCheck, "stencil spec checking")),-     ("stencils-infer", (stencilsInfer, "stencil spec inference")),-     ("stencils-synth", (stencilsSynth, "stencil spec synthesis")),-     ("units-suggest", (unitsCriticals,-                                  "suggest variables to annotate with\-                                  \units-of-measure for maximum coverage")),-     ("units-check", (unitsCheck, "unit-of-measure checking")),-     ("units-infer", (unitsInfer, "unit-of-measure inference")),-     ("units-synth", (unitsSynth, "unit-of-measure synthesise specs.")),-     ("units-compile", (unitsCompile, "units-of-measure compile module information.")) ]+data UnitsWriteOptions = UnitsWriteOptions+  { uwoUnitsOptions :: UnitsOptions+  , uwoWriteOptions :: WriteOptions+  } --- * Usage and about information-version = "0.902"-introMsg = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure."-usage = "Usage: camfort <MODE> <INPUT> [OUTPUT] [OPTIONS...]\n"-menu =-  "Refactor functions:\n"-  ++ concatMap (\(k, (_, info)) -> space ++ k ++ replicate (15 - length k) ' '-  ++ "   [" ++ info ++ "] \n") refactorings-  ++ "\nAnalysis functions:\n"-  ++ concatMap (\(k, (_, info)) -> space ++ k ++ replicate (15 - length k) ' '-  ++ "   [" ++ info ++ "] \n") analyses-  where space = replicate 5 ' '++newtype AnnotationOptions =+  AnnotationOptions { annotationType :: AnnotationType }+++data UnitsSynthOptions = UnitsSynthOptions+  { usoUnitsWriteOptions :: UnitsWriteOptions+  , usoAnnotationOptions :: AnnotationOptions+  }+++data StencilsSynthOptions = StencilsSynthOptions+  { ssoStencilsOptions    :: StencilsOptions+  , ssoWriteOptions       :: WriteOptions+  , ssoAnnotationOptions  :: AnnotationOptions+  }+++-- | Options used by refactoring commands.+data RefactOptions = RefactOptions+  { rfoReadOptions  :: ReadOptions+  , rfoWriteOptions :: WriteOptions+  }+++-- | Parser for an argument representing an individual file or directory.+fileArgument :: Mod ArgumentFields String -> Parser String+fileArgument m = strArgument (metavar "FILENAME" <> action "file" <> m)+++-- | Parser for file options with multiple files specified+-- | as a comma-separated list.+multiFileOption :: Mod OptionFields [String] -> Parser [String]+multiFileOption m = option (list str)+                    (metavar "FILE..." <> action "file" <> m)+  where list :: ReadM String -> ReadM [String]+        list = fmap (splitBy ',')+        splitBy _ [] = []+        splitBy c xs = case break (==c) xs of+                         (xs', [])     -> [xs']+                         (xs', _:cs) -> xs' : splitBy c cs+++excludeOption :: Parser (Maybe [String])+excludeOption = optional $ multiFileOption $+     long "exclude"+  <> short 'e'+  <> help "files to exclude (comma separated list, no spaces)"+++-- | Parse options for 'ReadOptions'.+readOptions :: Parser ReadOptions+readOptions = fmap ReadOptions+  (fileArgument $ help "input file")+  <*> excludeOption+++-- | User must specify either an ouput file, or say that the file+-- | should be rewritten in place.+writeOptions :: Parser WriteOptions+writeOptions = (fmap WriteFile . fileArgument $+                 help "file to write output to")+               <|> (pure WriteInplace <* flag' ()+                     (   long "inplace"+                      <> help "write in place (replaces input files)"))+++stencilsOptions :: Parser StencilsOptions+stencilsOptions = fmap StencilsOptions+  readOptions <*> evalOption+  where+    evalOption = flag AssignMode EvalMode+      (    long "eval"+        <> help "provide additional evaluation reporting"+        <> internal)+++stencilsSynthOptions :: Parser StencilsSynthOptions+stencilsSynthOptions = fmap StencilsSynthOptions+  stencilsOptions <*> writeOptions <*> annotationOptions+++unitsOptions :: Parser UnitsOptions+unitsOptions = fmap UnitsOptions+      readOptions+  <*> literalsOption+  <*> debugOption+  <*> optional includeDirOption+  where+    literalsOption = option parseLiterals $+                     long "units-literals"+                     <> short 'l'+                     <> metavar "ID"+                     <> completeWith ["Unitless", "Poly", "Mixed"]+                     <> 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")+++unitsWriteOptions :: Parser UnitsWriteOptions+unitsWriteOptions = fmap UnitsWriteOptions+  unitsOptions <*> writeOptions+++annotationOptions :: Parser AnnotationOptions+annotationOptions = fmap AnnotationOptions $+  flag ATDefault Doxygen+    (long "doxygen" <> help "synthesise annotations compatible with Doxygen")+  <|> flag ATDefault Ford+    (long "ford" <> help "synthesise annotations compatible with Ford")+++unitsSynthOptions :: Parser UnitsSynthOptions+unitsSynthOptions = fmap UnitsSynthOptions+  unitsWriteOptions <*> annotationOptions+++refactOptions :: Parser RefactOptions+refactOptions = fmap RefactOptions+  readOptions <*> writeOptions+++cmdCount, cmdAST :: Parser Command+cmdCount = fmap CmdCount readOptions+cmdAST   = fmap CmdAST   readOptions+++cmdStencilsCheck, cmdStencilsInfer, cmdStencilsSynth :: Parser Command+cmdStencilsCheck = fmap CmdStencilsCheck readOptions+cmdStencilsInfer = fmap CmdStencilsInfer stencilsOptions+cmdStencilsSynth = fmap CmdStencilsSynth stencilsSynthOptions+++cmdUnitsSuggest, cmdUnitsCheck, cmdUnitsInfer+  , cmdUnitsSynth, cmdUnitsCompile :: Parser Command+cmdUnitsSuggest = fmap CmdUnitsSuggest unitsOptions+cmdUnitsCheck   = fmap CmdUnitsCheck   unitsOptions+cmdUnitsInfer   = fmap CmdUnitsInfer   unitsOptions+cmdUnitsSynth   = fmap CmdUnitsSynth   unitsSynthOptions+cmdUnitsCompile = fmap CmdUnitsCompile unitsWriteOptions+++cmdRefactCommon, cmdRefactDead, cmdRefactEquivalence :: Parser Command+cmdRefactCommon      = fmap CmdRefactCommon refactOptions+cmdRefactDead        = fmap CmdRefactDead refactOptions+cmdRefactEquivalence = fmap CmdRefactEquivalence refactOptions++-- | Helper for building a command alias.+--+-- Command aliases will not show up in the help text, nor be subject to completion.+commandAlias :: String -> Parser Command -> Mod CommandFields Command+commandAlias alias cmdParser = command alias . info cmdParser $ mempty++-- | Helper for building a parser for a group of commands.+commandsParser :: String -> [(String, [String], Parser Command, String)] -> Parser Command+commandsParser groupName commands =+  hsubparser (mconcat (fmap+                        (\(name, _, cmdParser, description) ->+                           (command name . info cmdParser . progDesc $ description))+                        commands)+  <> commandGroup groupName)+  <|> aliasSubParser+  where aliasSubParser = subparser $+          mconcat (fmap+                    (\(_, aliases, cmdParser, _) ->+                       mconcat $ fmap (`commandAlias` cmdParser) aliases)+                    commands)+          <> internal++analysesParser :: Parser Command+analysesParser = commandsParser "Analysis Commands" analysesCommands+  where+    analysesCommands =+      [ ("count",+          [],+          cmdCount,         "count variable declarations")+      , ("ast",+          [],+          cmdAST,           "print the raw AST -- for development purposes")+      , ("stencils-check",+          ["stencil-check", "check-stencils", "check-stencil"],+          cmdStencilsCheck, "stencil spec checking")+      , ("stencils-infer",+          ["stencil-infer", "infer-stencils", "infer-stencil"],+          cmdStencilsInfer, "stencil spec inference")+      , ("stencils-synth",+          ["stencil-synth", "synth-stencils", "synth-stencil"],+          cmdStencilsSynth, "stencil spec synthesis")+      , ("units-suggest",+          ["unit-suggest", "suggest-units", "suggest-unit"],+          cmdUnitsSuggest,  "suggest variables to annotate with units-of-measure for maximum coverage")+      , ("units-check",+          ["unit-check", "check-units", "check-unit"],+          cmdUnitsCheck,    "unit-of-measure checking")+      , ("units-infer",+          ["unit-infer", "infer-units", "infer-unit"],+          cmdUnitsInfer,    "unit-of-measure inference")+      , ("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") ]+++refactoringsParser :: Parser Command+refactoringsParser = commandsParser "Refactoring Commands" refactoringsCommands+  where+    refactoringsCommands =+      [ ("common",      [], cmdRefactCommon,      "common block elimination")+      , ("equivalence", [], cmdRefactEquivalence, "equivalence elimination")+      , ("dead",        [], cmdRefactDead,        "dead-code elimination") ]+++topLevelCommands :: Parser Command+topLevelCommands = versionOption+  where versionOption = pure CmdTopVersion <* switch+                        (  long "version"+                        <> short 'v'+                        <> short '?'+                        <> help "show version number")+++-- | Collective parser for all CamFort commands.+commandParser :: Parser Command+commandParser =+  helper <*> (analysesParser <|> refactoringsParser <|> topLevelCommands)+++main :: IO ()+main = do+  cmd <- execParser (info commandParser idm)+  runCommand cmd+  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+++-- | Current CamFort version.+version = "0.903"+++-- | Full CamFort version string.+versionMessage = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure."+++-- | Print the full version string.+displayVersion :: IO ()+displayVersion = putStrLn versionMessage
tests/Camfort/Analysis/CommentAnnotatorSpec.hs view
@@ -8,7 +8,7 @@ import Test.Hspec  import Data.Data-import Data.Generics.Uniplate.Data+import Control.Monad.Identity (runIdentity) import Control.Monad.Writer.Strict  import Language.Fortran.AST@@ -16,29 +16,35 @@ import Language.Fortran.Util.Position  import Camfort.Analysis.CommentAnnotator+import Camfort.Specification.Parser (mkParser, parseError, SpecParser)  p = SrcSpan (Position 0 1 1) (Position 0 1 1) +annotateWith :: (String -> String) -> ProgramFile A -> ProgramFile A+annotateWith s = runIdentity . annotateComments trivialParser ignore+  where trivialParser = mkParser (Right . s) []+        ignore        = const . const . pure $ ()+ spec =   describe "Comment annotator" $ do     it "annotates with no comment blocks" $-      runWriter (annotateComments (\_ -> Right "") pf) `shouldBe` (pf, [])+      annotateWith (const "") pf `shouldBe` pf      it "links & annotates single comment block" $-      runWriter (annotateComments (\_ -> Right "hello") pf2) `shouldBe` (pf2e, [])+      annotateWith (const "hello") pf2 `shouldBe` pf2e      it "link multiple comments to single statement" $-      runWriter (annotateComments (\s -> Right $ "!!!" ++ s) pf3) `shouldBe` (pf3e, [])+      annotateWith ("!!!"++) pf3 `shouldBe` pf3e      it "link comments to separate targets" $-      runWriter (annotateComments (\s -> Right $ "!!!" ++ s) pf4) `shouldBe` (pf4e, [])+      annotateWith ("!!!"++) pf4 `shouldBe` pf4e -    it "generates warnings when there is a partial match" $ do-      let parser _ = Left $ ProbablyAnnotation "This is a warning."-                     :: Either AnnotationParseError String-      shouldBe (runWriter (annotateComments parser pf5))-               (pf5e, [ "Error (1:1)-(1:1): This is a warning."-                      , "Error (1:1)-(1:1): This is a warning." ])+    it "allows handling of parse errors" $ do+      let parser :: SpecParser String String+          parser = mkParser (const $ Left "This is a warning.") []+      shouldBe (runWriter (annotateComments parser (\srcSpan err -> tell [(srcSpan, err)]) pf5))+               (pf5e, [ (initSrcSpan, parseError "This is a warning.")+                      , (initSrcSpan, parseError "This is a warning.")])  data A = A   { annLink :: Maybe (Block A)@@ -60,6 +66,9 @@  -- Test cases +mkComment :: String -> Comment a+mkComment = Comment . ("= "++)+ ea = A Nothing Nothing  pf = wrapBlocks bs@@ -67,56 +76,56 @@  pf2 = wrapBlocks bs2 bs2 =-  [ BlComment ea p (Comment "something")+  [ BlComment ea p (mkComment "something")   , BlStatement ea p Nothing (StPause ea p Nothing) ]  pf2e = wrapBlocks bs2e bs2e =-  [ BlComment (A (Just (bs2e !! 1)) (Just "hello")) p (Comment "something")+  [ BlComment (A (Just (bs2e !! 1)) (Just "hello")) p (mkComment "something")   , BlStatement ea p Nothing (StPause ea p Nothing) ]  pf3 = wrapBlocks bs3 bs3 =-  [ BlComment ea p (Comment "mistral")-  , BlComment ea p (Comment "orhan")-  , BlComment ea p (Comment "jean-pierre")-  , BlComment ea p (Comment "contrastin")+  [ BlComment ea p (mkComment "mistral")+  , BlComment ea p (mkComment "orhan")+  , BlComment ea p (mkComment "jean-pierre")+  , BlComment ea p (mkComment "contrastin")   , BlStatement ea p Nothing (StPause ea p Nothing) ]  pf3e = wrapBlocks bs3e bs3e =-  [ BlComment (A (Just (last bs3e)) (Just "!!!mistral")) p (Comment "mistral")-  , BlComment (A (Just (last bs3e)) (Just "!!!orhan")) p (Comment "orhan")-  , BlComment (A (Just (last bs3e)) (Just "!!!jean-pierre")) p (Comment "jean-pierre")-  , BlComment (A (Just (last bs3e)) (Just "!!!contrastin")) p (Comment "contrastin")+  [ BlComment (A (Just (last bs3e)) (Just "!!!mistral")) p (mkComment "mistral")+  , BlComment (A (Just (last bs3e)) (Just "!!!orhan")) p (mkComment "orhan")+  , BlComment (A (Just (last bs3e)) (Just "!!!jean-pierre")) p (mkComment "jean-pierre")+  , BlComment (A (Just (last bs3e)) (Just "!!!contrastin")) p (mkComment "contrastin")   , BlStatement ea p Nothing (StPause ea p Nothing) ]  pf4 = wrapBlocks bs4 bs4 =-  [ BlComment ea p (Comment "mistral")-  , BlComment ea p (Comment "contrastin")+  [ BlComment ea p (mkComment "mistral")+  , BlComment ea p (mkComment "contrastin")   , BlStatement ea p Nothing (StPause ea p Nothing)-  , BlComment ea p (Comment "dominic")-  , BlComment ea p (Comment "orchard")+  , BlComment ea p (mkComment "dominic")+  , BlComment ea p (mkComment "orchard")   , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ]  pf4e = wrapBlocks bs4e bs4e =-  [ BlComment (A (Just (bs4e !! 2)) (Just "!!!mistral")) p (Comment "mistral")-  , BlComment (A (Just (bs4e !! 2)) (Just "!!!contrastin")) p (Comment "contrastin")+  [ BlComment (A (Just (bs4e !! 2)) (Just "!!!mistral")) p (mkComment "mistral")+  , BlComment (A (Just (bs4e !! 2)) (Just "!!!contrastin")) p (mkComment "contrastin")   , BlStatement ea p Nothing (StPause ea p Nothing)-  , BlComment (A (Just (last bs4e)) (Just "!!!dominic")) p (Comment "dominic")-  , BlComment (A (Just (last bs4e)) (Just "!!!orchard")) p (Comment "orchard")+  , BlComment (A (Just (last bs4e)) (Just "!!!dominic")) p (mkComment "dominic")+  , BlComment (A (Just (last bs4e)) (Just "!!!orchard")) p (mkComment "orchard")   , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ]  pf5 = wrapBlocks bs5 bs5 =-  [ BlComment ea p (Comment "comment 1")-  , BlComment ea p (Comment "comment 2")+  [ BlComment ea p (mkComment "comment 1")+  , BlComment ea p (mkComment "comment 2")   , BlStatement ea p Nothing (StPause ea p Nothing) ]  pf5e = wrapBlocks bs5e bs5e =-  [ BlComment (A (Just (last bs5e)) Nothing) p (Comment "comment 1")-  , BlComment (A (Just (last bs5e)) Nothing) p (Comment "comment 2")+  [ BlComment (A (Just (last bs5e)) Nothing) p (mkComment "comment 1")+  , BlComment (A (Just (last bs5e)) Nothing) p (mkComment "comment 2")   , BlStatement ea p Nothing (StPause ea p Nothing) ]
+ tests/Camfort/Specification/ParserSpec.hs view
@@ -0,0 +1,40 @@+module Camfort.Specification.ParserSpec (spec) where++import Data.Either (isLeft)++import Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++import Camfort.Specification.Parser (looksLikeASpec, mkParser, runParser, SpecParser)++trivialParser :: SpecParser String String+trivialParser = mkParser Right ["test"]++canParseTo :: SpecParser String String -> String -> String -> Expectation+canParseTo p s e = runParser p s `shouldBe` Right e++parsesTriviallyTo :: String -> String -> Expectation+parsesTriviallyTo = canParseTo trivialParser++doesNotParse :: String -> Expectation+doesNotParse s = runParser trivialParser s `shouldSatisfy` isLeft++spec :: Test.Spec+spec = do+  describe "specification characters" $ do+    let expectedSupportedChars = "!=<>"+    mapM_+      (\c -> it ("supports " ++ show c) ((c:" test") `parsesTriviallyTo` "test"))+      expectedSupportedChars+    it "allows whitespace before specification character" $+      "  = test" `parsesTriviallyTo` "test"+    it "requires a specification character" $+      doesNotParse ""+    it "does not accept specifications starting with invalid characters" $+      doesNotParse "c test"+  describe "specification keywords" $ do+    let testParser = mkParser Right []+    it "does not require any to be present (parsing)" $+      canParseTo testParser "= test" "test"+    it "does not require any to be present (checking)" $+      looksLikeASpec testParser "= test" `shouldBe` True
tests/Camfort/Specification/Stencils/CheckSpec.hs view
@@ -2,23 +2,31 @@  module Camfort.Specification.Stencils.CheckSpec (spec) where -import Camfort.Analysis.CommentAnnotator+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 qualified Camfort.Specification.Stencils.Grammar as SYN+  (CheckResult, stencilChecking)+import Camfort.Specification.Stencils.Parser (specParser) import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.Syntax -import Test.Hspec+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 qualified Language.Fortran.Util.Position     as FU -promoteErrors :: Either String x -> Either AnnotationParseError x-promoteErrors (Left x)  = Left (ProbablyAnnotation x)-promoteErrors (Right x) = Right x+import Test.Hspec +parseAndConvert :: String -> Either SynToAstError (Either RegionDecl SpecDecl) parseAndConvert x =     let ?renv = []-    in SYN.specParser x >>= (promoteErrors . synToAst)-extract (Right (Right [(_, s)])) = s+    in case runParser specParser x of+         Left  _  -> error "received stencil with invalid syntax in test"+         Right v  -> synToAst v  spec :: Spec spec =@@ -27,39 +35,160 @@       it "parse and convert simple exact stencil (1)" $           parseAndConvert "= stencil forward(depth=1, dim=1) :: x"           `shouldBe`-            (Right $ Right [(["x"], Specification $-             Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))])+            (Right $ Right (["x"], Specification+             (Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]]))) True))        it "parse and convert simple exact stencil (2)" $           parseAndConvert "= stencil forward(depth=1, dim=1) :: x, y, z"           `shouldBe`-            (Right $ Right [(["x","y","z"], Specification $-             Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))])+            (Right $ Right (["x","y","z"], Specification+             (Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]]))) True)) +      it "parse and convert simple exact access spec (2)" $+          parseAndConvert "= access forward(depth=1, dim=1) :: x, y, z"+          `shouldBe`+            (Right $ Right (["x","y","z"], Specification+             (Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]]))) False))+       it "parse and convert simple exact stencil with nonpointed (2a)" $           parseAndConvert "= stencil centered(depth=1, dim=2, nonpointed) :: x, y, z"           `shouldBe`-            (Right $ Right [(["x","y","z"], Specification $-             Mult $ Exact (Spatial (Sum [Product [Centered 1 2 False]])))])+            (Right $ Right (["x","y","z"], Specification+             (Mult $ Exact (Spatial (Sum [Product [Centered 1 2 False]]))) True))        it "parse and convert simple upper bounded stencil (3)" $           parseAndConvert "= stencil atmost, forward(depth=1, dim=1) :: x"           `shouldBe`-            (Right $ Right [(["x"], Specification $-             Mult $ Bound Nothing (Just $ Spatial-                      (Sum [Product [Forward 1 1 True]])))])+            (Right $ Right (["x"], Specification+             (Mult $ Bound Nothing (Just $ Spatial+                      (Sum [Product [Forward 1 1 True]]))) True)) +      it "parse and convert simple upper bounded access spec (3)" $+          parseAndConvert "= access atmost, forward(depth=1, dim=1) :: x"+          `shouldBe`+            (Right $ Right (["x"], Specification+             (Mult $ Bound Nothing (Just $ Spatial+                      (Sum [Product [Forward 1 1 True]]))) False))+       it "parse and convert simple lower bounded stencil (4)" $           parseAndConvert "= stencil atleast, backward(depth=2, dim=1) :: x"           `shouldBe`-            (Right $ Right [(["x"], Specification $-             Mult $ Bound (Just $ Spatial-                      (Sum [Product [Backward 2 1 True]])) Nothing)])+            (Right $ Right (["x"], Specification+             (Mult $ Bound (Just $ Spatial+                      (Sum [Product [Backward 2 1 True]])) Nothing) True))        it "parse and convert stencil requiring distribution (5)" $-          parseAndConvert "= stencil atleast, readonce, (forward(depth=1, dim=1) * ((centered(depth=1, dim=2)) + backward(depth=3, dim=4))) :: frob"+          parseAndConvert "= stencil readonce, atleast, forward(depth=1, dim=1) * (centered(depth=1, dim=2) + backward(depth=3, dim=4)) :: frob"           `shouldBe`-            (Right $ Right [(["frob"], Specification $-             Once $ Bound (Just $ Spatial+            (Right $ Right (["frob"], Specification+             (Once $ Bound (Just $ Spatial                       (Sum [Product [Forward 1 1 True, Centered 1 2 True],-                            Product [Forward 1 1 True, Backward 3 4 True]])) Nothing)])+                            Product [Forward 1 1 True, Backward 3 4 True]])) Nothing) True))++      it "rejects stencils with undefined regions" $+         parseAndConvert "= stencil r1 :: a"+         `shouldBe` (Left . regionNotInScope $ "r1")++      describe "stencils check" $ do+        checkTestShow exampleUnusedRegion+          "warns about unused regions"+          "(2:3)-(2:34)    Warning: Unused region 'r1'"+        checkTestShow exampleRedefinedRegion+          "warns about redefined"+          "(4:3)-(4:34)    Region 'r1' already defined\n\+          \(6:5)-(6:32)    Correct."+        checkTestShow exampleSimpleInvalidSyntax+          "warns about specification parse errors"+          "(2:3)-(2:16)    Could not parse specification at: \"... \"\n"+        checkTestShow exampleSimpleCorrect+          "recognises correct stencils"+          "(4:5)-(4:63)    Correct."+        checkTestShow exampleUnusedRegionWithOtherSpecs+          "provides reports in correct order"+          "(3:3)-(3:34)    Warning: Unused region 'r1'\n\+          \(5:5)-(5:63)    Correct.\n\+          \(9:5)-(9:52)    Not well specified.\n\+          \        Specification is:\n\+          \                stencil readOnce, forward(depth=1, dim=1) :: a\n\n\+          \        but at (10:5)-(10:17) the code behaves as\n\+          \                stencil readOnce, forward(depth=1, dim=1, nonpointed) :: a\n\n\+          \(12:3)-(12:16)    Could not parse specification at: \"... \"\n"+        checkTestShow exampleSpecWrongVar+          "validates that a specification is applied to the correct variables"+          "(4:5)-(4:44)    Not well specified.\n\+          \        Specification is:\n\+          \                stencil readOnce, pointed(dim=1) :: b\n\n\+          \        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++runCheck :: String -> CheckResult+runCheck = checkText . BS.packChars++checkTestShow :: String -> String -> String -> SpecWith ()+checkTestShow exampleText testDescription expected =+  it testDescription $ show (runCheck exampleText) `shouldBe` expected++exampleUnusedRegion :: String+exampleUnusedRegion =+  "program example\n\+  \  != region :: r1 = pointed(dim=1)\n\+  \end program"++exampleRedefinedRegion :: String+exampleRedefinedRegion =+  "program example\n\+  \  real, dimension(10) :: a\n\+  \  != region :: r1 = forward(depth=1,dim=1, nonpointed)\n\+  \  != region :: r1 = pointed(dim=1)\n\+  \  do i = 1, 10\n\+  \    != stencil readOnce, r1 :: a\n\+  \    a(i) = a(i+1)\n\+  \  end do\n\+  \end program"++exampleSimpleCorrect :: String+exampleSimpleCorrect =+  "program example\n\+  \  real, dimension(10) :: a\n\+  \  do i = 1, 10\n\+  \    != stencil readOnce, forward(depth=1,dim=1,nonpointed) :: a\n\+  \    a(i) = a(i+1)\n\+  \  end do\n\+  \end program"++exampleSimpleInvalidSyntax :: String+exampleSimpleInvalidSyntax =+  "program example\n\+  \  != stencil foo\n\+  \end program"++exampleUnusedRegionWithOtherSpecs :: String+exampleUnusedRegionWithOtherSpecs =+  "program example\n\+  \  real, dimension(10) :: a, b\n\+  \  != region :: r1 = pointed(dim=1)\n\+  \  do i = 1, 10\n\+  \    != stencil readOnce, forward(depth=1,dim=1,nonpointed) :: a\n\+  \    a(i) = a(i+1)\n\+  \  end do\n\+  \  do i = 1, 10\n\+  \    != stencil readOnce, forward(depth=1,dim=1) :: a\n\+  \    a(i) = a(i+1)\n\+  \  end do\n\+  \  != stencil foo\n\+  \end program"++exampleSpecWrongVar :: String+exampleSpecWrongVar =+  "program example\n\+  \  real, dimension(10) :: a\n\+  \  do i = 1, 10\n\+  \    != stencil readOnce, pointed(dim=1) :: b\n\+  \    a(i) = a(i)\n\+  \  end do\n\+  \end program"
tests/Camfort/Specification/Stencils/ConsistencySpec.hs view
@@ -14,9 +14,9 @@ spec :: Spec spec =   describe "Consistency spec" $ do-    let fivePointSpec = Specification . Once . Exact . Spatial $+    let fivePointSpec = Specification (Once . Exact . Spatial $           Sum [ Product [ Centered 1 1 True, Centered 0 2 True ]-              , Product [ Centered 1 2 True, Centered 0 1 True ] ]+              , Product [ Centered 1 2 True, Centered 0 1 True ] ]) True     let offFivePoint =           return (V.Cons (Offsets . S.fromList $ [-1])                          (V.Cons (Offsets . S.fromList $ [0]) V.Nil))
tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs view
@@ -3,11 +3,9 @@ import qualified Camfort.Helpers.Vec as V  import Camfort.Specification.Stencils.Model-import Camfort.Specification.Stencils.Consistency import Camfort.Specification.Stencils.Syntax import Camfort.Specification.Stencils.DenotationalSemantics -import qualified Data.Set as S import Algebra.Lattice  import Test.Hspec
− tests/Camfort/Specification/Stencils/GrammarSpec.hs 
@@ -1,91 +0,0 @@-module Camfort.Specification.Stencils.GrammarSpec (spec) where--import Camfort.Analysis.CommentAnnotator-import Camfort.Specification.Stencils.Grammar--import Test.Hspec hiding (Spec)-import qualified Test.Hspec as Test--spec :: Test.Spec-spec =-  describe "Stencils - Grammar" $ do-    it "basic unmodified stencil" $-      parse "= stencil r1 + r2 :: a"-      `shouldBe`-        Right (SpecDec (Spatial [] (Or (Var "r1") (Var "r2"))) ["a"])--{- Should no longer be possible-    it "just pointed stencil" $-      parse "= stencil pointed(dims=1,2) :: a"-      `shouldBe`-        Right (SpecDec (Spatial [Pointed [1, 2]] Nothing) ["a"])--}---    it "basic modified stencil (1)" $-      parse "      = stencil readonce, r1 + r2 :: a"-      `shouldBe`-        Right (SpecDec (Spatial [ReadOnce] (Or (Var "r1") (Var "r2"))) ["a"])--{- Should no longer be possible-    it "basic monfieid stencil (2)" $-      parse "= stencil atleast, pointed(dims=1,2), \-             \       forward(depth=1, dim=1) :: x"-      `shouldBe`-        Right (SpecDec (Spatial [AtLeast,Pointed [1,2]] (Just $ Forward 1 1)) ["x"])--    it "basic stencil with pointed and nonpointed" $-      parse "= stencil atleast, pointed(dims=2),  \-            \        nonpointed(dims=1), forward(depth=1, dim=1) :: frob"-      `shouldBe`-        Right (SpecDec (Spatial [AtLeast, Nonpointed [1], Pointed [2]]-                               (Just $ Forward 1 1)) ["frob"])--}--    it "region defn" $-      parse "= region :: r = forward(depth=1, dim=1) + backward(depth=2, dim=2)"-      `shouldBe`-        Right (RegionDec "r" (Or (Forward 1 1 True) (Backward 2 2 True)))--    it "region defn syntactic permutation" $-      parse "= region :: r = forward(dim=1,depth=1) + backward(depth=2, dim=2)"-      `shouldBe`-        Right (RegionDec "r" (Or (Forward 1 1 True) (Backward 2 2 True)))--    it "region defn irreflx syntactic permutation" $-      parse "= region :: r = forward(nonpointed,dim=1,depth=1) + backward(depth=2,nonpointed,dim=2)"-      `shouldBe`-        Right (RegionDec "r" (Or (Forward 1 1 False) (Backward 2 2 False)))--{- Should no longer be possible-    it "complex stencil" $-      parse "= stencil atleast, pointed(dims=1,2), readonce, \-            \ (forward(depth=1, dim=1) + r) * backward(depth=3, dim=4) \-            \ :: frob"-      `shouldBe`-       Right (SpecDec (Spatial [AtLeast,ReadOnce,Pointed [1,2]]-             (Just $ And (Or (Forward 1 1) (Var "r")) (Backward 3 4))) ["frob"])--    it "invalid stencil (atLeast/atMost)" $-      parse "= stencil atleast, atmost, pointed(dims=1,2), \-             \       forward(depth=1, dim=1) :: x"-      `shouldBe`-        (Left $ ProbablyAnnotation $-          "Conflicting modifiers: cannot use 'atLeast' and 'atMost' together")--    it "invalid stencil (pointed/nonpointed on same dim)" $-      parse "= stencil atleast, nonpointed(dims=2), pointed(dims=1,2), \-             \ forward(depth=1, dim=1) :: x"-      `shouldBe`-        (Left $ ProbablyAnnotation $-              "Conflicting modifiers: stencil marked as both\-              \ nonpointed and pointed in dimensions = 2")--}---parse = specParser---- Local variables:--- mode: haskell--- haskell-program-name: "cabal repl test-suite:spec"--- End:
tests/Camfort/Specification/Stencils/ModelSpec.hs view
@@ -4,7 +4,6 @@  import Algebra.Lattice import qualified Data.Set as S-import Data.List.NonEmpty import qualified Camfort.Helpers.Vec as V  import Camfort.Specification.Stencils.Model
+ tests/Camfort/Specification/Stencils/ParserSpec.hs view
@@ -0,0 +1,160 @@+module Camfort.Specification.Stencils.ParserSpec (spec) where++import Data.Either (isLeft)++import Camfort.Specification.Parser (runParser)+import qualified Camfort.Specification.Parser as Parser+import Camfort.Specification.Stencils.Parser (specParser, SpecParseError)+import Camfort.Specification.Stencils.Parser.Types+import Camfort.Specification.Stencils.Model (+    Approximation(..)+  , Multiplicity(..))+import qualified Camfort.Specification.Stencils.Syntax as Syn++import Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++-- | Helper for building stencil strings.+stencilString :: String -> String+stencilString body = "= stencil " ++ body ++ " :: a"++-- | Helper for building stencils.+mkSpec :: Multiplicity (Approximation Region) -> Either a Specification+mkSpec m = Right (SpecDec (SpecInner m True) ["a"])++modifierTest :: String -> (Region -> Multiplicity (Approximation Region)) -> SpecWith ()+modifierTest modifiers f =+  it ("modified with " ++ modifiers) $ parse (stencilString (modifiers ++ " r1 + r2"))+  `shouldBe` (mkSpec . f $ Or (Var "r1") (Var "r2"))++-- | Check that a stencil specification does not parse.+--+-- Automatically inserts a leading "= stencil " and trailing " :: a".+invalidStencilTest :: String -> String -> SpecWith ()+invalidStencilTest description stencilStr =+  it description $ parse (stencilString stencilStr) `shouldSatisfy` isLeft++-- | Check that a stencil specification does not parse.+--+-- Tests the @stencilStr@ as is.+invalidStencilTest' :: String -> String -> SpecWith ()+invalidStencilTest' description stencilStr =+  it description $ parse stencilStr `shouldSatisfy` isLeft++-- | Check that a stencil specification does not parse, and that the+-- error string matches that provided.+--+-- Tests the @stencilStr@ as is.+invalidStencilTestStr :: String -- ^ Test description+                      -> String -- ^ Specification string+                      -> String -- ^ Expected error string+                      -> SpecWith ()+invalidStencilTestStr description stencilStr errStr =+  it description $ show (parse stencilStr) `shouldBe` ("Left " ++ errStr)++spec :: Test.Spec+spec =+  describe "Stencils - Parser" $ do+    it "basic unmodified stencil" $+      parse (stencilString "r1 + r2")+      `shouldBe`+        mkSpec (Mult . Exact $ Or (Var "r1") (Var "r2"))++    context "with modifiers" $ do+      modifierTest "readOnce,"          (Once . Exact)+      modifierTest "atLeast,"           (Mult . (`Bound` Nothing) . Just)+      modifierTest "atMost,"            (Mult . Bound Nothing . Just)+      modifierTest "readOnce, atLeast," (Once . (`Bound` Nothing) . Just)+      modifierTest "readOnce, atMost,"  (Once . Bound Nothing . Just)++    describe "modifiers are case insensitive" $ do+      modifierTest "readOnce, atLeast," (Once . (`Bound` Nothing) . Just)+      modifierTest "readOnce, atMost,"  (Once . Bound Nothing . Just)+      modifierTest "readonce, atleast," (Once . (`Bound` Nothing) . Just)+      modifierTest "readonce, atmost,"  (Once . Bound Nothing . Just)++    let dimDepthTest (depth, dim) =+          let depthDim = concat ["depth=", depth, ", dim=", dim]+          in it depthDim $+          parse (stencilString $ concat ["forward(", depthDim, ")"])+          `shouldBe` mkSpec (Mult . Exact $ RegionConst $+                                     Syn.Forward (read depth) (read dim) True)++    describe "depth and dim" $+        mapM_ dimDepthTest [("1", "1"), ("10", "20")]++    describe "invalid stencils" $ do+      invalidStencilTest "approximation before multiplicity"+        "atLeast, readOnce r1"+      invalidStencilTest "repeated multiplicities"+        "readOnce, readOnce r1"+      invalidStencilTest "repeated approximations"+        "atLeast, atLeast, r1"+      invalidStencilTest "multiple approximations"+        "atLeast, atMost, r1"+      invalidStencilTest "zero dim"+        "forward(depth=1, dim=0)"+      invalidStencilTest "zero depth"+        "forward(depth=0, dim=1)"+      invalidStencilTest "negative dim"+        "forward(depth=1, dim=-1)"+      invalidStencilTest "negative depth"+        "forward(depth=-1, dim=1)"+      invalidStencilTest "just pointed stencil"+        "pointed(dims=1,2)"+      invalidStencilTest "basic monfieid stencil (2)"+        "atleast, pointed(dims=1,2), forward(depth=1, dim=1)"+      invalidStencilTest "basic stencil with pointed and nonpointed"+        "atleast, pointed(dims=2),  \+            \        nonpointed(dims=1), forward(depth=1, dim=1)"+      invalidStencilTest "complex stencil"+        "atleast, pointed(dims=1,2), readonce, \+            \ (forward(depth=1, dim=1) + r) * backward(depth=3, dim=4)"+      invalidStencilTest "pointed/nonpointed on same dim"+        "atleast, nonpointed(dims=2), pointed(dims=1,2), \+             \ forward(depth=1, dim=1)"+      invalidStencilTest' "empty specification"+        "= stencil"+      invalidStencilTest' "only identifier"+        "= stencil foo"++    it "basic modified stencil (1)" $+      parse (stencilString "      readonce, r1 + r2")+      `shouldBe`+        mkSpec (Once . Exact $ Or (Var "r1") (Var "r2"))+++    let regionTestCase isRefl =+          Right (RegionDec "r"+                  (Or (RegionConst (Syn.Forward 1 1 isRefl))+                   (RegionConst (Syn.Backward 2 2 isRefl))))+    it "region defn" $+      parse "= region :: r = forward(depth=1, dim=1) + backward(depth=2, dim=2)"+      `shouldBe`+        regionTestCase True++    it "region defn syntactic permutation" $+      parse "= region :: r = forward(dim=1,depth=1) + backward(depth=2, dim=2)"+      `shouldBe`+        regionTestCase True++    it "region defn irreflx syntactic permutation" $+      parse "= region :: r = forward(nonpointed,dim=1,depth=1) + backward(depth=2,nonpointed,dim=2)"+      `shouldBe`+        regionTestCase False++    describe "error messages" $ do+      invalidStencilTestStr "invalid identifier"+        "= stencil foo$ :: a"+        "Invalid character in identifier: '$'"+      invalidStencilTestStr "invalid syntax"+        "= stencil readonce, readonce, pointed(dim=1) :: a"+        "Could not parse specification at: \"readonce... \"\n"++parse :: String -> Either (Parser.SpecParseError SpecParseError) Specification+parse = runParser specParser++-- Local variables:+-- mode: haskell+-- haskell-program-name: "cabal repl test-suite:spec"+-- End:
tests/Camfort/Specification/StencilsSpec.hs view
@@ -8,7 +8,6 @@  module Camfort.Specification.StencilsSpec (spec) where -import GHC.TypeLits  import Control.Monad.Writer.Strict hiding (Sum, Product) import Data.List@@ -16,21 +15,24 @@ import Camfort.Helpers.Vec import Camfort.Input import Camfort.Specification.Stencils+import Camfort.Specification.Stencils.Generate+  (Neighbour(..), indicesToSpec, convIxToNeighbour) import Camfort.Specification.Stencils.Synthesis import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.InferenceFrontend-import Camfort.Specification.Stencils.Syntax hiding (Spec)+import Camfort.Specification.Stencils.Syntax import qualified Language.Fortran.AST as F+import Language.Fortran.Parser.Any (deduceVersion) import Language.Fortran.ParserMonad import Camfort.Reprint import Camfort.Output -import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Functor.Identity import qualified Data.ByteString.Char8 as B +import System.Directory (listDirectory) import System.FilePath  import Test.Hspec@@ -108,36 +110,36 @@      describe "Example stencil inferences" $ do       it "five point stencil 2D" $-        inferFromIndices (VL fivepoint)+        inferFromIndicesWithoutLinearity (VL fivepoint)         `shouldBe`-         (Specification $ Once $ Exact $ Spatial+         (Specification (Mult $ Exact $ Spatial                      (Sum [ Product [ Centered 1 1 True, Centered 0 2 True]                           , Product [ Centered 0 1 True, Centered 1 2 True]-                          ]))+                          ])) True)        it "seven point stencil 2D" $-        inferFromIndices (VL sevenpoint)+        inferFromIndicesWithoutLinearity (VL sevenpoint)         `shouldBe`-          (Specification $ Once $ Exact $ Spatial+          (Specification (Mult $ Exact $ Spatial                        (Sum [ Product [ Centered 1 1 True, Centered 0 2 True, Centered 0 3 True]                             , Product [ Centered 0 1 True, Centered 1 2 True, Centered 0 3 True]                             , Product [ Centered 0 1 True, Centered 0 2 True, Centered 1 3 True]-                            ]))+                            ])) True)        it "five point stencil 2D with blip" $-         inferFromIndices (VL fivepointErr)+         inferFromIndicesWithoutLinearity (VL fivepointErr)          `shouldBe`-          (Specification $ Once $ Exact $ Spatial+          (Specification (Mult $ Exact $ Spatial                          (Sum [ Product [ Centered 1 1 True, Centered 0 2 True],                                 Product [ Centered 0 1 True, Centered 1 2 True],-                                Product [ Forward 1 1 True, Forward 1 2 True] ]))+                                Product [ Forward 1 1 True, Forward 1 2 True] ])) True)        it "centered forward" $-         inferFromIndices (VL centeredFwd)+         inferFromIndicesWithoutLinearity (VL centeredFwd)          `shouldBe`-          (Specification $ Once $ Exact $ Spatial+          (Specification (Mult $ Exact $ Spatial             (Sum [ Product [ Forward 1 1 True-                           , Centered 1 2 True] ]))+                           , Centered 1 2 True] ])) True)      describe "2D stencil verification" $       mapM_ (test2DSpecVariation (Neighbour "i" 0) (Neighbour "j" 0)) variations@@ -159,19 +161,19 @@                        [Neighbour "i" 0, Neighbour "j" 0]                        [[offsetToIx "i" 1, offsetToIx "j" 1],                         [offsetToIx "i" 0, offsetToIx "j" 0]]-         `shouldBe` (Just $ Specification $ Once $ Exact+         `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]])))+                               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+         `shouldBe` (Just $ Specification (Once $ Exact                        (Spatial-                         (Sum [Product [Centered 0 1 True, Forward 1 2 True]])))+                         (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)" $@@ -179,9 +181,9 @@                         [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+         `shouldBe` (Just $ Specification (Once $ Exact                        (Spatial-                         (Sum [Product [Centered 0 1 True, Backward 1 2 True]])))+                         (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)" $@@ -189,19 +191,19 @@                         [Neighbour "i" 1, Neighbour "j" 0]                         [[offsetToIx "j" absoluteRep, offsetToIx "i" 1],                          [offsetToIx "j" absoluteRep, offsetToIx "i" 0]]-         `shouldBe` (Just $ Specification $ Once $ Exact+         `shouldBe` (Just $ Specification (Once $ Exact                        (Spatial-                         (Sum [Product [Backward 1 2 True]])))+                         (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+         `shouldBe` (Just $ Specification (Once $ Exact                        (Spatial                          (Sum [Product [Centered 0 1 True,-                                        Forward 1 2 False]])))+                                        Forward 1 2 False]]))) True)        it "consistent (6) a(i) = b(i) + b(0) \                         \:: pointed(dim=1)" $@@ -228,66 +230,160 @@     -- Some integration tests     ------------------------- -    let file = "tests"-           </> "fixtures"-           </> "Specification"-           </> "Stencils"-           </> "example2.f"-    let fileSynthExpected = "tests"-           </> "fixtures"-           </> "Specification"-           </> "Stencils"-           </> "example2.expected.f"-    program <- runIO $ readParseSrcDir file []-    programSrc       <- runIO $ readFile file-    synthExpectedSrc <- runIO $ readFile fileSynthExpected+    let example2In = fixturesDir </> "example2.f"+    program <- runIO $ readParseSrcDir example2In []      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\n\-            \(41:8)-(41:94)    stencil readOnce, (centered(depth=1, dim=2)) \-                                                \+ (centered(depth=1, dim=1)) :: a"+            \(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"        it "stencil check" $-         fst (callAndSummarise (\f p -> (check f p, p)) program)+         fst (callAndSummarise (\p -> (check p, p)) program)            `shouldBe`            "\ntests/fixtures/Specification/Stencils/example2.f\n\-            \(23:1)-(23:82)    Correct.\n(31:1)-(31:56)    Correct."--      it "stencil synth" $-         (B.unpack . runIdentity-           $ reprint (refactoring Fortran77)-              (snd . head . snd $ synth AssignMode '=' (map (\(f, _, p) -> (f, p)) program))-              (B.pack programSrc))-          `shouldBe` synthExpectedSrc--    let file = "tests"-           </> "fixtures"-           </> "Specification"-           </> "Stencils"-           </> "example3.f"-    program <- runIO $ readParseSrcDir file []+            \(23:1)-(23:78)    Correct.\n(31:1)-(31:56)    Correct." -    let file = "tests"-           </> "fixtures"-           </> "Specification"-           </> "Stencils"-           </> "example4.f"-    program <- runIO $ readParseSrcDir file []+    let example4In = fixturesDir </> "example4.f"+    program <- runIO $ readParseSrcDir example4In []      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"+             \(6:8)-(6:33)    stencil readOnce, pointed(dim=1) :: x" +    describe "integration test on inference for example5" $+      describe "stencil synth" $ do+        assertStencilInferenceNoWarn "example5.f"+          "inserts correct comment types for old fortran"+        assertStencilInferenceNoWarn "example5.f90"+          "inserts correct comment types for modern fortran"++    describe "synth on files already containing stencils" $ do+      assertStencilInferenceNoWarn "example6.f"+        "complements existing stencils (when second missing)"+      assertStencilInferenceNoWarn "example7.f"+        "complements existing stencils (when none missing)"+      assertStencilInferenceNoWarn "example8.f"+        "complements existing stencils (when first missing)"+      assertStencilInferenceNoWarn "example9.f"+        "complements existing stencils (when none missing - only one stencil)"+      assertStencilInferenceNoWarn "example10.f"+        "complements existing stencils (when one missing - inside if)"+      assertStencilInferenceNoWarn "example13.f"+        "complements existing stencils (when using regions references)"+      assertStencilInferenceNoWarn "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."+      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."++      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."++      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"++      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"+++    describe "synth/inference works correctly with nested loops" $ do+      assertStencilInferenceNoWarn "nestedLoops.f90" "inserts correct specification"++    -- Run over all the samples and test fixtures++    sampleDirConts <- runIO $ listDirectory samplesDir+    expectedDirConts <- runIO $ listDirectory (samplesDir </> "expected")++    let hasExpectedSrcFile f = f `elem` expectedDirConts+        sampleFiles          = filter hasExpectedSrcFile sampleDirConts++    describe "sample file tests" $+        mapM_ (\file -> assertStencilInferenceSample+                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++        assertStencilInferenceDir expected dir fileName testComment =+          let file         = dir </> fileName+              version      = deduceVersion file+              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]++        assertStencilInferenceOnFile = assertStencilInferenceDir+          (\d f -> d </> getExpectedSrcFileName f) fixturesDir++        assertStencilInferenceSample = assertStencilInferenceDir+          (\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++        assertStencilSynthResponseOut fileName testComment expectedResponse =+          describe testComment $ do+            assertStencilInferenceOnFile fileName "correct synthesis"+            assertStencilSynthResponse fileName "correct output" expectedResponse++        assertStencilInferenceNoWarn 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+ -- 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)@@ -325,11 +421,10 @@        indicesToSpec' ["i", "j"] [a, b] (map fromFormatToIx input)           `shouldBe` Just expectedSpec   where-    expectedSpec = Specification expectation+    expectedSpec = Specification expectation True     fromFormatToIx [ri,rj] = [ offsetToIx "i" ri, offsetToIx "j" rj ] -indicesToSpec' ivs lhs = fst . runWriter . indicesToSpec ivmap "a" lhs-  where ivmap = IM.singleton 0 (S.fromList ivs)+indicesToSpec' ivs lhs = fst . runWriter . indicesToSpec ivs "a" lhs  variations =   [ ( [ [0,0] ]@@ -407,7 +502,7 @@            `shouldBe` Just expectedSpec    where-    expectedSpec = Specification expectation+    expectedSpec = Specification expectation True     fromFormatToIx [ri,rj,rk] =       [offsetToIx "i" ri, offsetToIx "j" rj, offsetToIx "k" rk] @@ -426,7 +521,7 @@  prop_extract_synth_inverse :: F.Name -> Int -> Bool prop_extract_synth_inverse v o =-     ixToNeighbour' [v] (offsetToIx v o) == Neighbour v o+     convIxToNeighbour [v] (offsetToIx v o) == Neighbour v o  -- Local variables: -- mode: haskell
+ tests/Camfort/Specification/Units/InferenceBackendSpec.hs view
@@ -0,0 +1,122 @@+module Camfort.Specification.Units.InferenceBackendSpec (spec) where++import GHC.Real ((%))++import           Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++import Camfort.Specification.Units.Environment+import Camfort.Specification.Units.InferenceBackend+  ( criticalVariables+  , flattenConstraints+  , inconsistentConstraints+  , inferVariables+  , shiftTerms )++spec :: Test.Spec+spec = do+  describe "Flatten constraints" $+    it "testCons1" $+      flattenConstraints testCons1 `shouldBe` testCons1_flattened+  describe "Shift terms" $ do+    it "testCons1" $+      map shiftTerms (flattenConstraints testCons1) `shouldBe` testCons1_shifted+    it "testCons2" $+      map shiftTerms (flattenConstraints testCons2) `shouldBe` testCons2_shifted+    it "testCons3" $+      map shiftTerms (flattenConstraints testCons3) `shouldBe` testCons3_shifted+  describe "Consistency" $ do+    it "testCons1" $+      inconsistentConstraints testCons1 `shouldBe` Just [ConEq (UnitName "kg") (UnitName "m")]+    it "testCons2" $+      inconsistentConstraints testCons2 `shouldBe` Nothing+    it "testCons3" $+      inconsistentConstraints testCons3 `shouldBe` Nothing+  describe "Critical Variables" $ do+    it "testCons2" $+      criticalVariables testCons2 `shouldSatisfy` null+    it "testCons3" $+      criticalVariables testCons3 `shouldBe` [UnitVar ("c", "c"), UnitVar ("e", "e")]+    it "testCons4" $+      criticalVariables testCons4 `shouldBe` [UnitVar ("simple2_a22", "simple2_a22")]+    it "testCons5" $+      criticalVariables testCons5 `shouldSatisfy` null+  describe "Infer Variables" $+    it "testCons5" $+      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]]++testCons1 = [ ConEq (UnitName "kg") (UnitName "m")+            , ConEq (UnitVar ("x", "x")) (UnitName "m")+            , ConEq (UnitVar ("y", "y")) (UnitName "kg")]++testCons1_flattened = [([UnitPow (UnitName "kg") 1.0],[UnitPow (UnitName "m") 1.0])+                      ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0])+                      ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])]++testCons1_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "kg") (-1.0)])+                    ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0])+                    ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])]++--------------------------------------------------++testCons2 = [ConEq (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0)))+            ,ConEq (UnitName "m") (UnitMul (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) (UnitName "s"))+            ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitParamPosUse (("simple1_sqr6", "sqr"),0,0)) (-1.0)))+            ,ConEq (UnitName "s") (UnitParamPosUse (("simple1_sqr6", "sqr"),1,0))+            ,ConEq (UnitVar ("simple1_a5", "simple1_a5")) (UnitAlias "accel")+            ,ConEq (UnitVar ("simple1_t4", "simple1_t4")) (UnitName "s")+            ,ConEq (UnitVar ("simple1_v3", "simple1_v3")) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0)))+            ,ConEq (UnitVar ("simple1_x1", "simple1_x1")) (UnitName "m")+            ,ConEq (UnitVar ("simple1_y2", "simple1_y2")) (UnitName "m")+            ,ConEq (UnitParamPosUse (("simple1_sqr6","sqr"),0,0)) (UnitParamPosUse (("simple1_mul7","mul"),0,1))+            ,ConEq (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) (UnitParamPosUse (("simple1_mul7","mul"),1,1))+            ,ConEq (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) (UnitParamPosUse (("simple1_mul7","mul"),2,1))+            ,ConEq (UnitParamPosUse (("simple1_mul7","mul"),0,1)) (UnitMul (UnitParamPosUse (("simple1_mul7","mul"),1,1)) (UnitParamPosUse (("simple1_mul7","mul"),2,1)))+            ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))]++testCons2_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0),UnitPow (UnitName "m") (-1.0),UnitPow (UnitName "s") 1.0])+                    ,([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "m") (-1.0)])+                    ,([UnitPow (UnitAlias "accel") 1.0,UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),0,0)) 1.0],[UnitPow (UnitName "m") 1.0])+                    ,([UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) (-1.0)],[UnitPow (UnitName "s") (-1.0)])+                    ,([UnitPow (UnitVar ("simple1_a5", "simple1_a5")) 1.0,UnitPow (UnitAlias "accel") (-1.0)],[])+                    ,([UnitPow (UnitVar ("simple1_t4", "simple1_t4")) 1.0],[UnitPow (UnitName "s") 1.0])+                    ,([UnitPow (UnitVar ("simple1_v3", "simple1_v3")) 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0)])+                    ,([UnitPow (UnitVar ("simple1_x1", "simple1_x1")) 1.0],[UnitPow (UnitName "m") 1.0])+                    ,([UnitPow (UnitVar ("simple1_y2", "simple1_y2")) 1.0],[UnitPow (UnitName "m") 1.0])+                    ,([UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),0,0)) 1.0,UnitPow (UnitParamPosUse (("simple1_mul7","mul"),0,1)) (-1.0)],[])+                    ,([UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) 1.0,UnitPow (UnitParamPosUse (("simple1_mul7","mul"),1,1)) (-1.0)],[])+                    ,([UnitPow (UnitParamPosUse (("simple1_sqr6","sqr"),1,0)) 1.0,UnitPow (UnitParamPosUse (("simple1_mul7","mul"),2,1)) (-1.0)],[])+                    ,([UnitPow (UnitParamPosUse (("simple1_mul7","mul"),0,1)) 1.0,UnitPow (UnitParamPosUse (("simple1_mul7","mul"),1,1)) (-1.0),UnitPow (UnitParamPosUse (("simple1_mul7","mul"),2,1)) (-1.0)],[])+                    ,([UnitPow (UnitAlias "accel") 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-2.0)])]++testCons3 = [ ConEq (UnitVar ("a", "a")) (UnitVar ("e", "e"))+            , ConEq (UnitVar ("a", "a")) (UnitMul (UnitVar ("b", "b")) (UnitMul (UnitVar ("c", "c")) (UnitVar ("d", "d"))))+            , ConEq (UnitVar ("d", "d")) (UnitName "m") ]++testCons3_shifted = [([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("e", "e")) (-1.0)],[])+                    ,([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("b", "b")) (-1.0),UnitPow (UnitVar ("c", "c")) (-1.0),UnitPow (UnitVar ("d", "d")) (-1.0)],[])+                    ,([UnitPow (UnitVar ("d", "d")) 1.0],[UnitPow (UnitName "m") 1.0])]++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 (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))+            ,ConEq (UnitAlias "accel") (UnitParamPosUse (("simple2_sqr3","sqr"),1,0))+            ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11"))+            ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitAlias "accel")+            ,ConEq (UnitParamPosUse (("simple2_sqr3","sqr"),0,0)) (UnitMul (UnitParamPosUse (("simple2_sqr3","sqr"),1,0)) (UnitParamPosUse (("simple2_sqr3","sqr"),1,0)))+            ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))]++testCons5_infer = [(("simple2_a11", "simple2_a11"),UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0)))+                  ,(("simple2_a22", "simple2_a22"),UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))]++testDoubleToRationalSubset :: Integer -> Integer -> Bool+testDoubleToRationalSubset x y =+    not (x <= 10 && y <= 10 && x >= -10 && y >= -10 && y /= 0)+      || doubleToRationalSubset (fromIntegral x / fromIntegral y) == Just (x % y)
+ tests/Camfort/Specification/Units/InferenceFrontendSpec.hs view
@@ -0,0 +1,295 @@+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/Units/ParserSpec.hs view
@@ -0,0 +1,45 @@+module Camfort.Specification.Units.ParserSpec (spec) where++import Camfort.Specification.Parser (runParser, SpecParseError)+import Camfort.Specification.Units.Parser (unitParser, UnitParseError)+import Camfort.Specification.Units.Parser.Types (UnitStatement)++import Test.Hspec++spec :: Spec+spec = do+  let shouldParseSameAs s s' =+        parseUnits s `shouldBe` parseUnits s'+      unitEquivalences =+        [ ("m * s", "m s")+        , ("m * s**2", "m s**2")+        , ("m * s/t", "m s/t")+        ]+  describe "Parsing Equivalence" $+    mapM_ (\(s1,s2) -> it (concat ["\"", s1, "\" is the same as \"", s2, "\""]) $+            s1 `shouldParseSameAs` s2) unitEquivalences++  describe "error messages" $ do+    invalidUnitSpecTestStr "invalid identifier character"+      "= unit ($) :: a"+      "Invalid character in identifier: '$'"+    invalidUnitSpecTestStr "invalid syntax"+      "= unit :: s"+      "Could not parse specification at: \"[]\"\n"++-- | Check that a unit specification does not parse, and that the+-- error string matches that provided.+--+-- Tests the @unitStr@ as is.+invalidUnitSpecTestStr :: String -- ^ Test description+                       -> String -- ^ Specification string+                       -> String -- ^ Expected error string+                       -> SpecWith ()+invalidUnitSpecTestStr description unitStr errStr =+  it description $ show (parse unitStr) `shouldBe` ("Left " ++ errStr)++parseUnits :: String -> Either (SpecParseError UnitParseError) UnitStatement+parseUnits = parse . (\s -> "= unit " ++ s ++ " :: a")++parse :: String -> Either (SpecParseError UnitParseError) UnitStatement+parse = runParser unitParser
tests/Camfort/Specification/UnitsSpec.hs view
@@ -1,433 +1,37 @@-{-# LANGUAGE ImplicitParams #-} module Camfort.Specification.UnitsSpec (spec) where -import qualified Data.ByteString.Char8 as B--import Language.Fortran.Parser.Any-import Language.Fortran.ParserMonad (fromRight)-import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Renaming as FAR-import Data.Generics.Uniplate.Operations-import Camfort.Input-import Camfort.Functionality-import Camfort.Output-import Camfort.Analysis.Annotations-import Camfort.Specification.Units-import Camfort.Specification.Units.Monad-import Camfort.Specification.Units.InferenceFrontend-import Camfort.Specification.Units.InferenceBackend-import Camfort.Specification.Units.Environment-import Data.List-import Data.Maybe-import Data.Either-import qualified Data.Array as A-import qualified Numeric.LinearAlgebra as H-import qualified Data.Map.Strict as M-import GHC.Real-import Numeric.LinearAlgebra (-    atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols,-    takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks,-    ident, flatten, lu, dispf, Matrix-  )+import System.FilePath ((</>))  import Test.Hspec-import Test.QuickCheck-import Test.Hspec.QuickCheck -runFrontendInit litMode pf = usConstraints state-  where-    pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf-    uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode }-    (_, state, logs) = runUnitSolver uOpts pf' initInference--runUnits litMode pf m = (r, usConstraints state)-  where-    pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf-    uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode }-    (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m--runUnits' litMode pf m = (state, logs)-  where-    pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf-    uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = True, uoLiterals = litMode }-    (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m--runUnitsRenamed' litMode pf m = (state, logs)-  where-    pf' = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf-    uOpts = unitOpts0 { uoNameMap = FAR.extractNameMap pf', uoDebug = True, uoLiterals = litMode }-    (r, state, logs) = 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 . fmap (const unitAnnotation) $ pf-    uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode }-    (r, state, logs) = 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-+import Camfort.Input (readParseSrcDir)+import Camfort.Specification.Units (checkUnits)+import Camfort.Specification.Units.Monad+  (LiteralsOpt(..), unitOpts0, uoDebug, uoLiterals)  spec :: Spec-spec = do-  let showClean = show . nub . sort . head . rights . (:[]) . fst-  describe "Unit Inference Frontend" $ do-    describe "Literal Mode" $ do-      it "litTest1 Mixed" $ do-        (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" $ do-        (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" $ do-        (fromJust (head (rights [fst (runUnits LitUnitless litTest1 runInconsistentConstraints)]))) `shouldSatisfy`-          any (conParamEq (ConEq UnitlessLit (UnitVar ("j", "j"))))-      it "Polymorphic non-zero literal is not OK" $ do-        head (rights [fst (runUnits LitMixed inconsist1 runInconsistentConstraints)]) `shouldSatisfy` isJust--    describe "Polymorphic functions" $ do-      it "squarePoly1" $ do-        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" $ do-      it "Recursive Addition is OK" $ do-        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" $ do-      it "Recursive Multiplication is not OK" $ do-        (fromJust (head (rights [fst (runUnits LitMixed recursive2 runInconsistentConstraints)]))) `shouldSatisfy`-          any (conParamEq (ConEq (UnitParamPosAbs ("recur", 0)) (UnitParamPosAbs ("recur", 2))))-    describe "Explicitly annotated parametric polymorphic unit variables" $ do-      it "inside-outside" $ do-        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" $ do-        show (sort (fst (runUnitInference LitMixed eapVarScope))) `shouldBe`-          "[(\"f\",('a)**3),(\"g\",'a),(\"j\",'a),(\"k\",('a)**3),(\"x\",'a),(\"y\",'a)]"-      it "eapVarApp" $ do-        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" $ do-      it "inferPoly1" $ do-        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" $ do-      it "sqrtPoly" $ do-        show (sort (fst (runUnitInference LitMixed sqrtPoly))) `shouldBe`-          "[(\"a\",m**2),(\"b\",s**4),(\"c\",j**2),(\"n\",'a),(\"x\",m),(\"y\",s),(\"z\",j)]"--  describe "Unit Inference Backend" $ do-    describe "Flatten constraints" $ do-      it "testCons1" $ do-        flattenConstraints testCons1 `shouldBe` testCons1_flattened-    describe "Shift terms" $ do-      it "testCons1" $ do-        map shiftTerms (flattenConstraints testCons1) `shouldBe` testCons1_shifted-      it "testCons2" $ do-        map shiftTerms (flattenConstraints testCons2) `shouldBe` testCons2_shifted-      it "testCons3" $ do-        map shiftTerms (flattenConstraints testCons3) `shouldBe` testCons3_shifted-    describe "Consistency" $ do-      it "testCons1" $ do-        inconsistentConstraints testCons1 `shouldBe` Just [ConEq (UnitName "kg") (UnitName "m")]-      it "testCons2" $ do-        inconsistentConstraints testCons2 `shouldBe` Nothing-      it "testCons3" $ do-        inconsistentConstraints testCons3 `shouldBe` Nothing-    describe "Critical Variables" $ do-      it "testCons2" $ do-        criticalVariables testCons2 `shouldSatisfy` null-      it "testCons3" $ do-        criticalVariables testCons3 `shouldBe` [UnitVar ("c", "c"), UnitVar ("e", "e")]-      it "testCons4" $ do-        criticalVariables testCons4 `shouldBe` [UnitVar ("simple2_a22", "simple2_a22")]-      it "testCons5" $ do-        criticalVariables testCons5 `shouldSatisfy` null-    describe "Infer Variables" $ do-      it "testCons5" $ do-        show (inferVariables testCons5) `shouldBe` show testCons5_infer-    describe "Check that (restricted) double to ratios is consistent" $ do-      it "test all in -10/-10 ... 10/10, apart from /0" $-        do and [testDoubleToRationalSubset x y | x <- [-10..10], y <- [-10..10]]------------------------------------------------------testCons1 = [ ConEq (UnitName "kg") (UnitName "m")-            , ConEq (UnitVar ("x", "x")) (UnitName "m")-            , ConEq (UnitVar ("y", "y")) (UnitName "kg")]--testCons1_flattened = [([UnitPow (UnitName "kg") 1.0],[UnitPow (UnitName "m") 1.0])-                      ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0])-                      ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])]--testCons1_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "kg") (-1.0)])-                    ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0])-                    ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])]------------------------------------------------------testCons2 = [ConEq (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0)))-            ,ConEq (UnitName "m") (UnitMul (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) (UnitName "s"))-            ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) (-1.0)))-            ,ConEq (UnitName "s") (UnitParamPosUse ("simple1_sqr6",1,0))-            ,ConEq (UnitVar ("simple1_a5", "simple1_a5")) (UnitAlias "accel")-            ,ConEq (UnitVar ("simple1_t4", "simple1_t4")) (UnitName "s")-            ,ConEq (UnitVar ("simple1_v3", "simple1_v3")) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0)))-            ,ConEq (UnitVar ("simple1_x1", "simple1_x1")) (UnitName "m")-            ,ConEq (UnitVar ("simple1_y2", "simple1_y2")) (UnitName "m")-            ,ConEq (UnitParamPosUse ("simple1_sqr6",0,0)) (UnitParamPosUse ("simple1_mul7",0,1))-            ,ConEq (UnitParamPosUse ("simple1_sqr6",1,0)) (UnitParamPosUse ("simple1_mul7",1,1))-            ,ConEq (UnitParamPosUse ("simple1_sqr6",1,0)) (UnitParamPosUse ("simple1_mul7",2,1))-            ,ConEq (UnitParamPosUse ("simple1_mul7",0,1)) (UnitMul (UnitParamPosUse ("simple1_mul7",1,1)) (UnitParamPosUse ("simple1_mul7",2,1)))-            ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))]--testCons2_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0),UnitPow (UnitName "m") (-1.0),UnitPow (UnitName "s") 1.0])-                    ,([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "m") (-1.0)])-                    ,([UnitPow (UnitAlias "accel") 1.0,UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) 1.0],[UnitPow (UnitName "m") 1.0])-                    ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) (-1.0)],[UnitPow (UnitName "s") (-1.0)])-                    ,([UnitPow (UnitVar ("simple1_a5", "simple1_a5")) 1.0,UnitPow (UnitAlias "accel") (-1.0)],[])-                    ,([UnitPow (UnitVar ("simple1_t4", "simple1_t4")) 1.0],[UnitPow (UnitName "s") 1.0])-                    ,([UnitPow (UnitVar ("simple1_v3", "simple1_v3")) 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0)])-                    ,([UnitPow (UnitVar ("simple1_x1", "simple1_x1")) 1.0],[UnitPow (UnitName "m") 1.0])-                    ,([UnitPow (UnitVar ("simple1_y2", "simple1_y2")) 1.0],[UnitPow (UnitName "m") 1.0])-                    ,([UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",0,1)) (-1.0)],[])-                    ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",1,1)) (-1.0)],[])-                    ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",2,1)) (-1.0)],[])-                    ,([UnitPow (UnitParamPosUse ("simple1_mul7",0,1)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",1,1)) (-1.0),UnitPow (UnitParamPosUse ("simple1_mul7",2,1)) (-1.0)],[])-                    ,([UnitPow (UnitAlias "accel") 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-2.0)])]--testCons3 = [ ConEq (UnitVar ("a", "a")) (UnitVar ("e", "e"))-            , ConEq (UnitVar ("a", "a")) (UnitMul (UnitVar ("b", "b")) (UnitMul (UnitVar ("c", "c")) (UnitVar ("d", "d"))))-            , ConEq (UnitVar ("d", "d")) (UnitName "m") ]--testCons3_shifted = [([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("e", "e")) (-1.0)],[])-                    ,([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("b", "b")) (-1.0),UnitPow (UnitVar ("c", "c")) (-1.0),UnitPow (UnitVar ("d", "d")) (-1.0)],[])-                    ,([UnitPow (UnitVar ("d", "d")) 1.0],[UnitPow (UnitName "m") 1.0])]--testCons4 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse ("simple2_sqr3",0,0))-            ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitParamPosUse ("simple2_sqr3",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 (UnitParamPosUse ("simple2_sqr3",0,0)) (UnitMul (UnitParamPosUse ("simple2_sqr3",1,0)) (UnitParamPosUse ("simple2_sqr3",1,0)))]--testCons5 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse ("simple2_sqr3",0,0))-            ,ConEq (UnitAlias "accel") (UnitParamPosUse ("simple2_sqr3",1,0))-            ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11"))-            ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitAlias "accel")-            ,ConEq (UnitParamPosUse ("simple2_sqr3",0,0)) (UnitMul (UnitParamPosUse ("simple2_sqr3",1,0)) (UnitParamPosUse ("simple2_sqr3",1,0)))-            ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))]--testCons5_infer = [(("simple2_a11", "simple2_a11"),UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0)))-                  ,(("simple2_a22", "simple2_a22"),UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))]--testDoubleToRationalSubset :: Integer -> Integer -> Bool-testDoubleToRationalSubset x y =-    if x <= 10 && y <= 10 && x >= -10 && y >= -10 && y /= 0-    then doubleToRationalSubset (fromIntegral x / fromIntegral y) == Just (x % y)-    else True-----------------------------------------------------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" ]+spec =+  describe "fixtures integration tests" $+    describe "units-check" $+      it "reports (simple) inconsistent units" $+         "example-inconsist-1.f90" `unitsCheckReportIs` exampleInconsist1CheckReport --- 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" ]+fixturesDir :: String+fixturesDir = "tests" </> "fixtures" </> "Specification" </> "Units" --- 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" ]+-- | 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 } -fortranParser' = \x -> fromRight . (fortranParser x)+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
@@ -5,7 +5,6 @@  import Test.Hspec -import Camfort.Helpers import Camfort.Functionality  samplesBase :: FilePath@@ -30,7 +29,7 @@       expectedMod <- runIO $ readSample "cmn.expected.f90"        let outFile = samplesBase </> "common.f90.out"-      runIO $ common (samplesBase </> "common.f90") [] outFile ()+      runIO $ common (samplesBase </> "common.f90") [] outFile        actual    <- runIO $ readSample "common.f90.out"       actualMod <- runIO $ readSample "cmn.f90"
tests/Camfort/Transformation/EquivalenceElimSpec.hs view
@@ -16,7 +16,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -module Camfort.Transformation.EquivalenceElimSpec where+module Camfort.Transformation.EquivalenceElimSpec (spec) where  import System.FilePath import System.Directory@@ -25,7 +25,6 @@  import Camfort.Transformation.EquivalenceElim import Camfort.Functionality-import Camfort.Helpers import Camfort.Input  samplesBase :: FilePath@@ -40,7 +39,7 @@ readActual argumentFilename = do   let argumentPath = samplesBase </> argumentFilename   let outFile = argumentPath `addExtension` "out"-  equivalences argumentPath [] outFile ()+  equivalences argumentPath [] outFile   actual <- readFile outFile   removeFile outFile   return actual
+ tests/fixtures/Specification/Stencils/example10.f view
@@ -0,0 +1,15 @@+      program example10++      integer i, imax+      parameter (imax = 3)++      real a(0:imax), b(0:imax)++      do 1 i = 1, (imax-1)+         if (.true.) then+c= stencil readOnce, (pointed(dim=1)) :: b+        a(i) = b(i)+         end if+ 1    continue++      end
+ tests/fixtures/Specification/Stencils/example11.f view
@@ -0,0 +1,14 @@+      program example11++      integer i, imax+      parameter (imax = 3)++      real a(0:imax), b(0:imax), x++      do 1 i = 1, (imax-1)+         if (.true.) then+        x = b(i)+         end if+ 1    continue++      end
+ tests/fixtures/Specification/Stencils/example12.f view
@@ -0,0 +1,12 @@+      program example12+      implicit none++      integer i+      real a(0:10)++      do i = 0, 10+c= stencil readOnce, (backward(depth=1, dim=1)) :: a+            a(i) = a(i) + a(i+1)+      end do++      end
+ tests/fixtures/Specification/Stencils/example13.f view
@@ -0,0 +1,15 @@+      program example13+      implicit none++      integer i, imax+      parameter (imax = 3)+      real a(0:imax)++c= region :: r1 = pointed(dim=1)+      do i = 0, imax+c= stencil readOnce, atLeast, r1 :: a+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+            a(i) = a(i) + a(i+2)+      end do++      end
+ tests/fixtures/Specification/Stencils/example14.f view
@@ -0,0 +1,14 @@+      program example14+      implicit none++      integer i, imax+      parameter (imax = 3)+      real a(0:imax)++      do i = 0, imax+c= stencil readOnce, atLeast, pointed(dim=1) :: a+c= stencil readOnce, atLeast, pointed(dim=1) :: a+            a(i) = a(i) + a(i+2)+      end do++      end
+ tests/fixtures/Specification/Stencils/example15.f view
@@ -0,0 +1,13 @@+      program example15+      implicit none++      integer i+      real a(0:10)++      do i = 0, 10+c= stencil readOnce, forward(depth=1, dim=1) :: a+c= stencil readOnce, forward(depth=1, dim=1) :: a+            a(i) = a(i) + a(i+1)+      end do++      end
+ tests/fixtures/Specification/Stencils/example16.f view
@@ -0,0 +1,12 @@+      program example16+      implicit none++      integer i+      real a(0:10)++      do i = 0, 10+c= access readOnce, (forward(depth=1, dim=1)) :: a+            a(i) = a(i) + a(i+1)+      end do++      end
+ tests/fixtures/Specification/Stencils/example17.f view
@@ -0,0 +1,12 @@+      program example16+      implicit none++      integer i+      real a(0:10), x++      do i = 0, 10+c= stencil readOnce, (forward(depth=1, dim=1)) :: a+            x = a(i) + a(i+1)+      end do++      end
tests/fixtures/Specification/Stencils/example2.f view
@@ -20,7 +20,7 @@             if (.true.) then c= region :: r2 = centered(depth=1, dim=2)                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               +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)
+ tests/fixtures/Specification/Stencils/example5.f view
@@ -0,0 +1,12 @@+      program example5+      implicit none++      integer i, imax+      parameter (imax = 3)+      real a(0:imax)++      do i = 0, imax+            a(i) = a(i) + a(i+2)+      end do++      end
+ tests/fixtures/Specification/Stencils/example6.f view
@@ -0,0 +1,13 @@+      program example6+      implicit none++      integer i, imax+      parameter (imax = 3)+      real a(0:imax)++      do i = 0, imax+c= stencil readOnce, atLeast, pointed(dim=1) :: a+            a(i) = a(i) + a(i+2)+      end do++      end
+ tests/fixtures/Specification/Stencils/example7.f view
@@ -0,0 +1,14 @@+      program example7+      implicit none++      integer i, imax+      parameter (imax = 3)+      real a(0:imax)++      do i = 0, imax+c= stencil readOnce, atLeast, pointed(dim=1) :: a+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+            a(i) = a(i) + a(i+2)+      end do++      end
+ tests/fixtures/Specification/Stencils/example8.f view
@@ -0,0 +1,13 @@+      program example8+      implicit none++      integer i, imax+      parameter (imax = 3)+      real a(0:imax)++      do i = 0, imax+c= stencil readOnce, atMost, forward(depth=2, dim=1) :: a+            a(i) = a(i) + a(i+2)+      end do++      end
+ tests/fixtures/Specification/Stencils/example9.f view
@@ -0,0 +1,13 @@+      program example9++      integer i, imax+      parameter (imax = 3)++      real a(0:imax), b(0:imax)++      do 1 i = 1, (imax-1)+c= stencil readOnce, pointed(dim=1) :: b+        a(i) = b(i)+ 1    continue++      end
+ tests/fixtures/Specification/Units/example-inconsist-1.f90 view
@@ -0,0 +1,8 @@+program example+  implicit none+  != unit (s) :: x+  != unit (m) :: y+  integer :: x, y+  integer :: z+  z = x + y+end program example