camfort 0.802 → 0.804

raw patch · 45 files changed

+2959/−3075 lines, 45 filesdep −regex-basedep −regex-pcredep ~arraydep ~basedep ~fortran-srcPVP ok

version bump matches the API change (PVP)

Dependencies removed: regex-base, regex-pcre

Dependency ranges changed: array, base, fortran-src, ghc-prim, hmatrix

API changes (from Hackage documentation)

Files

• camfort.cabal +47/−55
• dist/build/Camfort/Specification/Units/Parser.hs +2/−2
• dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs +2/−2
• eval/Analyse.hs +0/−299
• src/Camfort/Analysis/Annotations.hs +27/−8
• src/Camfort/Analysis/CommentAnnotator.hs +1/−1
• src/Camfort/Analysis/Loops.hs +0/−97
• src/Camfort/Analysis/Simple.hs +35/−0
• src/Camfort/Analysis/Syntax.hs +63/−62
• src/Camfort/Functionality.hs +26/−31
• src/Camfort/Helpers.hs +6/−0
• src/Camfort/Input.hs +2/−2
• src/Camfort/Output.hs +79/−62
• src/Camfort/PrettyPrint.hs +2/−5
• src/Camfort/Reprint.hs +98/−44
• src/Camfort/Specification/Stencils.hs +0/−0
• src/Camfort/Specification/Stencils/Annotation.hs +0/−4
• src/Camfort/Specification/Stencils/CheckBackend.hs +0/−1
• src/Camfort/Specification/Stencils/CheckFrontend.hs +0/−1
• src/Camfort/Specification/Stencils/InferenceFrontend.hs +8/−21
• src/Camfort/Specification/Stencils/Synthesis.hs +2/−4
• src/Camfort/Specification/Units.hs +140/−196
• src/Camfort/Specification/Units/Debug.hs +0/−197
• src/Camfort/Specification/Units/Environment.hs +98/−245
• src/Camfort/Specification/Units/InferenceBackend.hs +242/−508
• src/Camfort/Specification/Units/InferenceFrontend.hs +639/−659
• src/Camfort/Specification/Units/Monad.hs +170/−0
• src/Camfort/Specification/Units/Parser.y +2/−2
• src/Camfort/Specification/Units/Solve.hs +0/−122
• src/Camfort/Specification/Units/SolveHMatrix.hs +0/−215
• src/Camfort/Specification/Units/Strip.hs +0/−50
• src/Camfort/Specification/Units/Synthesis.hs +59/−130
• src/Camfort/Transformation/CommonBlockElim.hs +41/−42
• src/Camfort/Transformation/DerivedTypeIntro.hs +0/−1
• src/Camfort/Traverse.hs +9/−0
• src/Main.hs +6/−7
• tests/Camfort/Analysis/CommentAnnotatorSpec.hs +122/−0
• tests/Camfort/Helpers/VecSpec.hs +21/−0
• tests/Camfort/Specification/Stencils/CheckSpec.hs +88/−0
• tests/Camfort/Specification/Stencils/GrammarSpec.hs +86/−0
• tests/Camfort/Specification/Stencils/ModelSpec.hs +135/−0
• tests/Camfort/Specification/StencilsSpec.hs +464/−0
• tests/Camfort/Specification/UnitsSpec.hs +127/−0
• tests/Camfort/Transformation/CommonSpec.hs +42/−0
• tests/Camfort/Transformation/EquivalenceElimSpec.hs +68/−0

@@ -1,5 +1,5 @@ name:                   camfort-version:                0.802+version:                0.804 synopsis:               CamFort - Cambridge Fortran infrastructure description:            CamFort is a tool for the analysis, transformation, verification of Fortran code. @@ -14,28 +14,12 @@ build-type:             Simple category:               Language, tools -cabal-version:          >= 1.8-tested-with:            GHC >= 7.10.1--test-suite spec-  type:                 exitcode-stdio-1.0-  main-is:              Spec.hs-  hs-source-dirs:       tests-  build-depends:        base < 5,-                        containers >= 0.5,-                        filepath >= 1.4,-                        directory >= 1.2,-                        hspec >= 2.2,-                        QuickCheck >= 2.8,-                        fortran-src >= 0.1,-                        uniplate >= 1.6.10,-                        mtl >= 2.1,-                        bytestring >= 0.10,			-                        camfort+cabal-version:          >= 1.18+tested-with:            GHC >= 7.8  source-repository head   type: git-  location: https://github.com/dorchard/camfort+  location: https://github.com/camfort/camfort  executable camfort   main-is: Main.hs@@ -44,11 +28,11 @@                         Camfort.Analysis.CallGraph                         Camfort.Analysis.CommentAnnotator                         Camfort.Analysis.IntermediateReps-                        Camfort.Analysis.Loops-                        Camfort.Analysis.LVA			+                        Camfort.Analysis.LVA+                        Camfort.Analysis.Simple                         Camfort.Analysis.Syntax                         Camfort.Analysis.Types-                        Camfort.Specification.Stencils.Annotation			+                        Camfort.Specification.Stencils.Annotation                         Camfort.Specification.Stencils.CheckBackend                         Camfort.Specification.Stencils.CheckFrontend                         Camfort.Specification.Stencils.InferenceBackend@@ -59,14 +43,11 @@                         Camfort.Specification.Stencils.Synthesis                         Camfort.Specification.Stencils                         Camfort.Specification.Units-                        Camfort.Specification.Units.Debug                         Camfort.Specification.Units.InferenceFrontend                         Camfort.Specification.Units.InferenceBackend                         Camfort.Specification.Units.Environment+                        Camfort.Specification.Units.Monad                         Camfort.Specification.Units.Parser-                        Camfort.Specification.Units.Solve-                        Camfort.Specification.Units.SolveHMatrix-                        Camfort.Specification.Units.Strip                         Camfort.Specification.Units.Synthesis                         Camfort.Transformation.CommonBlockElim                         Camfort.Transformation.CommonBlockElimToCalls@@ -84,8 +65,8 @@                         Camfort.Traverse                         Main -  build-depends:        base < 5,-                        ghc-prim >= 0.4.0.0,+  build-depends:        base >= 4.6 && < 5,+                        ghc-prim >= 0.3.1.0,                         containers >= 0.5.0.0,                         template-haskell >=2.4,                         generic-deriving >=1.5.5,@@ -96,7 +77,7 @@                         syz >= 0.2,                         syb >= 0.4,                         matrix >=0.2.2,-                        vector >= 0.1,			+                        vector >= 0.1,                         hmatrix >= 0.15,                         mtl >= 2.1,                         text >= 0.11.2.3,@@ -106,28 +87,24 @@                         transformers >= 0.4,                         GenericPretty >= 1.2,                         QuickCheck >= 2.8,-                        fortran-src >= 0.1,+                        fortran-src >= 0.1.0.2,                         filepath,                         fgl >= 5.5,                         bytestring >= 0.10+  default-language: Haskell2010  library   hs-source-dirs:       src-----  ghc-options:          -package mtl-2.1.3.1-   build-tools:          alex, happy-   exposed-modules:      Camfort.Analysis.Annotations                         Camfort.Analysis.CallGraph                         Camfort.Analysis.CommentAnnotator                         Camfort.Analysis.IntermediateReps-                        Camfort.Analysis.Loops                         Camfort.Analysis.LVA+                        Camfort.Analysis.Simple                         Camfort.Analysis.Syntax                         Camfort.Analysis.Types-                        Camfort.Specification.Stencils.Annotation			+                        Camfort.Specification.Stencils.Annotation                         Camfort.Specification.Stencils.CheckBackend                         Camfort.Specification.Stencils.CheckFrontend                         Camfort.Specification.Stencils.InferenceBackend@@ -138,14 +115,11 @@                         Camfort.Specification.Stencils.Synthesis                         Camfort.Specification.Stencils                         Camfort.Specification.Units-                        Camfort.Specification.Units.Debug                         Camfort.Specification.Units.InferenceFrontend                         Camfort.Specification.Units.InferenceBackend                         Camfort.Specification.Units.Environment+                        Camfort.Specification.Units.Monad                         Camfort.Specification.Units.Parser-                        Camfort.Specification.Units.Solve-                        Camfort.Specification.Units.SolveHMatrix-                        Camfort.Specification.Units.Strip                         Camfort.Specification.Units.Synthesis                         Camfort.Transformation.CommonBlockElim                         Camfort.Transformation.CommonBlockElimToCalls@@ -161,10 +135,9 @@                         Camfort.Reprint                         Camfort.PrettyPrint                         Camfort.Traverse-  other-modules: -  build-depends:        base < 5,-                        ghc-prim >= 0.4.0.0,+  build-depends:        base >= 4.6 && < 5,+                        ghc-prim >= 0.3.1.0,                         containers >= 0.5.0.0,                         template-haskell >=2.4,                         generic-deriving >=1.5.5,@@ -184,17 +157,36 @@                         transformers >= 0.4,                         vector >= 0.1,                         GenericPretty >= 1.2,-                        fortran-src >= 0.1,+                        fortran-src >= 0.1.0.2,                         filepath,                         bytestring >= 0.10,                         fgl >= 5.5+  default-language: Haskell2010 -executable analyse-  main-is: Analyse.hs-  hs-source-dirs:       eval-  build-depends: base < 5,-                 array >= 0.5.1,-                 bytestring >= 0.10,-                 containers >= 0.5.0.0,-                 regex-base >= 0.93.2,-                 regex-pcre >= 0.94.4+test-suite spec+  type:                 exitcode-stdio-1.0+  main-is:              Spec.hs+  hs-source-dirs:       tests+  other-modules:        Camfort.Analysis.CommentAnnotatorSpec+                        Camfort.Helpers.VecSpec+                        Camfort.Specification.Stencils.CheckSpec+                        Camfort.Specification.Stencils.GrammarSpec+                        Camfort.Specification.Stencils.ModelSpec+                        Camfort.Specification.StencilsSpec+                        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.2,+                        uniplate >= 1.6.10,+                        mtl >= 2.1,+                        bytestring >= 0.10,			+                        array >= 0.4,+                        hmatrix >= 0.15,+                        camfort+  default-language: Haskell2010

@@ -437,7 +437,7 @@ lexer' (x:xs)  | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId  | isNumber x = aux isNumber TNum- | otherwise = failWith $ "Not valid unit syntax at " ++ show (x:xs)+ | otherwise = Left NotAnnotation -- failWith $ "Not valid unit syntax at " ++ show (x:xs)  where    aux p cons =      let (target, rest) = span p xs@@ -449,7 +449,7 @@  parseUnit tokens  happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = failWith $ "Could not parse specification at: " ++ show t+happyError t = Left NotAnnotation -- failWith $ "Could not parse specification at: " ++ show t {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}

@@ -437,7 +437,7 @@ lexer' (x:xs)  | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId  | isNumber x = aux isNumber TNum- | otherwise = failWith $ "Not valid unit syntax at " ++ show (x:xs)+ | otherwise = Left NotAnnotation -- failWith $ "Not valid unit syntax at " ++ show (x:xs)  where    aux p cons =      let (target, rest) = span p xs@@ -449,7 +449,7 @@  parseUnit tokens  happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = failWith $ "Could not parse specification at: " ++ show t+happyError t = Left NotAnnotation -- failWith $ "Could not parse specification at: " ++ show t {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<built-in>" #-}

@@ -1,299 +0,0 @@-import Text.Printf (printf)-import Text.Regex.PCRE ((=~))-import Text.Regex.Base-import System.Environment-import qualified Data.ByteString.Char8 as S-import Data.Maybe-import Data.List (unfoldr, groupBy, foldl', nub)-import Data.Function (on)-import Data.Array-import qualified Data.Map as M-import Control.Monad--varKeywords = [ "readOnce", "reflexive", "irreflexive", "forward", "backward", "centered", "atLeast", "atMost" ]-spanKeywords = [ "tickAssign", "LHSnotHandled", "nonNeighbour", "emptySpec", "inconsistentIV", "relativized" ]--dimName :: Int -> String-dimName n = "dims"++show n-depthName :: Int -> String-depthName n = "depth"++show n-regionOpsName :: Int -> String-regionOpsName n = "regionOps"++ show n-plusOpsName :: Int -> String-plusOpsName n = "plusOps" ++ show n-mulOpsName :: Int -> String-mulOpsName n = "mulOps" ++ show n-dimDistName :: Int -> String-dimDistName n = "dimDist" ++ show n-dimTagName :: Int -> String-dimTagName n = "dimTag" ++ show n--type Analysis = M.Map String Int-type ModAnalysis = M.Map String Analysis---- Alongside countBySpan, also do some counts grouped by spans and variables.-countByVars :: Analysis -> S.ByteString -> Analysis-countByVars a l = M.unionsWith (+) $ [a, keysA] ++ map snd (filter fst counts)-  where-    counts  = [ ((get a "atLeast" > 0 && get keysA "atMost" > 0) ||-                (get keysA "atLeast" > 0 && get a "atMost" > 0),   {- ==> -} M.singleton "boundedBoth" n)-              , ( get keysA "reflexive" > 0 &&-                  M.size keysA == 1                            ,   {- ==> -} M.singleton "justReflexive" n )-              , ( ndims > 0                                    ,   {- ==> -} M.singleton (dimName ndims) n)-              , ( isJust mdep                                  ,   {- ==> -} M.singleton (depthName (fromJust mdep)) n)-              , ( regOps >= 0 && isSten                        ,   {- ==> -} M.singleton (regionOpsName regOps) n)-              , ( plusOps >= 0 && isSten                       ,   {- ==> -} M.singleton (plusOpsName plusOps) n)-              , ( mulOps >= 0 && isSten                        ,   {- ==> -} M.singleton (mulOpsName mulOps) n)-              , ( dimDist > 0 && isSten                        ,   {- ==> -} M.singleton (dimDistName dimDist) n)-              ]-    keysA   = M.fromList [ (k, n) | k <- varKeywords, l =~ re k  ] -- try each keyword-    re k    = "[^A-Za-z]" ++ k ++ "[^A-Za-z]" -- form a regular expression from a keyword-    get m k = 0 `fromMaybe` M.lookup k m -- convenience function-    n       = numVars l -- note that this will treat an EVALMODE line as having 1 variable-    ndims   = numDims l-    mdep    = depth l-    regOps  = countRegionOps l-    plusOps = countPlusOps l-    mulOps  = countMulOps l-    dimDist = countDimDist l-    isSten  = l =~ "\\)[[:space:]]*stencil "---- Count interesting stuff in a given line, and given the group's--- analysis to this point, grouped by span.-countBySpan :: Analysis -> S.ByteString -> Analysis-countBySpan a l = M.unionsWith (+) $ [a, keysA] ++ map snd (filter fst counts)-  where-    counts  = [ ( l =~ "stencil "                , {- ==> -} M.fromList [("numStencilLines", 1),-                                                                         ("numStencilSpecs", n)] )-              , ( get a "numStencilSpecs" > 0 &&-                  get keysA "tickAssign" > 0     , {- ==> -} M.singleton "tickAssignSuccess" 1 )-              , ( isJust mDimTag                 , {- ==> -} M.singleton (dimTagName (fromJust mDimTag)) n)-              ]-    keysA   = M.fromList [ (k, n) | k <- spanKeywords, l =~ re k  ] -- try each keyword-    re k    = "[^A-Za-z]" ++ k ++ "[^A-Za-z]" -- form a regular expression from a keyword-    get m k = 0 `fromMaybe` M.lookup k m -- convenience function-    n       = numVars l -- note that this will treat an EVALMODE line as having 1 variable-    mDimTag = countDimTag l---- Look at each group that shares a source span, then each group that shares a source span and vars.-eachGroup :: [S.ByteString] -> Analysis-eachGroup g = M.unionsWith (+) $ a':map (foldl' countByVars M.empty) gbv-  where-    a'  = foldl' countBySpan M.empty g-    gbv = groupBy ((==) `on` vars) (filter (not . S.null . vars) g)---- Group by source span and variable in order to group multiple lines--- that happen to pertain to the same expression (e.g. for boundedBoth).-analyseExec :: [S.ByteString] -> ModAnalysis-analyseExec [] = M.empty-analyseExec (e1:es)-  | any (=~ "Lexing failed") es = M.singleton modName . M.fromList $ [("lexFailed", 1), ("lexOrParseFailed", 1)] ++ linesTotal-  | any (=~ "Parsing failed") es = M.singleton modName . M.fromList $ [("parseFailed", 1), ("lexOrParseFailed", 1)] ++ linesTotal-  | otherwise = M.singleton modName . M.unionsWith (+) . (parseOk:) . map eachGroup $ gs-  where-    gs         = groupBy ((==) `on` srcSpan) . filter (=~ "\\)[[:space:]]*(stencil|EVALMODE)") $ es-    modName    = drop 4 . S.unpack . (=~ "MOD=([^ ]*)") $ e1-    lineCount  = msum (es >>= map (fmap fst . S.readInt) . mrSubList . (=~ "LineCount: ([0-9]*)"))-    linesTotal = case lineCount of Just n -> [("linesTotal", n)]; _ -> []-    parseOk    = M.fromList (("parseOk", 1):(case lineCount of Just n -> [("linesParsed", n)]; _ -> []) ++ linesTotal)---- helper functions-srcSpan :: S.ByteString -> S.ByteString-srcSpan = (=~ "^\\([^[:space:]]*\\)")-vars :: S.ByteString -> S.ByteString-vars = (=~ ":: .*$")-srcSpanAndVars l1 l2 = srcSpan l1 == srcSpan l2 && vars l1 == vars l2-numVars = (1 +) . S.length . S.filter (== ',') . vars-numDims :: S.ByteString -> Int-numDims s-  | S.null match = 0-  | otherwise  = (1 +) . S.length . S.filter (== ',') $ match-  where-    match = s =~ "\\(dims=[^\\)]*\\)"-depth :: S.ByteString -> Maybe Int-depth = fmap fst . S.readInt . S.concat . mrSubList . (=~ "depth=([0-9]*)")-countRegionOps :: S.ByteString -> Int-countRegionOps = S.length . S.filter (`elem` "+*")-countMulOps :: S.ByteString -> Int-countMulOps = S.length . S.filter (`elem` "*")-countPlusOps :: S.ByteString -> Int-countPlusOps = S.length . S.filter (`elem` "+")-countDimDist :: S.ByteString -> Int-countDimDist l = length . nub . filter (>0) $ (dimList ++ dimsList)-  where-    matchToInt = fromMaybe 0 . fmap fst . S.readInt-    -- search for "dim=n"-    dimList    = map (matchToInt . (! 1)) (getAllTextMatches (l =~ "dim=([0-9]*)" :: AllTextMatches [] (Array Int S.ByteString)))-    -- search for "(dims=n,n,...)"-    dimsList   = map matchToInt . concatMap (S.split ',') . mrSubList $ l =~ "\\(dims=([^\\)]*)\\)"-countDimTag :: S.ByteString -> Maybe Int-countDimTag = fmap fst . S.readInt . S.concat . mrSubList . (=~ "dimensionality=([0-9]*)")---- Extract one set of text that occurs between "%%% begin" and "%%% end",--- returning the remainder if present.-oneExec :: [S.ByteString] -> Maybe ([S.ByteString], [S.ByteString])-oneExec ls-  | null b    = Nothing-  | otherwise = Just (e, b)-  where-    a = dropWhile (not . (=~ "^%%% begin stencils-infer")) ls-    (e, b) = break (=~ "^%%% end stencils-infer") a--prettyOutput :: ModAnalysis -> String-prettyOutput = unlines . prettyOutput'-prettyOutput' :: ModAnalysis -> [String]-prettyOutput' ma = concat [ ("corpus module: " ++ m):map (replicate 4 ' ' ++) (prettyAnal a) | (m, a) <- M.toList ma ] ++-                          ( "overall":map (replicate 4 ' ' ++) (prettyAnal combined) ) ++-                          ( map (replicate 4 ' '++) [-                              printf "numStencilSpecs (%d) <= forward (%d) + backward (%d) + centered (%d) + reflexive (%d) = %d"-                                     numStencilSpecs forward backward centered reflexive numSpeced-                              ] )-  where-    combined = M.unionsWith (+) $ M.elems ma-    get = fromMaybe 0 . flip M.lookup combined-    numStencilSpecs = get "numStencilSpecs"-    forward = get "forward"-    backward = get "backward"-    centered = get "centered"-    reflexive = get "reflexive"-    numSpeced = forward + backward + centered + reflexive-prettyAnal a = [ k ++ ": " ++ show v | (k, v) <- M.toList a ]---main :: IO ()-main = do-  input <- S.getContents-  let ls = S.lines input-  let execs = unfoldr oneExec ls-  let ma = M.unionsWith (M.unionWith (+)) $ map analyseExec execs-  args <- getArgs-  case args of-    "-R":_ -> print ma-    _      -> putStrLn . prettyOutput $ ma-  return ()--runTest = M.unionsWith (M.unionWith (+)) . map analyseExec . unfoldr oneExec--test0 = map S.pack [-      "%%% begin stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f\""-    , "CamFort 0.775 - Cambridge Fortran Infrastructure."-    , "Inferring stencil specs for \"/home/mrd45/src/corpus/samples/weird/w1.f\""-    , ""-    , "Output of the analysis:"-    , "((38,9),(38,32))         stencil readOnce, reflexive(dims=1) :: real"-    , "((38,9),(38,32))         EVALMODE: Non-neighbour relative subscripts (tag: nonNeighbour)"-    , "((42,9),(42,32))         stencil readOnce, reflexive :: x"-    , "%%% end stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f\""-    ]--test1 = map S.pack [-      "%%% begin stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f\""-    , "CamFort 0.775 - Cambridge Fortran Infrastructure."-    , "Inferring stencil specs for \"/home/mrd45/src/corpus/samples/weird/w1.f\""-    , ""-    , "Output of the analysis:"-    , "((38,9),(38,32))         stencil readOnce, reflexive(dims=1) :: real"-    , "((38,9),(38,32))         EVALMODE: Non-neighbour relative subscripts (tag: nonNeighbour)"-    , "((44,11),(44,23))        stencil readOnce, reflexive(dims=1) :: u"-    , "((51,12),(51,54))        stencil readOnce, reflexive(dims=1) :: real, v"-    , "((51,12),(51,54))        EVALMODE: Non-neighbour relative subscripts (tag: nonNeighbour)"-    , "((56,12),(56,22))        stencil readOnce, reflexive(dims=1) :: v"-    , "((70,9),(70,34))         stencil readOnce, irreflexive(dims=1), (backward(depth=1, dim=1)) :: c"-    , "((70,9),(70,34))         stencil readOnce, reflexive(dims=1) :: d"-    , "((71,9),(71,34))         stencil readOnce, (backward(depth=1, dim=1)) :: b"-    , "((75,9),(75,40))         stencil readOnce, reflexive(dims=1) :: b, c, d, e"-    , "((75,9),(75,40))         stencil readOnce, irreflexive(dims=1), (forward(depth=1, dim=1)) :: x"-    , ""-    , "0.14user 0.00system 0:00.15elapsed 98%CPU (0avgtext+0avgdata 20616maxresident)k"-    , "0inputs+8outputs (0major+1395minor)pagefaults 0swaps"-    , "%%% end stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f\""-    , "%%% begin stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f90\""-    , "CamFort 0.775 - Cambridge Fortran Infrastructure."-    , "Inferring stencil specs for \"/home/mrd45/src/corpus/samples/weird/w1.f90\""-    , ""-    , "Output of the analysis:"-    , ""-    , "0.10user 0.00system 0:00.11elapsed 96%CPU (0avgtext+0avgdata 20908maxresident)k"-    , "0inputs+8outputs (0major+1510minor)pagefaults 0swaps"-    , "%%% end stencils-infer MOD=samples FILE=\"/home/mrd45/src/corpus/samples/weird/w1.f90\""-    , "%%% begin stencils-infer MOD=um FILE=\"/home/mrd45/um/trunk/src/io_services/server/stash/ios_server_coupler.F90\""-    , "LineCount: 155"-    , "StartTime: 2016-06-24 11:23:44+01:00"-    , "CamFort 0.775 - Cambridge Fortran Infrastructure."-    , "Inferring stencil specs for \"/home/mrd45/um/trunk/src/io_services/server/stash/ios_server_coupler.F90\""-    , ""-    , "Output of the analysis:"-    , ""-    , "/home/mrd45/um/trunk/src/io_services/server/stash/ios_server_coupler.F90"-    , "((108,3),(108,60))       stencil readOnce, reflexive(dims=2) :: offset_map"-    , "((108,3),(108,60))       EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((109,3),(110,37))       stencil readOnce, reflexive(dims=2) :: offset_map, size_map"-    , "((109,3),(110,37))       EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((111,3),(112,55))       stencil readOnce, reflexive(dims=1) :: grid_row_end, grid_row_start"-    , "((111,3),(112,55))       EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((130,3),(130,41))       stencil reflexive(dims=2) :: size_map"-    , "((130,3),(130,41))       EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((136,3),(136,37))       stencil reflexive(dims=2) :: size_map"-    , "((136,3),(136,37))       EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((137,3),(138,59))       stencil readOnce, reflexive(dims=1) :: grid_point_end, grid_point_start"-    , "((137,3),(138,59))       EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((139,24),(141,48))      stencil readOnce, irreflexive(dims=1,2,3), (reflexive(dim=1))*(centered(depth=1, dim=2)) + (reflexive(dim=2))*(centered(depth=1, dim=1)) :: p"-    , "((139,24),(141,48))      stencil readOnce, (reflexive(dim=1))*(reflexive(dim=2)) :: rhs"-    , "((147,7),(147,78))       EVALMODE: LHS is an array subscript we  can't handle (tag: LHSnotHandled)"-    , "((148,10),(148,68))      EVALMODE: dimensionality=1"-    , ""-    , "1.33user 0.04system 0:02.08elapsed 66%CPU (0avgtext+0avgdata 75672maxresident)k"-    , "0inputs+0outputs (0major+15984minor)pagefaults 0swaps"-    , "EndTime: 2016-06-24 11:23:46+01:00"-    , "%%% end stencils-infer MOD=um FILE=\"/home/mrd45/um/trunk/src/io_services/server/stash/ios_server_coupler.F90\""-  ]--test2 = map S.pack [-      "%%% begin stencils-infer MOD=um FILE=\"/home/mrd45/um/trunk/src/scm/initialise/initqlcf.F90\""-    , "LineCount: 210"-    , "StartTime: 2016-06-24 12:28:13+01:00"-    , "Progress: 46 / 2533"-    , "CamFort 0.775 - Cambridge Fortran Infrastructure."-    , "Inferring stencil specs for \"/home/mrd45/um/trunk/src/scm/initialise/initqlcf.F90\""-    , ""-    , "Output of the analysis:"-    , ""-    , "/home/mrd45/um/trunk/src/scm/initialise/initqlcf.F90"-    , "((126,5),(126,18))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((131,9),(131,66))      stencil readOnce, reflexive(dims=1,2) :: q, wqsat"-    , "((131,9),(131,66))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((132,9),(132,36))      stencil reflexive(dims=1,2) :: ocf"-    , "((132,9),(132,36))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((136,9),(136,42))      stencil readOnce, reflexive(dims=1,2) :: q, wqsat"-    , "((136,9),(136,42))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((137,9),(137,42))      stencil readOnce, reflexive(dims=1,2) :: ocf"-    , "((137,9),(137,42))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((146,9),(146,22))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((148,9),(148,22))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((195,5),(195,19))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((196,5),(196,19))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((199,7),(199,20))      stencil reflexive(dims=1,2) :: ocf"-    , "((199,7),(199,20))      stencil readOnce, reflexive(dims=1,2) :: q"-    , "((199,7),(199,20))      stencil reflexive(dims=1,2) :: t, wqsat"-    , "((199,7),(199,20))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((201,7),(201,20))      stencil reflexive(dims=1,2) :: ocf"-    , "((201,7),(201,20))      stencil readOnce, reflexive(dims=1,2) :: q"-    , "((201,7),(201,20))      stencil reflexive(dims=1,2) :: t, wqsat"-    , "((201,7),(201,20))      EVALMODE: assign to relative array subscript (tag: tickAssign)"-    , "((275,11),(275,54))     stencil atLeast, readOnce, reflexive(dims=1,2,3) :: p"-    , "((275,11),(275,54))     stencil atMost, readOnce, (forward(depth=2, dim=3)) :: p"-    , ""-    , "1.23user 0.03system 0:01.83elapsed 69%CPU (0avgtext+0avgdata 76092maxresident)k"-    , "0inputs+0outputs (0major+15975minor)pagefaults 0swaps"-    , "EndTime: 2016-06-24 12:28:15+01:00"-    , "%%% end stencils-infer MOD=um FILE=\"/home/mrd45/um/trunk/src/scm/initialise/initqlcf.F90\""-  ]--test2out = M.fromList [("um",M.fromList [("atLeast",1),("atMost",1),("boundedBoth",1),("depth2",1),("dims2",14),("dims3",1),("forward",1),("justReflexive",7),("numStencilLines",12),("numStencilSpecs",16),("parseOk",1),("readOnce",9),("reflexive",15),("tickAssign",11),("tickAssignSuccess",6)])]--runTests = do-  print $ runTest test2 == test2out---- Local variables:--- mode: haskell--- End:

@@ -33,6 +33,8 @@ import Camfort.Analysis.IntermediateReps  import Camfort.Specification.Units.Environment+import qualified Camfort.Specification.Units.Parser as P+import Camfort.Analysis.CommentAnnotator import qualified Camfort.Specification.Stencils.Syntax as StencilSpec import qualified Camfort.Specification.Stencils.Grammar as StencilComment @@ -56,10 +58,7 @@  type A = Annotation -data Annotation = A { indices        :: [Variable],-                      lives          :: ([Access],[Access]),-                      arrsRead       :: Map Variable [[Expr ()]],-                      arrsWrite      :: Map Variable [[Expr ()]],+data Annotation = A { lives          :: ([Access],[Access]),                       unitVar        :: Int,                       number         :: Int,                       refactored     :: Maybe SrcLoc,@@ -85,10 +84,7 @@ pRefactored = isJust . refactored  unitAnnotation = A-  { indices       = []-   , lives        = ([], [])-   , arrsRead     = empty-   , arrsWrite    = empty+  { lives        = ([], [])    , unitVar      = 0    , number       = 0    , refactored   = Nothing@@ -97,3 +93,26 @@    , stencilSpec  = Nothing    , stencilBlock = Nothing  }++--------------------------------------------------++-- Convenience name for a common annotation type.+type UA = FA.Analysis (UnitAnnotation A)++-- Instances for embedding parsed specifications into the AST+instance ASTEmbeddable UA P.UnitStatement where+  annotateWithAST ann ast =+    onPrev (\ ann -> ann { unitSpec = Just ast }) ann++-- Link annotation comments to declaration statements+instance Linkable UA where+  link ann (b@(F.BlStatement _ _ _ (F.StDeclaration {}))) =+      onPrev (\ ann -> ann { unitBlock = Just b }) ann+  link ann b = ann++-- Helpers for transforming the 'previous' annotation+onPrev :: (a -> a) -> FA.Analysis a -> FA.Analysis a+onPrev f ann = ann { FA.prevAnnotation = f (FA.prevAnnotation ann) }++modifyAnnotation :: F.Annotated f => (a -> a) -> f a -> f a+modifyAnnotation f x = F.setAnnotation (f (F.getAnnotation x)) x

@@ -53,7 +53,7 @@                                  -> Logger (ProgramFile a) annotateComments parse pf = do     pf' <- transformBiM (writeAST parse) pf-    return $ transformBi linkBlocks pf'+    return $ descendBi linkBlocks pf'   where     writeAST :: (Data a, ASTEmbeddable a ast)              => AnnotationParser ast -> Block a -> Logger (Block a)

@@ -1,97 +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 ImplicitParams #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Camfort.Analysis.Loops where--import Data.Data-import Data.List-import Data.Ord--import Language.Fortran-import Language.Fortran.Pretty---import Data.Generics.Uniplate.Operations-import Control.Monad.State.Lazy-import Debug.Trace--import Camfort.Analysis.LVA-import Camfort.Analysis.Annotations-import Camfort.Analysis.Syntax-import Camfort.Analysis.Types--import Camfort.Helpers-import Camfort.Traverse--import Camfort.Transformation.Syntax -- <- for doing reassociation--import qualified Data.Map.Lazy as Map hiding (map, (\\))----  when travesing whole program collect all declarations with bounds ---  collect all constants (#1) ---  identify all loop 'variables' (#2) ---   - identify all variables indexed by the loop variables---- loopBody :: Fortran t -> State (TypeEnvStack t) (Fortran ([String], [String], [String]))--- loopBody (For _ v@(VarName _ s) e1 e2 e3 body) = ---     let---         anno = (---     in For anno v e1 e2 e3 body------ newFrame gammas = []:gammas--- pushVar v t (g:gs) = ((v, t):g):gs--- popVar (((v,t):g):gs) = (g:gs)--- popFrame (g:gs) = (g, gs)---- ap (fmap ((,[""]),[""]))--loopAnalyse :: Program a -> Program Annotation-loopAnalyse p = map ((descendBi arrayIndices) . ix . lvaOnUnit . (transformBi reassociate) . (fmap (const unitAnnotation))) p--analyse' :: Program Annotation -> Program Annotation-analyse' p = map ((descendBi arrayIndices) . ix . lvaOnUnit . (transformBi reassociate))  p---- collect: from an association list to a map with list-based bins for matching keys-collect :: (Eq a, Ord k) => [(k, a)] -> Map.Map k [a]-collect = Map.fromListWith union . map (fmap (:[]))--arrayIndices :: Block Annotation -> Block Annotation-arrayIndices x = -    let tenv = typeEnv x-        -        arrIxsF :: Fortran Annotation -> Annotation-        arrIxsF y = let readIxs = [(v, mfmap (const ()) e) | -                                     (Var _ _ [(VarName _ v, e)]) <- rhsExpr y,-                                     length e > 0,-                                     isArrayType tenv v]--                        writeIxs = [(v, mfmap (const ()) e) |-                                     (Var _ _ [(VarName _ v, e)]) <- lhsExpr y,-                                     length e > 0,-                                     isArrayType tenv v]--                    in (tag y) { arrsRead = (collect readIxs), arrsWrite = (collect writeIxs) } -    in extendBi arrIxsF x               --ix :: ProgUnit Annotation -> ProgUnit Annotation-ix = let ixF :: Fortran Annotation -> Annotation-         ixF f = (tag f) { indices = (nub [v | (For _ _ (VarName _ v) _ _ _ _) <- ((universeBi f)::[Fortran Annotation])])}-     in extendBi ixF--loopVariables :: ProgUnit Annotation -> [String]-loopVariables f = (nub [v | (For _ _ (VarName _ v) _ _ _ _) <- ((universeBi f)::[Fortran Annotation])])

@@ -0,0 +1,35 @@+{-+   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 ScopedTypeVariables #-}++{- Simple syntactic analysis on Fortran programs -}++module Camfort.Analysis.Simple+ (countVariableDeclarations) where++import Data.Data+import Data.Generics.Uniplate.Operations+import Camfort.Helpers++import qualified Language.Fortran.AST as F++{-| 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)

@@ -24,7 +24,7 @@ -} module Camfort.Analysis.Syntax where --- Standard imports +-- Standard imports import Data.Char import Data.List import Data.Monoid@@ -46,8 +46,9 @@  -- * Comparison and ordering -{-|  'AnnotationFree' is a data type that wraps other types and denotes terms which should -     be compared for equality modulo their annotations and source location information -}+{-|  'AnnotationFree' is a data type that wraps other types and denotes terms+     which should  be compared for equality modulo their annotations and source+     location information -} data AnnotationFree t = AnnotationFree { annotationBound :: t } deriving Show  {-| short-hand constructor for 'AnnotationFree' -}@@ -55,19 +56,23 @@ {-| short-hand deconstructor for 'AnnotationFree' -} unaf = annotationBound -{-| A helpful function, used by the 'Eq AnnotationFree' instance that resets and source -    location information -}+{-| A helpful function, used by the 'Eq AnnotationFree' instance that+     resets and source  location information -} eraseSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a-eraseSrcLocs = transformBi erase' -                    where erase' :: SrcLoc -> SrcLoc-                          erase' _ = SrcLoc { srcFilename = "", srcLine = 0, srcColumn = 0 }+eraseSrcLocs =+    transformBi erase'+  where+    erase' :: SrcLoc -> SrcLoc+    erase' _ = SrcLoc { srcFilename = "", srcLine = 0, srcColumn = 0 } -{-| Sets the @SrcLoc@ information to have the filename "compact" which triggers a special +{-| Sets the @SrcLoc@ information to have the filename "compact" which triggers a special   compact form of pretty printing in the @Show SrcLoc@ instances -} setCompactSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a-setCompactSrcLocs = transformBi cmpact' -                    where cmpact' :: SrcLoc -> SrcLoc-                          cmpact' (SrcLoc _ l c) = SrcLoc { srcFilename = "compact", srcLine = l, srcColumn = c }+setCompactSrcLocs =+    transformBi cmpact'+  where+    cmpact' :: SrcLoc -> SrcLoc+    cmpact' (SrcLoc _ l c) = SrcLoc { srcFilename = "compact", srcLine = l, srcColumn = c }  lower = map toLower @@ -77,7 +82,7 @@     (AnnotationFree xs) == (AnnotationFree xs') =                if (length xs == length xs')                then foldl (\b -> \(x, x') -> ((af x) == (af x')) && b) True (zip xs xs')-               else False +               else False  instance Eq (AnnotationFree Int) where     x == y = (unaf x) == (unaf y)@@ -94,27 +99,29 @@ instance Eq (AnnotationFree (Expr a)) where     -- Compute variable equality modulo annotations and spans     (AnnotationFree (Var _ _ vs)) == (AnnotationFree (Var _ _ vs'))-          = cmp vs vs' where cmp [] [] = True-                             cmp ((VarName _ v,es):vs) ((VarName _ v',es'):vs') =--                                  -- Since whether variable names are upper or lower case is irrelevant-                                  -- in Fortran, we must compare variables for equality by normalising first-                                  -- (here to lower case)+          = cmp vs vs'+          where+           cmp [] [] = True+           cmp ((VarName _ v,es):vs) ((VarName _ v',es'):vs') = -                                  if (lower v) == (lower v') then -                                         (and (map (\(e, e') -> (af e) == (af e'))-                                                 (zip es es'))) && (cmp vs vs')-                                  else False+           -- Since whether variable names are upper or lower case is irrelevant+           -- in Fortran, we must compare variables for equality by normalising+           -- first (here to lower case) -                             cmp _ _ = False+               if (lower v) == (lower v') then+                   (and (map (\(e, e') -> (af e) == (af e'))+                        (zip es es'))) && (cmp vs vs')+               else False+           cmp _ _ = False -    -- For other expressions we can get away with reseting their annotations are erasing their source locs-    (AnnotationFree e1) == (AnnotationFree e2) = (eraseSrcLocs $ fmap (const ()) e1) == -                                                 (eraseSrcLocs $ fmap (const ()) e2)+    -- For other expressions we can get away with reseting their+    -- annotations are erasing their source locs+    (AnnotationFree e1) == (AnnotationFree e2) =+      (eraseSrcLocs $ fmap (const ()) e1) == (eraseSrcLocs $ fmap (const ()) e2)   instance Eq (AnnotationFree (Type a)) where-    (AnnotationFree (BaseType _ b attrs e1 e2)) == (AnnotationFree (BaseType _ b' attrs' e1' e2')) = +    (AnnotationFree (BaseType _ b attrs e1 e2)) == (AnnotationFree (BaseType _ b' attrs' e1' e2')) =        (af b == af b') && (af attrs == af attrs') && (af e1 == af e1') && (af e2 == af e2')      (AnnotationFree (ArrayT _ eps b attrs e1 e2)) == (AnnotationFree (ArrayT _ eps' b' attrs' e1' e2')) =@@ -127,8 +134,8 @@ instance Eq (AnnotationFree (BaseType p)) where     (AnnotationFree (DerivedType _ s)) == (AnnotationFree (DerivedType _ s')) = (af s) == (af s')     (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y)-     + instance Eq (AnnotationFree (SubName p)) where     (AnnotationFree (SubName _ s)) == (AnnotationFree (SubName _ s')) = (lower s) == (lower s')     (AnnotationFree (NullSubName _)) == (AnnotationFree (NullSubName _)) = True@@ -156,7 +163,7 @@ {-| Ordering on accessor syntax -} instance Ord (AccessP ()) where     (VarA s1) <= (VarA s2)           = s1 <= s2-    (ArrayA s1 e1) <= (ArrayA s2 e2) = if (s1 == s2) then e1 <= e2 else s1 <= s2 +    (ArrayA s1 e1) <= (ArrayA s2 e2) = if (s1 == s2) then e1 <= e2 else s1 <= s2     (VarA s1) <= (ArrayA s2 e1)      = True     _ <= _                           = False @@ -179,8 +186,8 @@ {-| Extracts all accessors (variables and array indexing) from a piece of syntax -} accesses f = nub $  [VarA (lower v) | (AssgExpr _ _ v _) <- (universeBi f)::[Expr Annotation]]                      ++ concat [varExprToAccesses ve | ve@(Var _ _ _) <- (universeBi f)::[Expr Annotation]]-                + {-| Extracts a string of the (root) variable name from a variable expression (if it is indeed a variable     expression -} varExprToVariable :: Expr a -> Maybe Variable@@ -194,17 +201,17 @@ {-| Extracts all 'accessors' from a variable expression e.g.,      @varExprToAccess@ on the syntax tree coming from @a(i, j)@ returns a list of @[VarA "a", VarA "i", VarA "j"]@ -} varExprToAccesses :: Expr a -> [Access]-varExprToAccesses (Var _ _ ves) = [mkAccess v es | (VarName _ v, es) <- ves, all isConstant es] +varExprToAccesses (Var _ _ ves) = [mkAccess v es | (VarName _ v, es) <- ves, all isConstant es]                                      where mkAccess v [] = VarA v                                            mkAccess v es = ArrayA v (map (fmap (const ())) es)-varExprToAccesses _             = [] +varExprToAccesses _             = []   class Successors t where     {-| Computes the 'root' successor from the current -}     successorsRoot :: t a -> [t a]     {-| Computes the successors nodes of a CFG (described by a zipper) for certain node types -}-    successors :: (Eq a, Typeable a) => Zipper (ProgUnit a) -> [t a]  +    successors :: (Eq a, Typeable a) => Zipper (ProgUnit a) -> [t a]  instance Successors Fortran where     successorsRoot (FSeq _ _ f1 f2)          = [f1]@@ -216,32 +223,32 @@     successorsRoot (Label _ _ _ f)           = [f]     successorsRoot _                         = [] -    successors = +    successors =         successorsF          where           successorsF :: forall a . (Eq a, Typeable a) => Zipper (ProgUnit a) -> [Fortran a]-          successorsF z = maybe [] id +          successorsF z = maybe [] id                            (do f <- (getHole z)::(Maybe (Fortran a))                                ss <- return $ successorsRoot f                                return $ ss ++ seekUp f (Just z))            seekUp :: forall a . (Eq a, Typeable a) => Fortran a -> Maybe (Zipper (ProgUnit a)) -> [Fortran a]           seekUp f z = case (z >>= up >>= getHole)::(Maybe (Fortran a)) of-                         Just uf -> +                         Just uf ->                              case uf of                                (FSeq _ _ f1 f2)     -> if (f == f1) then [f2]                                                        else seekUp uf (z >>= up)                                (For _ _ _ _ _ _ f') -> seekUp uf (z >>= up)-                               (If _ _ _ gf efs f') -> if (f == gf) then (maybe [] (:[]) f') ++ (map snd efs) -                                                       else seekUp uf (z >>= up) +                               (If _ _ _ gf efs f') -> if (f == gf) then (maybe [] (:[]) f') ++ (map snd efs)+                                                       else seekUp uf (z >>= up)                                (Forall _ _ _ f')    -> seekUp uf (z >>= up)                                (Where _ _ _ f' _)   -> seekUp uf (z >>= up)                                (Label _ _ _ f')     -> seekUp uf (z >>= up)                                _                    -> []-                         Nothing -> [] - +                         Nothing -> [] -{-| extract all 'right-hand side' expressions e.g. ++{-| extract all 'right-hand side' expressions e.g.       @rhsExpr (parse "x = e") = parse "e"@ -} rhsExpr :: Fortran Annotation -> [Expr Annotation] rhsExpr (Assg _ _ _ e2)        = (universeBi e2)::[Expr Annotation]@@ -251,11 +258,11 @@                                   ((universeBi e3)::[Expr Annotation])  rhsExpr (If _ _ e f1 fes f3)    = ((universeBi e)::[Expr Annotation])-                            + rhsExpr (Allocate x sp e1 e2)   = ((universeBi e1)::[Expr Annotation]) ++                                    ((universeBi e2)::[Expr Annotation]) -rhsExpr (Call _ _ e as)         = ((universeBi e)::[Expr Annotation]) ++ +rhsExpr (Call _ _ e as)         = ((universeBi e)::[Expr Annotation]) ++                                    ((universeBi as)::[Expr Annotation])  rhsExpr (Deallocate _ _ es e)   = (concatMap (\e -> (universeBi e)::[Expr Annotation]) es) ++@@ -278,13 +285,13 @@ rhsExpr (PointerAssg _ _ _ e2)  = (universeBi e2)::[Expr Annotation]  rhsExpr (Return _ _ e)          = (universeBi e)::[Expr Annotation]-rhsExpr (Print _ _ e es)        = ((universeBi e)::[Expr Annotation]) ++ +rhsExpr (Print _ _ e es)        = ((universeBi e)::[Expr Annotation]) ++                                    (concatMap (\e -> (universeBi e)::[Expr Annotation]) es) rhsExpr (ReadS _ _ s es)        = concatMap (\e -> (universeBi e)::[Expr Annotation]) es -- rhsExpr (Label x sp s f)        = rhsExpr f rhsExpr _                     = [] -{-| extract all 'left-hand side' expressions e.g. +{-| extract all 'left-hand side' expressions e.g.       @rhsExpr (parse "x = e") = parse "x"@ -} lhsExpr :: Fortran Annotation -> [Expr Annotation] lhsExpr (Assg _ _ e1 e2)        = ((universeBi e1)::[Expr Annotation])@@ -300,14 +307,10 @@     mempty = 0     mappend = (+) -{-| Counts the number of declarations (of variables) in a whole program -}-countVariableDeclarations :: Program Annotation -> Int-countVariableDeclarations x = sum [length xs | (Decl _ _ xs _) <- (universeBi x)::[Decl Annotation]]-                                 {-| Numbers all the statements in a program unit (successively) which is useful for analysis output -} numberStmts :: ProgUnit Annotation -> ProgUnit Annotation-numberStmts x = let +numberStmts x = let                   numberF :: Fortran Annotation -> State Int (Fortran Annotation)                   numberF = descendBiM number' @@ -315,8 +318,8 @@                   numberD = descendBiM number'                    number' :: Annotation -> State Int Annotation-                  -- actually numbers more than just statements, but this doesn't matter -                  number' x = do n <- get +                  -- actually numbers more than just statements, but this doesn't matter+                  number' x = do n <- get                                  put (n + 1)                                  return $ x { number = n } @@ -327,7 +330,7 @@  {-| All variables from a Fortran syntax tree -} variables f = nub $ map (map toLower) $ [v | (AssgExpr _ _ v _) <- (universeBi f)::[Expr Annotation]]-                 ++ [v | (VarName _ v) <- (universeBi f)::[VarName Annotation]] +                 ++ [v | (VarName _ v) <- (universeBi f)::[VarName Annotation]]  {-| A predicate on whether an expression is actually a constant constructor -} isConstant :: Expr p -> Bool@@ -335,7 +338,7 @@ isConstant (ConL _ _ _ _) = True isConstant (ConS _ _ _) = True isConstant _            = False-               + {-| Free-variables in a piece of Fortran syntax -} freeVariables :: (Data (t a), Data a) => t a -> [String] freeVariables f = (variables f) \\ (binders f)@@ -343,12 +346,12 @@ {-| All variables from binders -} binders :: forall a t . (Data (t a), Typeable (t a), Data a, Typeable a) => t a -> [String] binders f = nub $-               [v | (ArgName _ v) <- (universeBi f)::[ArgName a]] +               [v | (ArgName _ v) <- (universeBi f)::[ArgName a]]             ++ [v | (VarName _ v) <- (universeBi ((universeBi f)::[Decl a]))::[VarName a]]             ++ [v | (For _ _ (VarName _ v) _ _ _ _) <- (universeBi f)::[Fortran a]]  -{-| Tests whether an expression is an affine transformation (without scaling) +{-| Tests whether an expression is an affine transformation (without scaling)   on some variable, if so returns the variable and the translation factor -} affineMatch (Bin _ _ (Plus _) (Var _ _ [(VarName _ v, _)]) (Con _ _ n)) = Just (v, read n) affineMatch (Bin _ _ (Plus _) (Con _ _ n) (Var _ _ [(VarName _ v, _)]))   = Just (v, read n)@@ -358,7 +361,7 @@ affineMatch _                                                           = Nothing  --- * An embedded domain-specific language for describing syntax tree queries +-- * An embedded domain-specific language for describing syntax tree queries  {-| 'QueryCmd' provides 'commands' of which pieces of syntax to find -} @@ -371,8 +374,8 @@  {-| 'from' takes a command as its first parameter, a piece of syntax as its second, and      returns all pieces of syntax matching the query request.-     -     For example: @from Decls x@ returns a list of all declarations in @x@, of type @[Decl Annotation]@ ++     For example: @from Decls x@ returns a list of all declarations in @x@, of type @[Decl Annotation]@      If @x@ is itself a declaration then this is returned as well (so be careful with recursive functions      over things defined in turns of 'from'. See 'topFrom' for a solution to this. -}@@ -388,5 +391,3 @@ topFrom :: forall t synTyp . (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp] topFrom Locs x = accesses x topFrom _ x = (childrenBi x)::[synTyp]--

@@ -17,7 +17,6 @@ {- This module collects together stubs that connect analysis/transformations    with the input -> output procedures -} -{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -35,8 +34,8 @@  import Camfort.Analysis.Annotations import Camfort.Analysis.Types-import Camfort.Analysis.Loops import Camfort.Analysis.LVA+import Camfort.Analysis.Simple import Camfort.Analysis.Syntax  import Camfort.Transformation.DeadCode@@ -47,7 +46,7 @@  import qualified Camfort.Specification.Units as LU import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.Solve+import Camfort.Specification.Units.Monad  import Camfort.Helpers import Camfort.Output@@ -68,13 +67,14 @@ import Language.Fortran.Analysis(initAnalysis) import qualified Camfort.Specification.Stencils as Stencils +import qualified Debug.Trace as D+ -- CamFort optional flags data Flag = Version          | Input String          | Output String-         | Solver Solver          | Excludes String-         | Literals AssumeLiterals+         | Literals LiteralsOpt          | StencilInferMode Stencils.InferMode          | Debug deriving (Data, Show) @@ -89,11 +89,12 @@ -- * Wrappers on all of the features typeStructuring inSrc excludes outSrc _ = do     putStrLn $ "Introducing derived data types in " ++ show inSrc ++ "\n"-    doRefactor typeStruct inSrc excludes outSrc+    report <- doRefactor typeStruct inSrc excludes outSrc+    putStrLn report -ast d _ f _ = do-    (_, _, p) <- readParseSrcFile (d ++ "/" ++ f)-    putStrLn $ show p+ast d excludes f _ = do+    xs <- readForparseSrcDir (d ++ "/" ++ f) excludes+    putStrLn $ show (map (\(_, _, p) -> p) xs)  asts inSrc excludes _ _ = do     putStrLn $ "Do a basic analysis and output the HTML files "@@ -103,11 +104,7 @@  countVarDecls inSrc excludes _ _ = do     putStrLn $ "Counting variable declarations in " ++ show inSrc ++ "\n"-    doAnalysisSummary countVariableDeclarations inSrc excludes--loops inSrc excludes _ _ = do-    putStrLn $ "Analysing loops for " ++ show inSrc ++ "\n"-    doAnalysis loopAnalyse inSrc excludes+    doAnalysisSummaryForpar countVariableDeclarations inSrc excludes Nothing  lvaA inSrc excludes _ _ = do     putStrLn $ "Analysing loops for " ++ show inSrc ++ "\n"@@ -115,46 +112,44 @@  dead inSrc excludes outSrc _ = do     putStrLn $ "Eliminating dead code in " ++ show inSrc ++ "\n"-    doRefactor ((mapM (deadCode False))) inSrc excludes outSrc+    report <- doRefactor ((mapM (deadCode False))) inSrc excludes outSrc+    putStrLn report  commonToArgs inSrc excludes outSrc _ = do     putStrLn $ "Refactoring common blocks in " ++ show inSrc ++ "\n"-    doRefactor (commonElimToCalls inSrc) inSrc excludes outSrc+    report <- doRefactor (commonElimToCalls inSrc) inSrc excludes outSrc+    putStrLn report  common inSrc excludes outSrc _ = do     putStrLn $ "Refactoring common blocks in " ++ show inSrc ++ "\n"-    doRefactor (commonElimToModules inSrc) inSrc excludes outSrc+    report <- doRefactor (commonElimToModules inSrc) inSrc excludes outSrc+    putStrLn report  equivalences inSrc excludes outSrc _ = do     putStrLn $ "Refactoring equivalences blocks in " ++ show inSrc ++ "\n"-    doRefactor (mapM refactorEquivalences) inSrc excludes outSrc+    report <- doRefactor (mapM refactorEquivalences) inSrc excludes outSrc+    putStrLn report  {- Units feature -}+optsToUnitOpts :: [Flag] -> UnitOpts+optsToUnitOpts = foldl' (\ o f -> case f of Literals m -> o { uoLiterals = m }; Debug -> o { uoDebug = True }) unitOpts0+ unitsCheck inSrc excludes outSrc opt = do     putStrLn $ "Checking units for " ++ show inSrc ++ "\n"-    let ?solver = getOption opt :: Solver-     in let ?assumeLiterals = getOption opt :: AssumeLiterals-        in doAnalysisReportForpar (mapM LU.checkUnits) inSrc excludes outSrc+    doAnalysisReportForpar (mapM (LU.checkUnits (optsToUnitOpts opt))) inSrc excludes outSrc  unitsInfer inSrc excludes outSrc opt = do     putStrLn $ "Inferring units for " ++ show inSrc ++ "\n"-    let ?solver = getOption opt :: Solver-     in let ?assumeLiterals = getOption opt :: AssumeLiterals-        in doAnalysisReportForpar (mapM LU.inferUnits) inSrc excludes outSrc+    doAnalysisReportForpar (mapM (LU.inferUnits (optsToUnitOpts opt))) inSrc excludes outSrc  unitsSynth inSrc excludes outSrc opt = do     putStrLn $ "Synthesising units for " ++ show inSrc ++ "\n"-    let ?solver = getOption opt :: Solver-     in let ?assumeLiterals = getOption opt :: AssumeLiterals-        in doRefactorForpar (mapM LU.synthesiseUnits) inSrc excludes outSrc+    doRefactorForpar (mapM (LU.synthesiseUnits (optsToUnitOpts opt))) inSrc excludes outSrc  unitsCriticals inSrc excludes outSrc opt = do     putStrLn $ "Infering critical variables for units inference in directory "              ++ show inSrc ++ "\n"-    let ?solver = getOption opt :: Solver-     in let ?assumeLiterals = getOption opt :: AssumeLiterals-        in doAnalysisReportForpar (mapM LU.inferCriticalVariables)-              inSrc excludes outSrc+    doAnalysisReportForpar (mapM (LU.inferCriticalVariables (optsToUnitOpts opt))) inSrc excludes outSrc  {- Stencils feature -} stencilsCheck inSrc excludes _ _ = do

@@ -21,6 +21,12 @@ import qualified Data.ByteString.Char8 as B import System.Directory import Language.Fortran+import Data.List (union)+import qualified Data.Map.Lazy as Map hiding (map, (\\))++-- collect: from an association list to a map with list-based bins for matching keys+collect :: (Eq a, Ord k) => [(k, a)] -> Map.Map k [a]+collect = Map.fromListWith union . map (fmap (:[]))  lineCol :: SrcLoc -> (Int, Int) lineCol s = (srcLine s, srcColumn s)

@@ -129,7 +129,7 @@     output to the directory specified by the fourth parameter -} doRefactor :: ([(Filename, Program A)]            -> (String, [(Filename, Program Annotation)]))-           -> FileOrDir -> [Filename] -> FileOrDir -> IO ()+           -> FileOrDir -> [Filename] -> FileOrDir -> IO String doRefactor rFun inSrc excludes outSrc = do   if excludes /= [] && excludes /= [""]   then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes)@@ -139,10 +139,10 @@   ps <- readParseSrcDir inSrc excludes   let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)   --let outFiles = filter (\f -not ((take (length $ d ++ "out") f) == (d ++ "out"))) (map fst ps')-  putStrLn report   let outFiles = map fst ps'   let outData = zip3 outFiles (map (B.pack . Fortran.snd3) ps) (map snd ps')   outputFiles inSrc outSrc outData+  return report  -- * Source directory and file handling 

@@ -62,10 +62,12 @@ import Data.Generics.Zipper import Data.Maybe import Debug.Trace-import Control.Monad.Trans.State.Lazy import Text.Printf +import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Lazy + -- Custom 'Show' which on strings is the identity class Show' s where       show' :: s -> String@@ -126,13 +128,13 @@  -- When there is a file to be reprinted (for refactoring) instance OutputFiles (Filename, SourceText, Program Annotation) where-  mkOutputText f' (f, input, ast') = B.pack $ reprint refactoringLF input f' (PR ast')+  mkOutputText f' (f, input, ast') = evalState (reprint refactoringLF (PR ast') input) 0     where   outputFile (f, _, _) = f  -- When there is a file to be reprinted (for refactoring) instance OutputFiles (Filename, SourceText, F.ProgramFile Annotation) where-  mkOutputText f' (f, input, ast') = B.pack $ reprint refactoringForPar input f' ast'+  mkOutputText f' (f, input, ast') = runIdentity $ reprint refactoringForPar ast' input   outputFile (f, _, _) = f  srcSpanToSrcLocs :: FU.SrcSpan -> (SrcLoc, SrcLoc)@@ -144,23 +146,24 @@  instance (PrettyPrint (F.ProgramFile Annotation)) where    -- STUB-   prettyPrint _ = ""+   prettyPrint _ = B.empty -refactoringForPar :: (Typeable a) => [String] -> SrcLoc -> a -> State Int (String, SrcLoc, Bool)-refactoringForPar inp cursor =-    (\_ -> return ("", cursor, False)) `extQ` (outputComments inp cursor)+refactoringForPar :: (Typeable a) =>  a -> SourceText -> StateT SrcLoc Identity (SourceText, Bool)+refactoringForPar z inp =+    ((\_ -> return (B.empty, False)) `extQ` (flip outputComments inp)) $ z   where-    outputComments :: [String] -> SrcLoc -> F.Block Annotation -> State Int (String, SrcLoc, Bool)-    outputComments inp cursor e@(F.BlComment ann span comment) = return $+    outputComments :: F.Block Annotation -> SourceText -> StateT SrcLoc Identity (SourceText, Bool)+    outputComments e@(F.BlComment ann span comment) inp = do+       cursor <- get        if (pRefactored ann)          then    let (lb, ub) = srcSpanToSrcLocs span                      lb'      = leftOne lb                      (p0, _)  = takeBounds (cursor, lb') inp-                     nl       = if comment == [] then "" else "\n"-                 in (p0 ++ comment ++ nl, ub, True)-         else ("", cursor, False)+                     nl       = if 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 (SrcLoc f l c) = SrcLoc f (l-1) (c-1)-    outputComments _ _ _ = return ("", cursor, False)+    outputComments _ _ = return (B.empty, False)   {-| changeDir is used to change the directory of a filename string.@@ -186,89 +189,103 @@   (uses generic query extension - remember extQ is non-symmetric) -} -refactoringLF :: (Typeable a, Monad m) => [String] -> SrcLoc -> a -> StateT Int m (String, SrcLoc, Bool)-refactoringLF inp cursor = ((((\_ -> return ("", cursor, False))-                              `extQ` (refactorUses inp cursor))-                                 `extQ` (refactorDecl inp cursor))-                                    `extQ` (refactorArgName inp cursor))-                                       `extQ` (refactorFortran inp cursor)+refactoringLF :: (Typeable a) =>  a -> SourceText -> StateT SrcLoc (State Int) (SourceText, Bool)+refactoringLF = flip $ \inp -> ((((\_ -> return (B.empty, False))+                              `extQ` (refactorUses inp))+                                 `extQ` (refactorDecl inp))+                                    `extQ` (refactorArgName inp))+                                       `extQ` (refactorFortran inp)  -refactorFortran :: Monad m => [String] -> SrcLoc -> Fortran Annotation -> StateT Int m (String, SrcLoc, Bool)-refactorFortran inp cursor e =  return $-       if (pRefactored $ tag e) then+refactorFortran :: Monad m => SourceText -> Fortran Annotation -> StateT SrcLoc m (SourceText, Bool)+refactorFortran inp e = do+    cursor <- get+    if (pRefactored $ tag e) then           let (lb, ub) = srcSpan e               (p0, _) = takeBounds (cursor, lb) inp-              outE = pprint e-              lnl = case e of (NullStmt _ _) -> (if ((p0 /= []) && (Prelude.last p0 /= '\n')) then "\n" else "")-                              _              -> ""-              lnl2 = if ((p0 /= []) && (Prelude.last p0 /= '\n')) then "\n" else ""-              textOut = if p0 == "\n" then outE else (p0 ++ lnl2 ++ outE ++ lnl)-          in (textOut, ub, True)-       else ("", cursor, False)+              outE = B.pack $ pprint e+              lnl = case e of (NullStmt _ _) -> (if ((p0 /= B.empty) && (B.last p0 /= '\n')) then B.pack "\n" else B.empty)+                              _              -> B.empty+              lnl2 = if ((p0 /= B.empty) && (B.last p0 /= '\n')) then B.pack "\n" else B.empty+              textOut = if p0 == (B.pack "\n") then outE else B.concat [p0, lnl2, outE, lnl]+          in put ub >> return (textOut, True)+    else return (B.empty, False)  -refactorDecl :: Monad m => [String] -> SrcLoc -> Decl Annotation -> StateT Int m (String, SrcLoc, Bool)-refactorDecl inp cursor d =+refactorDecl :: SourceText -> Decl Annotation -> StateT SrcLoc (State Int) (SourceText, Bool)+refactorDecl inp d = do+    cursor <- get     if (pRefactored $ tag d) then        let (lb, ub) = srcSpan d            (p0, _) = takeBounds (cursor, lb) inp-           textOut = p0 ++ (pprint d)+           textOut = p0 `B.append` (B.pack $ pprint d)        in do textOut' <- -- The following compensates new lines with removed lines                          case d of                            (NullDecl _ _) ->-                              do added <- get+                              do added <- lift get                                  let diff = linesCovered ub lb                                  -- remove empty newlines here if extra lines have been added                                  let (text, removed) = if added <= diff                                                          then removeNewLines textOut added                                                          else removeNewLines textOut diff-                                 put (added - removed)+                                 lift $ put (added - removed)                                  return text                            otherwise -> return textOut-             return (textOut', ub, True)-    else return ("", cursor, False)+             put ub+             return (textOut', True)+    else return (B.empty, False) -refactorArgName :: Monad m => [String] -> SrcLoc -> ArgName Annotation -> m (String, SrcLoc, Bool)-refactorArgName inp cursor a = return $-        case (refactored $ tag a) of-            Just lb -> let (p0, _) = takeBounds (cursor, lb) inp-                       in (p0 ++ pprint a, lb, True)-            Nothing -> ("", cursor, False)+refactorArgName :: Monad m => SourceText -> ArgName Annotation -> StateT SrcLoc m (SourceText, Bool)+refactorArgName inp a = do+    cursor <- get+    case (refactored $ tag a) of+        Just lb -> do+            let (p0, _) = takeBounds (cursor, lb) inp+            put lb+            return (p0 `B.append` (B.pack $ pprint a), True)+        Nothing -> return (B.empty, False) -refactorUses :: Monad m => [String] -> SrcLoc -> Uses Annotation -> StateT Int m (String, SrcLoc, Bool)-refactorUses inp cursor u =+refactorUses :: SourceText -> Uses Annotation -> StateT SrcLoc (State Int) (SourceText, Bool)+refactorUses inp u = do+    cursor <- get     let ?variant = HTMLPP in         case (refactored $ tag u) of            Just lb -> let (p0, _) = takeBounds (cursor, lb) inp-                          syntax  = printSlave u-                       in do added <- get-                             if (newNode $ tag u) then put (added + (countLines syntax))+                          syntax  = B.pack $ printSlave u+                       in do added <- lift get+                             if (newNode $ tag u) then lift $ put (added + (countLines syntax))                                                   else return ()-                             return (p0 ++ syntax, toCol0 lb, True)-           Nothing -> return ("", cursor, False)+                             put $ toCol0 lb+                             return (p0 `B.append` syntax, True)+           Nothing -> return (B.empty, False) -countLines []        = 0-countLines ('\n':xs) = 1 + countLines xs-countLines (x:xs)    = countLines xs+countLines xs =+  case B.uncons xs of+    Nothing -> 0+    Just ('\n', xs) -> 1 + countLines xs+    Just (x, 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 lines that were removed. Note     that the number of new lines removed might actually be less than 'n'- but in principle     this should not happen with the usaage in 'refactorDecl' -} -removeNewLines [] n = ([], 0)- removeNewLines xs 0 = (xs, 0)- -- Deal with CR LF in the same way as just LF-removeNewLines ('\r':('\n':('\r':('\n':xs)))) n = let (xs', n') = removeNewLines ('\r':'\n':xs) (n - 1)-                                                   in (xs', n' + 1)--removeNewLines ('\n':('\n':xs)) n = let (xs', n') = removeNewLines ('\n':xs) (n - 1)-                                     in (xs', n' + 1)-removeNewLines (x:xs) n = let (xs', n') = removeNewLines xs n-                          in (x:xs', n)+removeNewLines xs n =+    case unpackFst (B.splitAt 4 xs) of+       ("\r\n\r\n", xs) -> (xs', n' + 1)+           where (xs', n') = removeNewLines ((B.pack "\r\n") `B.append` xs) (n - 1)+       _ ->+         case unpackFst (B.splitAt 2 xs) of+           ("\n\n", xs)     -> (xs', n' + 1)+               where (xs', n') = removeNewLines ((B.pack "\n") `B.append` xs) (n - 1)+           _ ->+            case B.uncons xs of+                Nothing -> (xs, 0)+                Just (x, xs) -> (B.cons x xs', n)+                    where (xs', n') = removeNewLines xs n +unpackFst (x, y) = (B.unpack x, y) --removeNewLines ('\n':xs) 0 = let (xs', n') = removeNewLines xs 0 --                             in ('\n':xs', 0)

@@ -50,10 +50,10 @@ import Text.Printf  class PrettyPrint p where-  prettyPrint :: p -> String+  prettyPrint :: p -> SourceText  instance (PrintMaster (Program Annotation) DefaultPP) => PrettyPrint (Program Annotation) where-  prettyPrint p = let ?variant = DefaultPP in printMaster p+  prettyPrint p = let ?variant = DefaultPP in B.pack $ printMaster p  -- Define new pretty printing version for HTML output data HTMLPP = HTMLPP@@ -270,10 +270,7 @@      "<u>show ast</u></div><div id='a" ++ (show $ number t) ++ "src' " ++      "style='background:#fff;display:none;width:600px;overflow:wrap;'>" ++ (astString) ++ "</div></div>" ++ "<p><table>" ++      row ["lives: (in) ",    showList $ (map show) $ fst $ lives t, "(out)", showList $ (map show) $ snd $ lives t] ++-     row ["indices:",  showList $ indices t] ++      row ["successors:", showList $ (map show) (successorStmts t)] ++-     row ["arrays R:", showExps (assocs $ arrsRead t)] ++-     row ["arrays W:", showExps (assocs $ arrsWrite t)] ++      "</table></p></div><br />\n\r\n"          where            listToPair x       = "(" ++ listToPair' x ++ ")"

@@ -22,8 +22,8 @@  import Camfort.PrettyPrint import Camfort.Analysis.Annotations-import Camfort.Helpers import Camfort.Traverse+import Camfort.Helpers  import qualified Data.ByteString.Char8 as B import Data.Functor.Identity@@ -33,57 +33,111 @@ import Language.Fortran import Camfort.Analysis.Syntax --- Start of GLORIOUS REFACTORING ALGORITHM!--- FIXME: Use ByteString! (Or Data.Text, at least)+{-+Reminder:+ -- type SourceText    = B.ByteString+ -- data SrcLoc+       = SrcLoc {srcFilename :: String, srcLine :: Int, srcColumn :: Int}+-} -reprint :: (Data (p Annotation), PrettyPrint (p Annotation))-        => (forall a . Typeable a => [String] -> SrcLoc -> a -> State Int (String, SrcLoc, Bool))-        -> SourceText -> Filename -> p Annotation -> String-reprint refactoring input f p+type Refactored = Bool++-- A refactoring takes a 'Typeable' value+-- into a stateful SourceText (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 SrcLoc which is the "cursor"+-- within the original source text. The incoming value corresponds to+-- the position of the first character in the input SourceText. The+-- outgoing value is a cursor ahead of the incoming one which shows+-- the amount of SourceText that is consumed by the refactoring.++type Refactoring m =+    forall b .+     Typeable b => b -> SourceText -> StateT SrcLoc m (SourceText, Refactored)++-- The reprint algorithm takes a refactoring (parameteric in+-- some monad m) and turns an arbitrary pretty-printable type 'p'+-- into a monadic SourceText transformer.++reprint :: (Monad m, Data p, PrettyPrint p)+        => Refactoring m -> p -> SourceText -> m SourceText+reprint refactoring tree input   -- If the inupt is null then switch into pretty printer-  | B.null input = prettyPrint p+  | B.null input = return $ prettyPrint tree   -- Otherwise go with the normal algorithm-  | otherwise =-    pn ++ pe-  where input' = map B.unpack $ B.lines input-        len = Prelude.length input'-        start = SrcLoc f 1 0-        end = SrcLoc f len (1 + (Prelude.length $ Prelude.last input'))-        (pn, cursorn) = evalState (reprintC refactoring start input' (toZipper p)) 0-        (_, inpn) = takeBounds (start, cursorn) input'-        (pe, _) = takeBounds (cursorn, end) inpn+  | otherwise = do+      -- Create an initial cursor at the start of the file+      let cursor0 = SrcLoc "" 1 0+      -- Enter the top-node of a zipper for 'tree'+      -- setting the cursor at the start of the file+      (output, cursorn) <- runStateT (enter refactoring (toZipper tree) input) cursor0+      -- Remove from the input the portion covered by the main algorithm+      -- leaving the rest of the file not covered within the bounds of+      -- the tree+      let (_, remaining)  = takeBounds (cursor0, cursorn) input+      return $ output `B.append` remaining -reprintC :: (forall b . (Typeable b) => [String] -> SrcLoc -> b -> State Int (String, SrcLoc, Bool))-         -> SrcLoc -> [String] -> Zipper a -> State Int (String, SrcLoc)-reprintC refactoring cursor inp z = do-  (p1, cursor', flag) <- query (refactoring inp cursor) z+-- The enter, enterDown, enterRight each take a refactoring+-- and a zipper producing a stateful SourceText transformer with SrcLoc state. -  (_, inp')       <- return $ takeBounds (cursor, cursor') inp-  (p2, cursor'')  <- if flag then return ("", cursor')-                             else enterDown refactoring cursor' inp' z+enter, enterDown, enterRight+  :: Monad m+  => Refactoring m -> Zipper a -> SourceText -> StateT SrcLoc m SourceText -  (_, inp'')      <- return $ takeBounds (cursor', cursor'') inp'-  (p3, cursor''') <- enterRight refactoring cursor'' inp'' z+-- `enter` applies the generic refactoring to the current context+-- of the zipper+enter refactoring z inp = do -  return (p1 ++ p2 ++ p3, cursor''')+  -- Part 1.+  -- Apply a refactoring+  cursor     <- get+  (p1, refactored) <- query (flip refactoring inp) z -enterDown, enterRight ::-             (forall b . (Typeable b) => [String] -> SrcLoc -> b -> State Int (String, SrcLoc, Bool))-          -> SrcLoc -> [String] -> Zipper a -> State Int (String, SrcLoc)-enterDown refactoring cursor inp z = case (down' z) of-                             Just dz -> reprintC refactoring cursor inp dz-                             Nothing -> return $ ("", cursor)+  -- Part 2.+  -- Cut out the portion of source text consumed by the refactoring+  cursor'    <- get+  (_, inp')  <- return $ takeBounds (cursor, cursor') inp+  -- If a refactoring was not output,+  -- Enter the children of the current context+  p2         <- if refactored+                   then return B.empty+                   else enterDown refactoring z inp' -enterRight refactoring cursor inp z = case (right z) of-                             Just rz -> reprintC refactoring cursor inp rz-                             Nothing -> return $ ("", cursor)+  -- Part 3.+  -- Cut out the portion of source text consumed by the children+  -- then enter the right sibling of the current context+  cursor''   <- get+  (_, inp'') <- return $ takeBounds (cursor', cursor'') inp'+  p3         <- enterRight refactoring z inp'' -takeBounds (l, u) inp = takeBounds' (lineCol l, lineCol u) [] inp-takeBounds' ((ll, lc), (ul, uc)) tk inp  =-    if (ll == ul && lc == uc) || (ll > ul) then (Prelude.reverse tk, inp)-    else case inp of []             -> (Prelude.reverse tk, inp)-                     ([]:[])        -> (Prelude.reverse tk, inp)-                     ([]:ys)        -> takeBounds' ((ll+1, 0), (ul, uc)) ('\n':tk) ys-                     ((x:xs):ys)    -> takeBounds' ((ll, lc+1), (ul, uc)) (x:tk) (xs:ys)+  -- Conat the output for the current context, children, and right sibling+  return $ B.concat [p1, p2, p3] --- End of GLORIOUS REFACTORING ALGORITHM+-- `enterDown` navigates to the children of the current context+enterDown refactoring z inp =+  case (down' z) of+    -- Go to children+    Just dz -> enter refactoring dz inp+    -- No children+    Nothing -> return $ B.empty++-- `enterRight` navigates to the right sibling of the current context+enterRight refactoring z inp =+  case (right z) of+    -- Go to right sibling+    Just rz -> enter refactoring rz inp+    -- No right sibling+    Nothing -> return $ B.empty++-- Given a lower-bound and upper-bound pair of SrcLocs, split the+-- incoming SourceText based on the distance between the SrcLoc pairs+takeBounds :: (SrcLoc, SrcLoc) -> SourceText -> (SourceText, SourceText)+takeBounds (l, u) inp = takeBounds' (lineCol l, lineCol u) B.empty inp+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

@@ -30,10 +30,6 @@  {- *** Routines for associating annotations to ASTs -} --- Helper for transforming the 'previous' annotation-onPrev :: (a -> a) -> FA.Analysis a -> FA.Analysis a-onPrev f ann = ann { FA.prevAnnotation = f (FA.prevAnnotation ann) }- -- Instances for embedding parsed specifications into the AST instance ASTEmbeddable (FA.Analysis Annotation) Gram.Specification where   annotateWithAST ann ast =

@@ -33,7 +33,6 @@ import Camfort.Specification.Stencils.Model import qualified Camfort.Specification.Stencils.Grammar as SYN -import Camfort.Analysis.Loops (collect) import Camfort.Analysis.Annotations import Camfort.Helpers.Vec -- These two are redefined here for ForPar ASTs

@@ -35,7 +35,6 @@ import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.Synthesis import Camfort.Specification.Stencils.Syntax-import Camfort.Analysis.Loops (collect) import Camfort.Analysis.Annotations import Camfort.Analysis.CommentAnnotator import Camfort.Helpers

@@ -35,9 +35,9 @@ import Camfort.Specification.Stencils.Annotation import qualified Camfort.Specification.Stencils.Grammar as Gram import qualified Camfort.Specification.Stencils.Synthesis as Synth-import Camfort.Analysis.Loops (collect) import Camfort.Analysis.Annotations import Camfort.Helpers.Vec+import Camfort.Helpers (collect) import Camfort.Input import qualified Camfort.Output as O @@ -79,7 +79,7 @@ type LogLine = (FU.SrcSpan, Either [([Variable], Specification)] (String,Variable)) -- The core of the inferer works within this monad type Inferer = WriterT [LogLine]-                 (ReaderT (Cycles, F.ProgramUnitName, TypeEnv A)+                 (ReaderT (Cycles, F.ProgramUnitName)                     (State InferState))  type Cycles = [(F.Name, F.Name)]@@ -89,12 +89,11 @@ runInferer :: FAD.InductionVarMapByASTBlock            -> Cycles            -> F.ProgramUnitName-           -> TypeEnv A            -> Inferer a            -> (a, [LogLine])-runInferer ivmap cycles puName tenv =+runInferer ivmap cycles puName =     flip evalState (IS ivmap [])-  . flip runReaderT (cycles, puName, tenv)+  . flip runReaderT (cycles, puName)   . runWriterT  stencilInference :: FAR.NameMap@@ -102,20 +101,20 @@                  -> F.ProgramFile (FA.Analysis A)                  -> (F.ProgramFile (FA.Analysis A), [LogLine]) stencilInference nameMap mode pf =-    (F.ProgramFile cm_pus' blocks', log1 ++ log2)+    (F.ProgramFile mi cm_pus' blocks', log1 ++ log2)   where     -- Parse specification annotations and include them into the syntax tree     -- that way if generate specifications at the same place we can     -- decide whether to synthesise or not      -- TODO: might want to output log0 somehow (though it doesn't fit LogLine)-    (pf'@(F.ProgramFile cm_pus blocks), log0) =+    (pf'@(F.ProgramFile mi cm_pus blocks), log0) =          if mode == Synth           then runWriter (annotateComments Gram.specParser pf)           else (pf, [])      (cm_pus', log1) = runWriter (transformBiM perPU cm_pus)-    (blocks', log2) = runInferer ivMap [] F.NamelessBlockData tenv blocksInf+    (blocks', log2) = runInferer ivMap [] F.NamelessBlockData blocksInf     blocksInf       = let ?flowsGraph = flTo                           ?nameMap    = nameMap                       in descendBiM (perBlockInfer mode) blocks@@ -129,7 +128,7 @@              ?nameMap    = nameMap          in do               let pum = descendBiM (perBlockInfer mode) pu-              let (pu', log) = runInferer ivMap [] (FA.puName pu) tenv pum+              let (pu', log) = runInferer ivMap [] (FA.puName pu) pum               tell log               return pu'     perPU pu = return pu@@ -155,7 +154,6 @@      -- get map of variable name ==> { defining AST-Block-IDs }     dm    = FAD.genDefMap bm-    tenv  = FAT.inferTypes pf  -- | Return list of variable names that flow into themselves via a 2-cycle findVarFlowCycles :: Data a => F.ProgramFile a -> [(F.Name, F.Name)]@@ -591,17 +589,6 @@ isVariableExpr :: F.Expression a -> Bool isVariableExpr (F.ExpValue _ _ (F.ValVariable _)) = True isVariableExpr _                                  = False---- Although type analysis isn't necessary anymore (Forpar does it--- internally) I'm going to leave this infrastructure in-place in case--- it might be useful later.-type TypeEnv a = M.Map FAT.TypeScope (M.Map String FA.IDType)-isArrayType :: TypeEnv A -> F.ProgramUnitName -> String -> Bool-isArrayType tenv name v = fromMaybe False $ do-  tmap <- M.lookup (FAT.Local name) tenv `mplus` M.lookup FAT.Global tenv-  idty <- M.lookup v tmap-  cty  <- FA.idCType idty-  return $ cty == FA.CTArray  -- Penelope's first code, 20/03/2016. -- iii././//////////////////////. mvnmmmmmmmmmu

@@ -33,7 +33,6 @@ import Camfort.Specification.Stencils.Syntax import Camfort.Specification.Stencils.Model -import Camfort.Analysis.Loops (collect) import Camfort.Analysis.Annotations import Camfort.Helpers.Vec -- These two are redefined here for ForPar ASTs@@ -119,6 +118,5 @@                                  (F.ExpValue a s (F.ValInteger $ show (abs o))))  offsetToIxWithIVs :: [Variable] -> F.Name -> Int -> F.Index (FA.Analysis A)-offsetToIxWithIVs ivs v o = F.setAnnotation a' ix-  where a'  = a { FA.prevAnnotation = (FA.prevAnnotation a) {indices = ivs} }-        ix  = offsetToIx v o+offsetToIxWithIVs ivs v o = F.setAnnotation a ix+  where ix  = offsetToIx v o

@@ -13,256 +13,200 @@    See the License for the specific language governing permissions and    limitations under the License. -}+ {-    Units of measure extension to Fortran -TODO:- * Deal with variable shadowing in "contained" functions.- * Better errors with line number info- -} --{-# LANGUAGE ScopedTypeVariables, ImplicitParams, DoAndIfThenElse,-             PatternGuards, ConstraintKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}  module Camfort.Specification.Units-          (Solver, removeUnits, checkUnits-                 , inferUnits, synthesiseUnits-                 , inferCriticalVariables)  where-+  (checkUnits, inferUnits, synthesiseUnits, inferCriticalVariables)+where -import Data.Data-import Data.Char (isNumber)-import Data.List-import Data.Maybe import qualified Data.Map as M-import Data.Label.Mono (Lens)-import qualified Data.Label-import Data.Label.Monadic hiding (modify)-import Data.Function-import Data.Matrix+import Data.Char (isNumber)+import Data.List (intercalate)+import Data.Maybe (fromMaybe, maybeToList, listToMaybe) import Data.Generics.Uniplate.Operations-import Control.Monad.State.Strict hiding (gets)-import Control.Monad.Identity+import Control.Monad.State.Strict -import Camfort.Helpers+import Camfort.Helpers hiding (lineCol) import Camfort.Output-import Camfort.Analysis.Annotations hiding (Unitless)+import Camfort.Analysis.Annotations import Camfort.Analysis.Syntax import Camfort.Analysis.Types- import Camfort.Input-import Camfort.Specification.Units.Debug-import Camfort.Specification.Units.InferenceBackend-import Camfort.Specification.Units.InferenceFrontend-import qualified Camfort.Specification.Units.Synthesis as US-import Camfort.Specification.Units.Strip  -- Provides the types and data accessors used in this module import Camfort.Specification.Units.Environment--- Solvers for the Gaussian matrix-import Camfort.Specification.Units.Solve+import Camfort.Specification.Units.Monad+import Camfort.Specification.Units.InferenceBackend+import Camfort.Specification.Units.InferenceFrontend+import Camfort.Specification.Units.Synthesis (runSynthesis)  import qualified Language.Fortran.Analysis.Renaming as FAR-import qualified Language.Fortran.Analysis.BBlocks as FAB import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.AST as F-import Camfort.Transformation.Syntax+import qualified Language.Fortran.Util.Position as FU  -- For debugging and development purposes import qualified Debug.Trace as D ---------------------------------------------------- Set the default options for the inference--instance Default Solver where-    defaultValue = Custom-instance Default AssumeLiterals where-    defaultValue = Poly--{- START HERE! Two main functions of this file: inferUnits and removeUnits -}---- Deprecated-removeUnits ::-    (Filename, F.ProgramFile Annotation) -> (Report, (Filename, F.ProgramFile Annotation))-removeUnits (fname, x) = undefined-  {-  let ?criticals = False-    in ("", (fname, map (descendBi removeUnitsInBlock) x)) -}-- -- ************************************* --   Unit inference (top - level) -- -- ************************************* -type Params = (?solver :: Solver, ?assumeLiterals :: AssumeLiterals)+inferCriticalVariables, checkUnits, inferUnits, synthesiseUnits+  :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> (Report, (Filename, F.ProgramFile Annotation))  {-| Infer one possible set of critical variables for a program -}-inferCriticalVariables ::-       Params-    => (Filename, F.ProgramFile Annotation)-    -> (Report, (Filename, F.ProgramFile Annotation))-inferCriticalVariables (fname, pf) = (r, (fname, pf))+inferCriticalVariables uo (fname, pf)+  | Right vars <- eVars = (okReport vars, (fname, pf))+  | Left exc   <- eVars = (errReport exc, (fname, pf))   where     -- Format report-    r = concat [fname ++ ": " ++ r ++ "\n" | r <- Data.Label.get report env]+    okReport []   = logs ++ "\n\n" ++ "No additional annotations are necessary.\n"+    okReport vars = logs ++ "\n\n" ++ unlines [ fname ++ ": " ++ expReport ei | ei <- expInfo ]+      where+        names = map showVar vars+        expInfo = [ e | s@(F.StDeclaration {})               <- universeBi pfUA :: [F.Statement UA]+                      , e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi s    :: [F.Expression UA]+                      , FA.varName e `elem` names ] -    -- Run the infer procedure with empty unit environment, retunring-    -- the updated unit environment, matching variables to their units-    env = let ?criticals = True-              ?debug     = False-              ?nameMap   = nameMap-              ?argumentDecls = False-          in  flip execState emptyUnitEnv-              (do-                 doInferUnits . FAB.analyseBBlocks $ pf'-                 vars <- criticalVars nameMap-                 case vars of-                   [] -> report <<++ "No critical variables. Appropriate annotations."-                   _  -> report <<++ "Critical variables: "-                                ++ (concat $ intersperse "," vars)-                 ifDebug debugGaussian)+    expReport e = showSrcSpan (FU.getSpan e) ++ " " ++ unrename nameMap v+      where v = FA.varName e -    pf' = FAR.analyseRenames . FA.initAnalysis $ (fmap mkUnitAnnotation pf)-    nameMap = FAR.extractNameMap pf'-    -- Core infer procedure-    --infer :: (Params, ?argumentDecls :: Bool) => State UnitEnv ()+    varReport     = intercalate ", " . map showVar +    showVar (UnitVar v)     = v+    showVar (UnitLiteral _) = "<literal>"+    showVar _               = "<bad>"++    errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs++    -- run inference+    uOpts = uo { uoNameMap = nameMap }+    (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runCriticalVariables+    pfUA = usProgramFile state -- the program file after units analysis is done++    pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf+    nameMap = FAR.extractNameMap pfRenamed+ {-| Check units-of-measure for a program -}-checkUnits ::-       Params-    => (Filename, F.ProgramFile Annotation)-    -> (Report, (Filename, F.ProgramFile Annotation))-checkUnits (fname, pf) = (r, (fname, pf))+checkUnits uo (fname, pf)+  | Right mCons <- eCons = (okReport mCons, (fname, pf))+  | Left exc    <- eCons = (errReport exc, (fname, pf))   where     -- Format report-    r = concat [fname ++ ": " ++ r ++ "\n" | r <- Data.Label.get report env, not (null r)]-        ++ fname ++ ": checked " ++ show n ++ " user variables\n"+    okReport Nothing = fname ++ ": Consistent. " ++ show nVars ++ " variables checked.\n" ++ logs+    okReport (Just cons) = logs ++ "\n\n" ++ fname ++ ": Inconsistent:\n" +++                           unlines [ fname ++ ": " ++ srcSpan con ++ " constraint " ++ show (unrename nameMap con) | con <- cons ]+      where+        srcSpan con | Just ss <- findCon con = showSrcSpan ss ++ " "+                    | otherwise              = "" -    -- Count number of checked and inferred variables-    n = countVariables (_varColEnv env) (_debugInfo env) (_procedureEnv env)-                                    (fst $ _linearSystem env) (_unitVarCats env)+    -- Find a given constraint within the annotated AST. FIXME: optimise+    findCon :: Constraint -> Maybe FU.SrcSpan+    findCon con = listToMaybe $ [ FU.getSpan x | x <- universeBi pfUA :: [F.Expression UA], getConstraint x `eq` con ] +++                                [ FU.getSpan x | x <- universeBi pfUA :: [F.Statement UA] , getConstraint x `eq` con ] +++                                [ FU.getSpan x | x <- universeBi pfUA :: [F.Declarator UA], getConstraint x `eq` con ] +++                                [ FU.getSpan x | x <- universeBi pfUA :: [F.Argument UA]  , getConstraint x `eq` con ]+      where eq Nothing _    = False+            eq (Just c1) c2 = conParamEq c1 c2 -    pf' = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ (fmap mkUnitAnnotation pf)-    nameMap = FAR.extractNameMap pf'-    -- Apply inferences-    env = let ?criticals = False-              ?debug     = False-              ?nameMap   = nameMap-              ?argumentDecls = False-          in execState (doInferUnits pf') emptyUnitEnv+    varReport     = intercalate ", " . map showVar +    showVar (UnitVar v)     = v `fromMaybe` M.lookup v nameMap+    showVar (UnitLiteral _) = "<literal>" -- FIXME+    showVar _               = "<bad>"++    errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs++    -- run inference+    uOpts = uo { uoNameMap = nameMap }+    (eCons, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInconsistentConstraints+    pfUA :: F.ProgramFile UA+    pfUA = usProgramFile state -- the program file after units analysis is done++    -- number of 'real' variables checked, e.g. not parametric+    nVars = M.size . M.filter (not . isParametricUnit) $ usVarUnitMap state+    isParametricUnit u = case u of UnitParamPosAbs {} -> True; UnitParamPosUse {} -> True+                                   UnitParamVarAbs {} -> True; UnitParamVarUse {} -> True+                                   _ -> False++    pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf+    nameMap = FAR.extractNameMap pfRenamed+ {-| Check and infer units-of-measure for a program-     This produces an output of all the unit information for a program -}-inferUnits ::-       Params-    => (Filename, F.ProgramFile Annotation)-    -> (Report, (Filename, F.ProgramFile Annotation))-inferUnits (fname, pf) = (r, (fname, pf))+    This produces an output of all the unit information for a program -}+inferUnits uo (fname, pf)+  | Right []   <- eVars = checkUnits uo (fname, pf)+  | Right vars <- eVars = (okReport vars, (fname, pf))+  | Left exc   <- eVars = (errReport exc, (fname, pf))   where     -- Format report-    r = fname ++ ":\n" ++-        concat [ r ++ "\n" | r <- Data.Label.get report env, not (null r)]-        ++ fname ++ ": checked/inferred " ++ show n ++ " user variables\n"+    okReport vars = logs ++ "\n\n" ++ unlines [ fname ++ ": " ++ expReport ei | ei <- expInfo ]+      where+        expInfo = [ (e, u) | s@(F.StDeclaration {})               <- universeBi pfUA :: [F.Statement UA]+                           , e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi s    :: [F.Expression UA]+                           , u <- maybeToList (FA.varName e `lookup` vars) ] -    -- Count number of checked and inferred variables-    n = countVariables (_varColEnv env) (_debugInfo env) (_procedureEnv env)-                                    (fst $ _linearSystem env) (_unitVarCats env)-    -- Apply inference and synthesis-    (_, env) = runState inferAndSynthesise emptyUnitEnv-    inferAndSynthesise =-        let ?criticals = False-            ?debug     = False-            ?nameMap   = nameMap-            ?argumentDecls = False-        in do-          doInferUnits pf'-          succeeded <- gets success-          if succeeded-            then US.synthesiseUnits True pf'-            else return pf'-    pf' = FAB.analyseBBlocks-        . FAR.analyseRenames-        . FA.initAnalysis-        . fmap mkUnitAnnotation $ pf-    nameMap = FAR.extractNameMap pf'+    expReport (e, u) = showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ unrename nameMap v+      where v = FA.varName e +    errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs +    -- run inference+    uOpts = uo { uoNameMap = nameMap }+    (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables++    pfUA = usProgramFile state -- the program file after units analysis is done++    pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf+    nameMap = FAR.extractNameMap pfRenamed+ {-| Synthesis unspecified units for a program (after checking) -}-synthesiseUnits ::-       Params-    => (Filename, F.ProgramFile Annotation)-    -> (Report, (Filename, F.ProgramFile Annotation))-synthesiseUnits (fname, pf) = (r, (fname, fmap (prevAnnotation . FA.prevAnnotation) pf3))+synthesiseUnits uo (fname, pf)+  | Right []   <- eVars = checkUnits uo (fname, pf)+  | Right vars <- eVars = (okReport vars, (fname, pfFinal))+  | Left exc   <- eVars = (errReport exc, (fname, pfFinal))   where     -- Format report-    r = concat [fname ++ ": " ++ r ++ "\n" | r <- Data.Label.get report env, not (null r)]-        ++ fname ++ ": checked/inferred " ++ show n ++ " user variables\n"-    -- Count number of checked and inferred variables-    n = countVariables (_varColEnv env) (_debugInfo env) (_procedureEnv env)-                                    (fst $ _linearSystem env) (_unitVarCats env)-    -- Apply inference and synthesis-    pf' = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ (fmap mkUnitAnnotation pf)-    (pf3, env) = runState inferAndSynthesise emptyUnitEnv-    nameMap = FAR.extractNameMap pf'-    inferAndSynthesise =-        let ?criticals = False-            ?debug     = False-            ?nameMap   = nameMap-            ?argumentDecls = False-        in do-          doInferUnits pf'-          succeeded <- gets success-          if succeeded-            then do-              p <- US.synthesiseUnits False pf'-              (n, _) <- gets evUnitsAdded-              report <<++ ("Added " ++ (show n) ++ " annotations")-              return p-            else return pf'+    okReport vars = logs ++ "\n\n" ++ unlines [ fname ++ ": " ++ expReport ei | ei <- expInfo ]+      where+        expInfo = [ (e, u) | s@(F.StDeclaration {})               <- universeBi pfUA :: [F.Statement UA]+                           , e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi s    :: [F.Expression UA]+                           , u <- maybeToList (FA.varName e `lookup` vars) ] --- Count number of variables for which a spec has been checked-countVariables vars debugs procs matrix ucats =-    length $ filter (\c -> case (ucats !! (c - 1)) of-                             Variable -> case (lookupVarsByCols vars [c]) of-                                           [] -> False-                                           _  -> True-                             Argument -> case (lookupVarsByCols vars [c]) of-                                           [] -> False-                                           _  -> True-                             _        -> False) [1..ncols matrix]+    expReport (e, u) = showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ (v `fromMaybe` M.lookup v nameMap)+      where v = FA.varName e --- Critical variables analysis-criticalVars :: FAR.NameMap -> State UnitEnv [String]-criticalVars nameMap = do-    uvarenv     <- gets varColEnv-    (matrix, vector) <- gets linearSystem-    ucats       <- gets unitVarCats-    dbgs        <- gets debugInfo-    -- debugGaussian-    let cv1 = criticalVars' uvarenv ucats matrix 1 dbgs-    let cv2 = [] -- criticalVars-    return (map realName (cv1 ++ cv2))-      where realName v = v `fromMaybe` (v `M.lookup` nameMap)+    errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs -criticalVars' :: VarColEnv-              -> [UnitVarCategory]-              -> Matrix Rational-              -> Row-              -> DebugInfo -> [String]-criticalVars' varenv ucats matrix i dbgs =-  let m = firstNonZeroCoeff matrix ucats-  in-    if (i == nrows matrix) then-      if (m i) /= (ncols matrix)-      then lookups [((m i) + 1)..(ncols matrix)] dbgs-      else []-    else-      if (m (i + 1)) /= ((m i) + 1)-      then (lookups [((m i) + 1)..(m (i + 1) - 1)] dbgs)-        ++ (criticalVars' varenv ucats matrix (i + 1) dbgs)-      else criticalVars' varenv ucats matrix (i + 1) dbgs-  where-    lookups = lookupVarsByColsFilterByArg matrix varenv ucats+    -- run inference+    uOpts = uo { uoNameMap = nameMap }+    (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables >>= runSynthesis++    pfUA = usProgramFile state -- the program file after units analysis is done+    pfFinal = fmap prevAnnotation . fmap FA.prevAnnotation $ pfUA -- strip annotations++    pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf+    nameMap = FAR.extractNameMap pfRenamed++--------------------------------------------------++unrename nameMap = transformBi $ \ x -> x `fromMaybe` M.lookup x nameMap++showSrcLoc :: FU.Position -> String+showSrcLoc loc = show (lineCol loc) ++ ":" ++ show (lineCol loc)++showSrcSpan :: FU.SrcSpan -> String+showSrcSpan (FU.SrcSpan l u) = "(" ++ showSrcLoc l ++ " - " ++ showSrcLoc u ++ ")"++lineCol :: FU.Position -> (Int, Int)+lineCol p  = (fromIntegral $ FU.posLine p, fromIntegral $ FU.posColumn p)

@@ -1,197 +0,0 @@-{--   Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish--   Licensed under the Apache License, Version 2.0 (the "License");-   you may not use this file except in compliance with the License.-   You may obtain a copy of the License at--       http://www.apache.org/licenses/LICENSE-2.0--   Unless required by applicable law or agreed to in writing, software-   distributed under the License is distributed on an "AS IS" BASIS,-   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.-   See the License for the specific language governing permissions and-   limitations under the License.--}-{---  Units of measure extension to Fortran--TODO:- * Deal with variable shadowing in "contained" functions.- * Better errors with line number info---}---{-# LANGUAGE ScopedTypeVariables, ImplicitParams, DoAndIfThenElse #-}--module Camfort.Specification.Units.Debug where---import qualified Data.Vector as V-import qualified Debug.Trace as D-import Data.Data-import Data.Char-import Data.Maybe-import Data.Function-import Data.Matrix-import Data.List-import Data.Matrix-import Data.Ratio-import Data.Generics.Uniplate.Operations-import Data.Label.Monadic hiding (modify)-import Control.Monad.State.Strict hiding (gets)-import Control.Monad--import Camfort.Analysis.Annotations hiding (Unitless)-import Camfort.Specification.Units.Environment-import Camfort.Transformation.Syntax--import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Util.Position as FU---- *************************************---   Debugging and testing functions------ *************************************----- QuickCheck instance for matrices, used for testing matrix operations-{--instance (Arbitrary a) => Arbitrary (Matrix a) where-    arbitrary = sized (\n -> do xs <- vectorOf (n*n) arbitrary-                                return $ matrix n n (\(i, j) -> xs !! ((i-1)*n + (j-1))))--}---- Matrix for development-fooMatrix :: Matrix Rational-fooMatrix = matrix 4 4 $ (\(i,j) -> if (i==j) then (toInteger i) % 1 else 0)---{-| debugGaussian - a debugging routine which shose the Gaussian matrix with various peieces of info-                    mainly used for development purposes -}-debugGaussian :: State UnitEnv String-debugGaussian = do grid' <- debugGaussian'-                   report <<++ ("Dump of units-of-measure system matrix\n" ++ grid')-                   return grid'--debugGaussian' = do ucats   <- gets unitVarCats-                    (matrix,rowv)  <- gets linearSystem-                    varenv  <- gets varColEnv-                    debugs  <- gets debugInfo-                    procenv <- gets procedureEnv--                    let -- Column headings and then a space-                        grid = ["" : map show [1..(ncols matrix)], []]-                        -- Gaussian matrix-                            ++ map (\r -> (show r) : (map showRational $ V.toList $ getRow r matrix) ++ [show $ rowv !! (r - 1)]) [1..(nrows matrix)]-                        -- Column categories-                            ++ [[], "" : map showCat ucats]-                        -- Debug info, e.g., expression or variable-                            ++ ["" : map (showExpr ucats varenv procenv debugs) [1.. (ncols matrix)]]-                        -- Additional debug info for args that are also variables-                            ++ ["" : map (showArgVars ucats varenv) [1..(ncols matrix)]]-                    let colSize = maximum' (map maximum' (map (notLast . (map length)) grid))-                    let expand r = r ++ (replicate (colSize - length r) ' ')-                    let showLine x = (concatMap expand x) ++ "\n"--                    let grid' = concatMap showLine grid-                    return grid'--   where maximum' [] = 0-         maximum' xs = maximum xs--         notLast xs = take (length xs - 1) xs--showExpr cats vars procs debugInfo c =-             case (cats !! (c - 1)) of-               Variable  -> case (lookupVarsByCols vars [c]) of-                              []    -> case (lookupProcByCols procs [c]) of-                                         []    -> "?"-                                         (x:_) -> "=" ++ x-                              (x:_) -> x-               Temporary -> snd $ case (lookup c debugInfo) of-                                    Just x -> x-                                    Nothing -> (undefined, "") -- error $ "Temporary fail " ++ (show c) " not in " ++ (show cats)-               Argument  -> case (lookupProcByArgCol procs [c]) of-                              []    -> "?"-                              (x:_) -> x-               Literal _  -> snd $ case (lookup c debugInfo) of-                                    Just x -> x-                                    Nothing -> show c `D.trace` error "Literal fail"-               Magic     -> ""--lineCol :: FU.Position -> (Int, Int)-lineCol p  = (fromIntegral $ FU.posLine p, fromIntegral $ FU.posColumn p)--showSrcLoc loc = show (lineCol loc) ++ ":" ++ show (lineCol loc)-showSrcSpan (FU.SrcSpan l u) = "(" ++ showSrcLoc l ++ " - " ++ showSrcLoc u ++ ")"--showExprLines cats vars procs debugInfo c =-             case (cats !! (c - 1)) of-               Variable  -> case (lookup c debugInfo) of-                              Just (sp, expr) -> (showSrcSpan sp) ++ "\t" ++ expr-                              Nothing ->-                                case (lookupVarsByCols vars [c]) of-                                  []    -> case (lookupProcByCols procs [c]) of-                                             []    -> "?"-                                             (x:_) -> "=" ++ x-                                  (x:_) -> x-               Temporary -> let (sp, expr) = fromJust $ lookup c debugInfo-                            in (showSrcSpan sp) ++ "\t" ++ expr-               Argument  -> case (lookupProcByArgCol procs [c]) of-                              []    -> "?"-                              (x:_) -> x-               Literal _ -> let (sp, expr) = fromJust $ lookup c debugInfo-                            in (showSrcSpan sp) ++ "\t" ++ expr-               Magic     -> ""--showArgVars cats vars c =-             case (cats !! (c - 1)) of-               Argument -> case (lookupVarsByCols vars [c]) of-                             []    -> ""-                             (x:_) -> x-               _        -> ""---showCat Variable  = "Var"-showCat Magic     = "Magic"-showCat Temporary = "Temp"-showCat Argument  = "Arg"-showCat (Literal False) = "Lit"-showCat (Literal True)  = "Lit="--lookupProcByArgCol :: ProcedureEnv -> [Int] -> [String]-lookupProcByArgCol penv cols =-             mapMaybe (\j -> lookupEnv j penv) cols-                 where lookupEnv j [] = Nothing-                       lookupEnv j ((p, (_, args)):penv)-                           | elem (VarCol j) args  = Just (p ++ "#" ++ (show $ fromJust $ elemIndex (VarCol j) args))-                           | otherwise    = lookupEnv j penv---lookupProcByCols :: ProcedureEnv -> [Int] -> [String]-lookupProcByCols penv cols =-             mapMaybe (\j -> lookupEnv j penv) cols-                 where lookupEnv j [] = Nothing-                       lookupEnv j ((p, (Just (VarCol i), _)):penv)-                                    | i == j    = Just p-                                    | otherwise = lookupEnv j penv-                       lookupEnv j ((p, (Nothing, _)):penv) = lookupEnv j penv--lookupVarsByCols :: VarColEnv -> [Int] -> [F.Name]-lookupVarsByCols uenv cols = mapMaybe (\j -> lookupEnv j uenv) cols-                 where lookupEnv j [] = Nothing-                       lookupEnv j ((VarBinder (v, _), (VarCol i, _)):uenv)-                                    | i == j    = Just v-                                    | otherwise = lookupEnv j uenv--lookupVarBindersByCols :: VarColEnv -> [Int] -> [VarBinder]-lookupVarBindersByCols uenv cols = mapMaybe (\j -> lookupEnv j uenv) cols-                 where lookupEnv j [] = Nothing-                       lookupEnv j ((vb@(VarBinder (v, _)), (VarCol i, _)):uenv)-                                    | i == j    = Just vb-                                    | otherwise = lookupEnv j uenv--showRational r = show (numerator r) ++ if ((denominator r) == 1) then "" else "%" ++ (show $ denominator r)

@@ -13,7 +13,7 @@    See the License for the specific language governing permissions and    limitations under the License. -}-{-# LANGUAGE TemplateHaskell, ImplicitParams, DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}   {- Provides various data types and type class instances for the Units extension -}@@ -29,7 +29,6 @@ import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Util.Position as FU -import Camfort.Specification.Units.Parser import qualified Camfort.Specification.Units.Parser as P  import Data.Char@@ -38,78 +37,106 @@ import Data.Matrix import Data.Ratio -data UnitInfo-  = Parametric (String, Int)-  | ParametricUse (String, Int, Int) -- identify particular instantiation of parameters-  | UnitName String-  | Undetermined String-  | UnitlessI-  | UnitMul UnitInfo UnitInfo-  | UnitPow UnitInfo Double-  deriving (Show, Eq, Ord, Data, Typeable)--type EqualityConstrained = Bool--data Solver = LAPACK | Custom deriving (Show, Read, Eq, Data)-data AssumeLiterals = Poly | Unitless | Mixed deriving (Show, Read, Eq, Data)---- *****************---  Syntax------ *****************--{- Represents a constant unit expression (i.e. one without unit variables)-   for the RHSs of the Gaussian matrix.-    e.g. Unitful [("a", 2/3), ("b",2)]-         represents the linear term  2/3 log a + 2 log b-         UnitlessC marks unitless i.e., 1--}-data UnitConstant =-       Unitful [(F.Name, Rational)]-     | UnitlessC Rational-    deriving (Eq, Show, Data)---- Column of the Guassian matrix associated with a variable-newtype VarCol = VarCol Col deriving (Eq, Show)+import Text.Printf --- Map from Variable names to their column paired with any column of their indices---   e.g., for a(i,k) we have a map from 'a' to its column paired with---       a two element list of the columns for 'i' and 'j'+-- | 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, String)      -- an abstract parameter identified by PU name and variable name+  | UnitParamVarUse (String, String, 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+  | UnitLiteral Int                       -- literal with undetermined but uniquely identified units+  | UnitlessLit                           -- a unitless literal+  | UnitlessVar                           -- a unitless variable+  | UnitName String                       -- a basic unit+  | UnitAlias String                      -- the name of a unit alias+  | UnitVar String                        -- variable with undetermined units (assumed to have unique name)+  | UnitMul UnitInfo UnitInfo             -- two units multiplied+  | UnitPow UnitInfo Double               -- a unit raised to a constant power+  deriving (Eq, Ord, Data, Typeable) -newtype VarBinder = VarBinder (F.Name, FU.SrcSpan) deriving Show-type VarColEnv = [(VarBinder, (VarCol, [VarCol]))]+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+    UnitLiteral i             -> printf "#<Literal id=%d>" i+    UnitlessLit               -> "1"+    UnitlessVar               -> "1"+    UnitName name             -> name+    UnitAlias name            -> name+    UnitVar var               -> printf "#<Var %s>" var+    UnitMul u1 (UnitPow u2 k)+      | k < 0                 -> maybeParen u1 ++ " / " ++ show (UnitPow u2 (-k))+    UnitMul u1 u2             -> maybeParenS u1 ++ " " ++ maybeParenS u2+    UnitPow u 1               -> show u+    UnitPow u 0               -> "1"+    UnitPow u k               -> printf "%s**%s" (maybeParen u) kStr+      where kStr | k < 0     = printf "(%f)" k+                 | otherwise = show k+    where+      maybeParen x | all isAlphaNum s = s+                   | otherwise        = "(" ++ s ++ ")"+        where s = show x+      maybeParenS x | all isUnitMulOk s = s+                    | otherwise         = "(" ++ s ++ ")"+        where s = show x+      isUnitMulOk c = isSpace c || isAlphaNum c || c `elem` "*." -data UnitVarCategory =-    Literal EqualityConstrained-  | Temporary-  | Variable-  | Argument-  | Magic-  deriving (Eq, Show)+-- | A relation between UnitInfos+data Constraint+  = ConEq   UnitInfo UnitInfo        -- an equality constraint+  | ConConj [Constraint]             -- conjunction of constraints+  deriving (Eq, Ord, Data, Typeable)+type Constraints = [Constraint] -type DerivedUnitEnv = [(F.Name, UnitConstant)]+instance Show Constraint where+  show (ConEq u1 u2) = show u1 ++ " === " ++ show u2+  show (ConConj cs) = intercalate " && " (map show cs) -type ProcedureNames = (String, Maybe F.Name, [F.Name])-type Procedure = (Maybe VarCol, [VarCol])-type ProcedureEnv = [(String, Procedure)]+-------------------------------------------------- -type LinearSystem = (Matrix Rational, [UnitConstant])+-- | 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 (ConConj cs1) (ConConj cs2) = and $ zipWith conParamEq cs1 cs2+conParamEq _ _ = False -type Row = Int-type Col = Int+-- | Unit 'parametric' equality: treat all uses of a parametric+-- abstractions as equivalent to the abstraction.+unitParamEq :: UnitInfo -> UnitInfo -> Bool+unitParamEq (UnitParamLitAbs i)           (UnitParamLitUse (i', _))     = i == i'+unitParamEq (UnitParamLitUse (i', _))     (UnitParamLitAbs i)           = i == i'+unitParamEq (UnitParamVarAbs (f, i))      (UnitParamVarUse (f', i', _)) = (f, i) == (f', i')+unitParamEq (UnitParamVarUse (f', i', _)) (UnitParamVarAbs (f, i))      = (f, i) == (f', i')+unitParamEq (UnitParamPosAbs (f, i))      (UnitParamPosUse (f', i', _)) = (f, i) == (f', i')+unitParamEq (UnitParamPosUse (f', i', _)) (UnitParamPosAbs (f, i))      = (f, i) == (f', i')+unitParamEq (UnitMul u1 u2)               (UnitMul u1' u2')             = unitParamEq u1 u1' && unitParamEq u2 u2' ||+                                                                          unitParamEq u1 u2' && unitParamEq u2 u1'+unitParamEq (UnitPow u p)                 (UnitPow u' p')               = unitParamEq u u' && p == p'+unitParamEq u1 u2 = u1 == u2 -type DebugInfo = [(Col, (FU.SrcSpan, String))]+-------------------------------------------------- +-- The annotation on the AST used for solving units. data UnitAnnotation a = UnitAnnotation {    prevAnnotation :: a,-   unitSpec       :: Maybe UnitStatement,+   unitSpec       :: Maybe P.UnitStatement,+   unitConstraint :: Maybe Constraint,    unitInfo       :: Maybe UnitInfo,    unitBlock      :: Maybe (F.Block (FA.Analysis (UnitAnnotation a))) }   deriving (Data, Typeable, Show) -dbgUnitAnnotation (UnitAnnotation _ x y z) =-  "{ unitSpec = " ++ show x ++ ", unitInfo = " ++ show y ++ ", unitBlock = " ++-     (case z of+dbgUnitAnnotation (UnitAnnotation _ s c i b) =+  "{ 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@@ -117,197 +144,23 @@    ++ "}"  mkUnitAnnotation :: a -> UnitAnnotation a-mkUnitAnnotation a = UnitAnnotation a Nothing Nothing Nothing--data UnitEnv = UnitEnv {-  _report              :: [String],-  _varColEnv           :: VarColEnv,-  _derivedUnitEnv      :: DerivedUnitEnv,-  _procedureEnv        :: ProcedureEnv,-  _calls               :: ProcedureEnv,-  _unitVarCats         :: [UnitVarCategory],-  _reorderedCols       :: [Int],-  _underdeterminedCols :: [Int],-  _linearSystem        :: LinearSystem,-  _debugInfo           :: DebugInfo,-  _tmpRowsAdded        :: [Int],-  _tmpColsAdded        :: [Int],-  _success             :: Bool,-  -- This part of the state is just for some evaluation metrics-  _evUnitsAdded        :: (Int, [String]),-  _evCriticals         :: [Int],-  _puname              :: Maybe F.ProgramUnitName,-  _hasDeclaration      :: [F.Name]-} deriving Show--emptyUnitEnv = UnitEnv { _report              = [],-                         _varColEnv          = [],-                         _derivedUnitEnv      = [],-                         _procedureEnv        = [],-                         _calls               = [],-                         _unitVarCats         = [Magic],-                         _reorderedCols       = [],-                         _underdeterminedCols = [],-                         _linearSystem        = (fromLists [[1]], [Unitful []]),-                         _debugInfo           = [],-                         _tmpRowsAdded        = [],-                         _tmpColsAdded        = [],-                         _success             = True,-                         ----                         _evUnitsAdded        = (0, []),-                         _evCriticals         = [],-                         _puname              = Nothing,-                         _hasDeclaration      = []-                       }--Data.Label.mkLabels [''UnitEnv]---- *******************---  Syntax transformers--unitMult :: UnitConstant -> UnitConstant -> UnitConstant-unitMult (Unitful us) (Unitful us') = Unitful (us ++ us')-unitMult (UnitlessC r) (Unitful us) = Unitful (map (\(n, u) -> (n, r * u)) us)-unitMult (Unitful us) (UnitlessC r) = Unitful (map (\(n, u) -> (n, u * r)) us)-unitMult (UnitlessC r) (UnitlessC r') = UnitlessC (r * r')--unitScalarMult :: Rational -> UnitConstant -> UnitConstant-unitScalarMult r (UnitlessC r') = UnitlessC (r * r')-unitScalarMult r (Unitful us)   = Unitful (map (\(n, u) -> (n, r * u)) us)--convertUnit :: UnitInfo -> State UnitEnv UnitConstant-convertUnit p@(Parametric {})    = error $ "Can't use parametric yet: " ++ show p-convertUnit p@(ParametricUse {}) = error $ "Can't use parameteric yet" ++ show p-convertUnit (UnitName u) = do-  denv <- gets derivedUnitEnv-  case lookup u denv of-    Just uc -> return uc-    Nothing -> do let u1 = Unitful [(u, 1)]-                  derivedUnitEnv << (u, u1)-                  return $ u1-convertUnit (Undetermined s) = return $ Unitful []-convertUnit UnitlessI        = return $ UnitlessC 1-convertUnit (UnitMul u1 u2)  = do-   u1' <- convertUnit u1-   u2' <- convertUnit u2-   return $ unitMult u1' u2'-convertUnit (UnitPow u r) = do-   u' <- convertUnit u-   return $ unitScalarMult (toRational r) u'+mkUnitAnnotation a = UnitAnnotation a Nothing Nothing Nothing Nothing --- Convert parser units to UnitInfo+-------------------------------------------------- -toUnitInfo :: UnitOfMeasure -> UnitInfo-toUnitInfo (UnitProduct u1 u2) =+-- | Convert parser units to UnitInfo+toUnitInfo :: P.UnitOfMeasure -> UnitInfo+toUnitInfo (P.UnitProduct u1 u2) =     UnitMul (toUnitInfo u1) (toUnitInfo u2)-toUnitInfo (UnitQuotient u1 u2) =+toUnitInfo (P.UnitQuotient u1 u2) =     UnitMul (toUnitInfo u1) (UnitPow (toUnitInfo u2) (-1))-toUnitInfo (UnitExponentiation u1 p) =+toUnitInfo (P.UnitExponentiation u1 p) =     UnitPow (toUnitInfo u1) (toDouble p)   where-    toDouble :: UnitPower -> Double-    toDouble (UnitPowerInteger i) = fromInteger i-    toDouble (UnitPowerRational x y) = fromRational (x % y)-toUnitInfo (UnitBasic str) =+    toDouble :: P.UnitPower -> Double+    toDouble (P.UnitPowerInteger i) = fromInteger i+    toDouble (P.UnitPowerRational x y) = fromRational (x % y)+toUnitInfo (P.UnitBasic str) =     UnitName str toUnitInfo (P.Unitless) =-    UnitlessI---- ******************--- Helpers---- Update a list state by consing-infix 2 <<-(<<) :: MonadState f m => Lens (->) f [o] -> o -> m ()-(<<) lens o = lens =. (o:)---- Update a list state by appending-infix 2 <<++-(<<++) lens o = lens =. (++ [o])----- *** Operations on unit environments-addCol :: UnitVarCategory -> State UnitEnv Int-addCol category =-  do (matrix, vector) <- gets linearSystem-     let m = ncols matrix + 1-     linearSystem =: (extendTo 0 0 m matrix, vector)-     unitVarCats <<++ category-     tmpColsAdded << m-     return m--addRow :: State UnitEnv Int-addRow = addRow' (Unitful [])--addRow' :: UnitConstant -> State UnitEnv Int-addRow' uc =-  do (matrix, vector) <- gets linearSystem-     let n = nrows matrix + 1-     linearSystem =: (extendTo 0 n 0 matrix, vector ++ [uc])-     tmpRowsAdded << n-     return n--liftUnitEnv :: (Matrix Rational -> Matrix Rational) -> UnitEnv -> UnitEnv-liftUnitEnv f = Data.Label.modify linearSystem $ \(matrix, vector) -> (f matrix, vector)--resetTemps :: State UnitEnv ()-resetTemps = do tmpRowsAdded =: []-                tmpColsAdded =: []------------------------------------------------- Lookup helpers--lookupCaseInsensitive :: String -> [(String, a)] -> Maybe a-lookupCaseInsensitive x m = let x' = map toUpper x in (find (\(k, v) -> (map toUpper k) == x') m) >>= (return . snd)--lookupWithoutSrcSpan :: F.Name -> [(VarBinder, a)] -> Maybe a-lookupWithoutSrcSpan v env = snd `fmap` find f env-  where-    f (VarBinder (w, _), _) = map toUpper w == v'-    v'   = map toUpper v--lookupWithSrcSpan :: F.Name -> FU.SrcSpan -> [(VarBinder, a)] -> Maybe a-lookupWithSrcSpan v s env = snd `fmap` find f env-  where-    f (VarBinder (w, t), _) = map toUpper w == v' && s == t-    v'   = map toUpper v-------------------------------------------------trim = filter $ \(unit, r) -> r /= 0--{- Treat 'UnitConstant's as numbers -}-instance Num UnitConstant where-  (Unitful u1) + (Unitful u2) = Unitful $ trim $ merge u1 u2-    where merge [] u2 = u2-          merge u1 [] = u1-          merge ((unit1, r1) : u1) ((unit2, r2) : u2)-            | unit1 == unit2 = (unit1, r1 + r2) : merge u1 u2-            | unit1 <  unit2 = (unit1, r1) : merge u1 ((unit2, r2) : u2)-            | otherwise      = (unit2, r2) : merge ((unit1, r1) : u1) u2-  (UnitlessC n1) + (UnitlessC n2) = UnitlessC (n1 + n2)-  (Unitful units) * (UnitlessC n) = Unitful $ trim [(unit, r * n) | (unit, r) <- units]-  (UnitlessC n) * (Unitful units) = Unitful $ trim [(unit, n * r) | (unit, r) <- units]-  (UnitlessC n1) * (UnitlessC n2) = UnitlessC (n1 * n2)-  negate (Unitful units) = Unitful [(unit, -r) | (unit, r) <- units]-  negate (UnitlessC n) = UnitlessC (-n)-  abs (Unitful units) = Unitful [(unit, abs r) | (unit, r) <- units]-  abs (UnitlessC n) = UnitlessC $ abs n-  signum (Unitful units) = Unitful [(unit, signum r) | (unit, r) <- units]-  signum (UnitlessC n) = UnitlessC $ signum n-  fromInteger = UnitlessC . fromInteger--{- Treat 'UnitConstant's as fractionals -}-instance Fractional UnitConstant where-  (Unitful units) / (UnitlessC n) = Unitful [(unit, r / n) | (unit, r) <- units]-  (UnitlessC n1) / (UnitlessC n2) = UnitlessC (n1 / n2)-  fromRational = UnitlessC . fromRational--data Consistency a = Ok a | Bad a Int (UnitConstant, [Rational]) deriving Show--efmap :: (a -> a) -> Consistency a -> Consistency a-efmap f (Ok x)      = Ok (f x)-efmap f (Bad x l msg) = Bad x l msg--ifDebug :: (?debug :: Bool, Monad m) => m a -> m ()-ifDebug e = if ?debug then e >> return () else return ()+    UnitlessLit

@@ -13,565 +13,299 @@    See the License for the specific language governing permissions and    limitations under the License. -}-{- -  Units of measure extension to Fortran--TODO:- * Deal with variable shadowing in "contained" functions.- * Better errors with line number info-+{-+  Units of measure extension to Fortran: backend -} - {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-} -module Camfort.Specification.Units.InferenceBackend where-+module Camfort.Specification.Units.InferenceBackend+  ( inconsistentConstraints, criticalVariables, inferVariables+  -- mainly for debugging and testing:+  , shiftTerms, flattenConstraints, flattenUnits, constraintsToMatrix, rref, isInconsistentRREF )+where -import qualified Data.Vector as V-import Data.Data-import Data.Char-import Data.Maybe-import Data.Function-import Data.Matrix-import Data.List-import Data.Matrix-import Data.Ratio-import Data.Generics.Uniplate.Operations-import Data.Label.Monadic hiding (modify)-import Control.Monad.State.Strict hiding (gets)+import Data.Tuple (swap)+import Data.Maybe (maybeToList)+import Data.List ((\\), findIndex, partition, sortBy, group)+import Data.Generics.Uniplate.Operations (rewrite) import Control.Monad--import qualified Language.Fortran.Util.Position as FU+import Control.Monad.State.Strict+import Control.Monad.ST+import Control.Arrow (first, second)+import qualified Data.Map as M+import qualified Data.Array as A -import Camfort.Analysis.Annotations hiding (Unitless)-import Camfort.Specification.Units.Debug+import Camfort.Analysis.Annotations import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.Solve-import Camfort.Specification.Units.Synthesis-import Camfort.Transformation.Syntax --- *************************************---   Gaussian Elimination (Main)------ *************************************---- TOOD : fortran_src implement pretty print-pprint _ = ""--{-| Print debug information for non-zero coefficients from the Gaussian matrix -}-debugInfoForNonZeros :: [Rational] -> State UnitEnv String-debugInfoForNonZeros row = do debugs <- gets debugInfo-                              let cSpots = concatMap (getInfo debugs) (zip [1..] row)-                              return $ if (cSpots == []) then "" else (" arising from \n" ++ cSpots)-                                  where-                                    getInfo debugs (n, 0) = ""-                                    getInfo debugs (n, r) =-                                         case lookup n debugs of-                                                        (Just (span, s)) -> "\t" ++ (showSrcSpan span) ++ " - " ++ s ++ "\n"-                                                        _                -> ""--{- | An attempt at getting some useful user information. Needs position information -}-errorMessage :: (?debug :: Bool) => Row -> UnitConstant -> [Rational] -> State UnitEnv String-errorMessage row unit rowCoeffs =- let ?num = 0 in-    do uvarEnv <- gets varColEnv-       debugs <- gets debugInfo-       let unitStr = pprintUnitConstant unit-       let varCols = map (+1) (findIndices (\n -> n /= 0) rowCoeffs)-       if varCols == [] then-           case unit of-             Unitful xs | length xs > 1 ->-                     do let xs' = map (\(v, r) -> (v, r * (-1))) (tail xs)-                        let uR = pprintUnitConstant (Unitful $ xs')-                        let uL = pprintUnitConstant (Unitful [head xs])-                        success =: False-                        conflictInfo <- debugInfoForNonZeros rowCoeffs-                        return $-                           let unitStrL = pprint uL-                               unitStrR = pprint uR-                               msg = "Conflict since " ++ unitStrL ++ " != " ++ unitStrR-                           in msg ++ conflictInfo-             {- A single unit with no variable column suggests an attempt to unify an unit-                with unitless -}-             Unitful xs | length xs == 1 ->-                          do let xs' = map (\(v, r) -> (v, r * (-1))) xs-                             let uL = pprintUnitConstant (Unitful xs')-                             let unitStrL = pprint uL-                             ifDebug debugGaussian-                             conflictInfo <- debugInfoForNonZeros rowCoeffs-                             return $ "Conflict since " ++ unitStrL ++ " != 1" ++ conflictInfo-             _ -> do debugGaussian-                     return "Sorry, I can't give a better error."-       else-           let varColsAndNames = zip varCols (lookupVarsByCols uvarEnv varCols)-               exprStr' = map (\(k,v) -> if (rowCoeffs !! (k - 1)) == 1-                                         then v-                                         else (showRational (rowCoeffs !! (k - 1))) ++ "*" ++ v) varColsAndNames-               exprStr = concat $ intersperse "*" exprStr'-               msg     = "Conflict arising from " ++ exprStr ++ " of unit " ++ unitStr-           in do conflictInfo <- debugInfoForNonZeros rowCoeffs-                 return $ msg ++ conflictInfo--reportInconsistency :: (?debug :: Bool) => LinearSystem -> [Int] -> State UnitEnv ()-reportInconsistency (m, v) ns = do-  uvarEnv <- gets varColEnv-  debugs <- gets debugInfo--  -- helper functions-  let srcLineCompare = compare `on` (fst . lineCol . (\(FU.SrcSpan l _) -> l) . fst)-  let nonZeroVectorIndices = V.toList . V.map (+1) . V.findIndices (/= 0)--  -- examine all row numbers given to us as the parameter-  vs <- fmap (sortBy srcLineCompare . concat) . forM ns $ \ n -> do-      -- find out column indices of interest in the row-      let colsOfInterest = nonZeroVectorIndices (getRow n m)--      -- for each index of interest in the row, see what other rows also use it-      vs <- forM colsOfInterest $ \ i -> do-        let rowsOfInterest = nub . (i:) . nonZeroVectorIndices $ getCol i m-        -- lookup debug info for those row indices of interest-        let colDebugs = mapMaybe (flip lookup debugs) $ rowsOfInterest-        -- also lookup VarBinder info for i and convert it to same format-        let vs = map (\ (VarBinder (v, s)) -> (s, v)) $ lookupVarBindersByCols uvarEnv [i]-        return $ vs ++ colDebugs--      -- flatten it out-      return (concat vs)--  report <<++ "Caused by at least one of the following terms:"-  forM_ (nub vs) $ \ (s1@(FU.SrcSpan l _), str) -> do-    unless (all (\ x -> isNumber x || x == '.' || x == '-') str) $-      report <<++ "line " ++ show (lineCol l) ++ ": " ++ str---extendConstraints :: [UnitConstant] -> State UnitEnv ()-extendConstraints units =-        do (matrix, vector) <- gets linearSystem-           let n = nrows matrix + 1-               m = ncols matrix + 1-           linearSystem =: case units of-                             [] -> do (extendTo 0 0 m matrix, vector)-                             _ -> (setElem 1 (n, m) $ extendTo 0 n m matrix, vector ++ [last units])-           tmpColsAdded << m-           tmpRowsAdded << n-           return ()--swapUnitVarCats x n xs = swapUnitVarCats' x n xs xs 1-swapUnitVarCats' x n [] ys c = []-swapUnitVarCats' x n (z:zs) ys c | c == x = (ys !! (n - 1)) : (swapUnitVarCats' x n zs ys (c + 1))-                                 | c == n = (ys !! (x - 1)) : (swapUnitVarCats' x n zs ys (c + 1))-                                 | otherwise = z : (swapUnitVarCats' x n zs ys (c + 1))--swapCols :: Int -> Int -> State UnitEnv ()-swapCols x n = do --report <<++ ("Pre swap - " ++ (show x) ++ " <-> " ++ (show n))-                  --debugGaussian-                  varColEnv   =. updateColInfo x n-                  procedureEnv =. updateColInfo x n-                  calls        =. updateColInfo x n-                  unitVarCats  =. swapUnitVarCats x n-                  linearSystem =. (\(m, v) -> (switchCols x n m, v))-                  debugInfo    =. map (updateColInfo x n)-                  tmpColsAdded =. map (updateColInfo x n)-                  --report <<++ "Post swap"-                  --debugGaussian-                  return ()--class UpdateColInfo t where-    updateColInfo :: Col -> Col -> t -> t--instance UpdateColInfo VarCol where-    updateColInfo x n (VarCol y) | y == x = VarCol n-                                       | y == n = VarCol x-                                       | otherwise = VarCol y--instance UpdateColInfo VarColEnv where-    updateColInfo _ _ [] = []-    updateColInfo x n ((v, (uv, uvs)):ys) = (v, (updateColInfo x n uv, map (updateColInfo x n) uvs)) : (updateColInfo x n ys)--instance UpdateColInfo Procedure where-    updateColInfo x n (Nothing, ps) = (Nothing, map (updateColInfo x n) ps)-    updateColInfo x n (Just p, ps) = (Just $ updateColInfo x n p, map (updateColInfo x n) ps)--instance UpdateColInfo ProcedureEnv where-    updateColInfo x n = map (\(s, p) -> (s, updateColInfo x n p))--instance UpdateColInfo (Int, a) where-    updateColInfo x n (y, s) | y == x = (n, s)-                             | y == n = (x, s)-                             | otherwise = (y, s)--instance UpdateColInfo Int where-    updateColInfo x n y | y == x = x-                        | y == n = n-                        | otherwise = y--{-| reorderVarCols puts any variable columns to the end of the Gaussian matrix (along with the associated information) -}-reorderVarCols :: State UnitEnv ()-reorderVarCols = do ucats <- gets unitVarCats-                    (matrix, _) <- gets linearSystem-                    reorderVarCols' (ncols matrix) 1-                   where   correctEnd :: Int -> State UnitEnv Int-                           correctEnd 0   = return 0-                           correctEnd end = do ucats <- gets unitVarCats-                                               case (ucats !! (end - 1)) of-                                                  Variable -> correctEnd (end - 1)-                                                  _        -> return $ end--                           reorderVarCols' :: Int -> Int -> State UnitEnv ()-                           reorderVarCols' end c | c >= end = return ()-                           reorderVarCols' end c = do ucats <- gets unitVarCats-                                                      case (ucats !! (c - 1)) of-                                                        Variable -> do end' <- correctEnd end-                                                                       swapCols end' c-                                                                       reorderVarCols' (end' - 1) (c+1)-                                                        _        -> reorderVarCols' end (c+1)--{-| reduceRows is a core part of the polymorphic unit checking for procedures.--   It is essentially an "optimisation" of the Gaussian matrix (not in the sense-   of performance), that elimiantes rows in the system such that there are as-   few variables as possible. Within a function, assuming everything is-   consistent, then this should generate a linear constraint between the-   parameters and the return as a single row in the matrix. This is then used by-   the interprocedural constraints to hookup call-sites with definitions (in a-   parametrically polymorphic way- i.e. lambda abstraction is polymorphic in its-   units, different to say ML).--}---reduceRows :: Col -> LinearSystem -> LinearSystem-reduceRows m (matrix, vector)-  | m > ncols matrix = (matrix, vector)-  | otherwise =-    case (find (\n -> matrix ! (n, m) /= 0) [1..nrows matrix]) of-      Just r1 ->-        case (find (\n -> matrix ! (n, m) /= 0) [(r1 + 1)..nrows matrix]) of-          Just r2 -> -- Found two rows with non-zero coeffecicients-                     -- in this column-            case (elimRow (matrix, vector) (Just r1) m r2) of-              -- Eliminate the row and cut the system down-              Ok (matrix', vector') -> reduceRows m (cutSystem r2 (matrix', vector'))-              Bad _ _ _             -> reduceRows (m+1) (matrix, vector)--          Nothing -> -- If there are no two rows with non-zero coeffecieints-                     -- in column m then move onto the next column-                     reduceRows (m+1) (matrix, vector)-      Nothing -> reduceRows (m+1) (matrix, vector)--solveSystemM :: (?solver :: Solver, ?debug :: Bool) => String -> State UnitEnv Bool-solveSystemM adjective = do-  system <- gets linearSystem-  ifDebug debugGaussian-  case (solveSystemH_Either system) of-    Right system' -> do-      linearSystem =: system'-      ifDebug (report <<++ "After solve")-      ifDebug (debugGaussian)-      return True-    Left ns       -> do-      report <<++ (adjective ++ " units of measure")-      reportInconsistency system ns-      return False-      -- linearSystem =: system'-      -- if (adjective `elem` ["inconsistent", "underdetermined"]) then-      --     do msg <- errorMessage row unit vars-      --        report <<++ msg-      --        return False-      -- else-      --     return False--checkUnderdeterminedM :: State UnitEnv ()-checkUnderdeterminedM = do ucats <- gets unitVarCats-                           system <- gets linearSystem-                           varenv  <- gets varColEnv-                           debugs  <- gets debugInfo-                           procenv <- gets procedureEnv--                           let badCols = checkUnderdetermined ucats system-                           uenv <- gets varColEnv-                           if not (null badCols) then-                               do let exprs = map (showExprLines ucats varenv procenv debugs) badCols-                                  let exprsL = concat $ intersperse "\n\t" exprs-                                  debugGaussian-                                  report <<++ "Underdetermined units of measure. Try adding units to: \n\t" ++ exprsL-                                  return ()-                           else return ()-                           underdeterminedCols =: badCols---checkUnderdetermined :: [UnitVarCategory] -> LinearSystem -> [Int]-checkUnderdetermined ucats system@(matrix, vector) =-  fixValue (propagateUnderdetermined matrix) $ checkUnderdetermined' ucats system 1--lookupVarsByColsFilterByArg :: Matrix Rational -> VarColEnv -> [UnitVarCategory] -> [Int] -> DebugInfo -> [String]-lookupVarsByColsFilterByArg matrix uenv ucats cols dbgs =-      mapMaybe (\j -> lookupEnv j uenv) cols-         where lookupEnv j [] = --Nothing-                                if (ucats !! (j - 1) == Temporary && (not (all (==0) (V.toList (getCol j matrix))))) then-                                     case (lookup j dbgs) of-                                       Just (srcSpan, info) -> Just ("[expr: " ++ (showSrcSpan srcSpan) ++ "@" ++ info ++ "]")-                                       Nothing              -> Nothing--                                else Nothing-               lookupEnv j ((VarBinder (v, _), (VarCol i, _)):uenv)-                                              | i == j    = if (j <= length ucats) then-                                                             case (ucats !! (j - 1)) of-                                                                Argument -> Nothing-                                                                _        -> if (all (==0) (V.toList (getCol j matrix)))-                                                                            then Nothing-                                                                            else Just v-                                                            else Nothing-                                              | otherwise = lookupEnv j uenv--firstNonZeroCoeff :: Matrix Rational -> [UnitVarCategory] -> Row -> Col-firstNonZeroCoeff matrix ucats row =-      case (V.findIndex (/= 0) (getRow row matrix)) of-                                  Nothing -> ncols matrix-                                  Just i  -> i + 1-{-    firstNonZeroCoeff' (V.toList $ getRow row matrix) 0-       where-                {-   -}-         firstNonZeroCoeff' []     n = n + 1-         firstNonZeroCoeff' (0:rs) n = firstNonZeroCoeff' rs (n+1)-         firstNonZeroCoeff' (r:rs) n = case (ucats !! n) of-                                         Literal -> firstNonZeroCoeff' rs (n + 1)-                                         _       -> n + 1-}------ debug string ("n = " ++ show n ++ " vc = " ++ (show (vector !! (n - 1))) ++ " ms = " ++ show ms ++ " rest = " ++ show rest) `D.trace`-checkUnderdetermined' :: [UnitVarCategory] -> LinearSystem -> Int -> [Int]-checkUnderdetermined' ucats system@(matrix, vector) n-  | n > nrows matrix = []-  | not ((drop 1 ms) == []) && vector !! (n - 1) /= Unitful [] = ms ++ rest-  | otherwise = rest-  where ms = filter significant [2 .. ncols matrix]-        significant m = matrix ! (n, m) /= 0 && ucats !! (m - 1) `notElem` [Literal False, Literal True, Argument, Temporary]-        rest = checkUnderdetermined' ucats system (n + 1)--propagateUnderdetermined :: Matrix Rational -> [Int] -> [Int]-propagateUnderdetermined matrix list =-    nub $ do m <- list-             n <- filter (\n -> matrix ! (n, m) /= 0) [1 .. nrows matrix]-             filter (\m -> matrix ! (n, m) /= 0) [1 .. ncols matrix]---- *************************************---   Intrinsic functions: information &---      setup functions for them.------ *************************************+import Numeric.LinearAlgebra (+    atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols,+    takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks,+    ident, flatten, lu, dispf+  )+import qualified Numeric.LinearAlgebra as H+import Numeric.LinearAlgebra.Devel (+    newMatrix, readMatrix, writeMatrix, runSTMatrix+  ) -intrinsicsDict :: (?assumeLiterals :: AssumeLiterals) => [(String, String -> State UnitEnv ())]-intrinsicsDict =-    map (\x -> (x, addPlain1ArgIntrinsic)) ["ABS", "ACHAR", "ADJUSTL", "ADJUSTR", "AIMAG", "AINT", "ANINT", "CEILING", "CONJG", "DBLE", "EPSILON", "FLOOR","FLOAT", "FRACTION", "HUGE", "IACHAR", "ICHAR", "INT", "IPARITY", "LOGICAL", "MAXEXPONENT", "MINEXPONENT",  "NEW_LINE", "NINT", "NORM2", "NOT", "NULL", "PARITY", "REAL", "RRSPACING", "SPACING", "SUM", "TINY", "TRANSPOSE", "TRIM"]+import qualified Debug.Trace as D - ++ map (\x -> (x, addPlain2ArgIntrinsic)) ["ALL", "ANY", "IALL", "IANY", "CHAR", "CMPLX", "DCOMPLX", "DIM", "HYPOT", "IAND", "IEOR", "IOR", "MAX", "MIN", "MAXVAL", "MINVAL","MODULO", "MOD"]+-------------------------------------------------- - ++ map (\x -> (x, addPlain1Arg1ExtraIntrinsic)) ["CSHIFT", "EOSHIFT", "IBCLR", "IBSET", "NEAREST", "PACK", "REPEAT", "RESHAPE", "SHIFTA", "SHIFTL", "SHIFTR", "SIGN"]+-- | Returns just the list of constraints that were identified as+-- being possible candidates for inconsistency, if there is a problem.+inconsistentConstraints :: Constraints -> Maybe Constraints+inconsistentConstraints [] = Nothing+inconsistentConstraints cons+  | null inconsists = Nothing+  | otherwise       = Just [ con | (con, i) <- zip cons [0..], i `elem` inconsists ]+  where+    (unsolvedM, inconsists, colA) = constraintsToMatrix cons - ++ map (\x -> (x, addPlain2Arg1ExtraIntrinsic)) ["DSHIFTL", "DSHIFTR", "ISHFT", "ISHFTC", "MERGE", "MERGE_BITS"]+-------------------------------------------------- - ++ map (\x -> (x, addProductIntrinsic)) ["DOT_PRODUCT", "DPROD", "MATMUL"]+-- | Identifies the variables that need to be annotated in order for+-- inference or checking to work.+criticalVariables :: Constraints -> [UnitInfo]+criticalVariables [] = []+criticalVariables cons = filter (not . isUnitName) $ map (colA A.!) criticalIndices+  where+    (unsolvedM, inconsists, colA) = constraintsToMatrix cons+    solvedM                       = rref unsolvedM+    uncriticalIndices             = concatMap (maybeToList . findIndex (/= 0)) $ H.toLists solvedM+    criticalIndices               = A.indices colA \\ uncriticalIndices+    isUnitName (UnitName _)       = True; isUnitName _ = False - ++ map (\x -> (x, addPowerIntrinsic)) ["SCALE", "SET_EXPONENT"]+-------------------------------------------------- - ++ map (\x -> (x, addUnitlessIntrinsic)) ["ACOS", "ACOSH", "ASIN", "ASINH", "ATAN", "ATANH", "BESSEL_J0", "BESSEL_J1", "BESSEL_Y0", "BESSEL_Y1", "COS", "COSH", "ERF", "ERFC", "ERFC_SCALED", "EXP", "EXPONENT", "GAMMA", "LOG", "ALOG", "LOG10", "LOG_GAMMA", "PRODUCT", "SIN", "SINH", "TAN", "TANH"]+-- | Returns list of formerly-undetermined variables and their units.+inferVariables :: Constraints -> [(String, UnitInfo)]+inferVariables [] = []+inferVariables cons+  | null inconsists = [ (var, if null units then UnitlessVar else foldl1 UnitMul units)+                      | ([UnitPow (UnitVar var) k], units) <- map (partition (not . isUnitName)) unitPows+                      , k `approxEq` 1 ]+  | otherwise       = []+  where+    (unsolvedM, inconsists, colA)       = constraintsToMatrix cons+    solvedM                             = rref unsolvedM+    cols                                = A.elems colA+    unitPows                            = map (concatMap flattenUnits . zipWith UnitPow cols) (H.toLists solvedM)+    isUnitName (UnitPow (UnitName _) _) = True; isUnitName _ = False - ++ map (\x -> (x, addUnitlessSubIntrinsic)) ["CPU_TIME", "RANDOM_NUMBER"]+-------------------------------------------------- - ++ map (\x -> (x, addUnitlessResult0ArgIntrinsic)) ["COMMAND_ARGUMENT_COUNT", "COMPILER_OPTIONS", "COMPILER_VERSION"]+simplifyConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2)) - ++ map (\x -> (x, addUnitlessResult1ArgIntrinsic)) ["ALLOCATED", "ASSOCIATED", "BIT_SIZE", "COUNT", "DIGITS",  "IS_IOSTAT_END", "IS_IOSTAT_EOR", "KIND", "LBOUND", "LCOBOUND", "LEADZ", "LEN", "LEN_TRIM", "MASKL", "MASKR", "MAXLOC", "MINLOC", "POPCOUNT", "POPPAR", "PRECISION", "PRESENT", "RADIX", "RANGE", "SELECTED_CHAR_KIND", "SELECTED_INT_KIND", "SELECTED_REAL_KIND", "SHAPE", "SIZE", "STORAGE_SIZE", "TRAILZ", "UBOUND", "UCOBOUND"]+simplifyUnits :: UnitInfo -> UnitInfo+simplifyUnits = rewrite rw+  where+    rw (UnitMul (UnitMul u1 u2) u3)                          = Just $ UnitMul u1 (UnitMul u2 u3)+    rw (UnitMul u1 u2) | u1 == u2                            = Just $ UnitPow u1 2+    rw (UnitPow (UnitPow u1 p1) p2)                          = Just $ UnitPow u1 (p1 * p2)+    rw (UnitMul (UnitPow u1 p1) (UnitPow u2 p2)) | u1 == u2  = Just $ UnitPow u1 (p1 + p2)+    rw (UnitPow _ p) | p `approxEq` 0                        = Just UnitlessLit+    rw (UnitMul UnitlessLit u)                               = Just u+    rw (UnitMul u UnitlessLit)                               = Just u+    rw u                                                     = Nothing - ++ map (\x -> (x, addUnitlessResult2SameArgIntrinsic)) ["ATAN2", "BGE", "BGT", "BLE", "BLT", "INDEX", "LGE", "LGT", "LLE", "LLT", "SCAN", "VERIFY"]+flattenUnits :: UnitInfo -> [UnitInfo]+flattenUnits = map (uncurry UnitPow) . M.toList+             . M.filterWithKey (\ u _ -> u /= UnitlessLit)+             . M.filter (not . approxEq 0)+             . M.fromListWith (+)+             . map (first simplifyUnits)+             . flatten+  where+    flatten (UnitMul u1 u2) = flatten u1 ++ flatten u2+    flatten (UnitPow u p)   = map (second (p*)) $ flatten u+    flatten u               = [(u, 1)] - ++ map (\x -> (x, addUnitlessResult2AnyArgIntrinsic)) ["BTEST", "EXTENDS_TYPE_OF", "SAME_TYPE_AS"]+approxEq a b = abs (b - a) < epsilon+epsilon = 0.001 -- arbitrary -     -- missing: ATOMIC_DEFINE, ATOMIC_REF, BESSEL_JN, BESSEL_YN, C_*, DATE_AND_TIME, EXECUTE_COMMAND_LINE, GET_COMMAND, GET_COMMAND_ARGUMENT, GET_ENVIRONMENT_VARIABLE, IBITS, any of the image stuff, MOVE_ALLOC, MVBITS, RANDOM_SEED, SPREAD, SYSTEM_CLOCK, TRANSFER, UNPACK+-------------------------------------------------- +-- Convert a set of constraints into a matrix of co-efficients, and a+-- reverse mapping of column numbers to units.+constraintsToMatrix :: Constraints -> (H.Matrix Double, [Int], A.Array Int UnitInfo)+constraintsToMatrix cons = (augM, inconsists, A.listArray (0, length colElems - 1) colElems)+  where+    -- convert each constraint into the form (lhs, rhs)+    consPairs       = flattenConstraints cons+    -- ensure terms are on the correct side of the equal sign+    shiftedCons     = map shiftTerms consPairs+    lhs             = map fst shiftedCons+    rhs             = map snd shiftedCons+    (lhsM, lhsCols) = flattenedToMatrix lhs+    (rhsM, rhsCols) = flattenedToMatrix rhs+    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 -{- [A] Various helpers for adding information about procedures to the type system -}+-- [[UnitInfo]] is a list of flattened constraints+flattenedToMatrix :: [[UnitInfo]] -> (H.Matrix Double, A.Array Int UnitInfo)+flattenedToMatrix cons = (m, A.array (0, numCols - 1) (map swap uniqUnits))+  where+    m = runSTMatrix $ do+          m <- newMatrix 0 numRows numCols+          -- loop through all constraints+          forM_ (zip cons [0..]) $ \ (unitPows, row) -> do+            -- write co-efficients for the lhs of the constraint+            forM_ unitPows $ \ (UnitPow u k) -> do+              case M.lookup u colMap of+                Just col -> readMatrix m row col >>= (writeMatrix m row col . (+k))+                _        -> return ()+          return m+    -- identify and enumerate every unit uniquely+    uniqUnits = flip zip [0..] . map head . group . sortBy colSort $ [ u | UnitPow u _ <- concat cons ]+    -- map units to their unique column number+    colMap    = M.fromList uniqUnits+    numRows   = length cons+    numCols   = M.size colMap -addPlain1ArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addPlain1ArgIntrinsic name =-  do result <- anyUnits Variable-     arg    <- anyUnits Argument-     mustEqual False result arg-     procedureEnv << (name, (Just result, [arg]))+negateCons = map (\ (UnitPow u k) -> UnitPow u (-k)) -addPlain2ArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addPlain2ArgIntrinsic name =-  do result <- anyUnits Variable-     arg1  <- anyUnits Argument-     arg2  <- anyUnits Argument-     mustEqual False result arg1-     mustEqual False result arg2-     procedureEnv << (name, (Just result, [arg1, arg2]))+colSort (UnitLiteral i) (UnitLiteral j) = compare i j+colSort (UnitLiteral _) _               = LT+colSort _ (UnitLiteral _)               = GT+colSort x y                             = compare x y -addPlain1Arg1ExtraIntrinsic :: (?assumeLiterals :: AssumeLiterals) =>  String -> State UnitEnv ()-addPlain1Arg1ExtraIntrinsic name =-  do result <- anyUnits Variable-     arg1   <- anyUnits Argument-     arg2   <- anyUnits Argument-     mustEqual False result arg1-     procedureEnv << (name, (Just result, [arg1, arg2]))+-------------------------------------------------- -addPlain2Arg1ExtraIntrinsic :: (?assumeLiterals :: AssumeLiterals) =>  String -> State UnitEnv ()-addPlain2Arg1ExtraIntrinsic name =-  do result <- anyUnits Variable-     arg1   <- anyUnits Argument-     arg2   <- anyUnits Argument-     arg3   <- anyUnits Argument-     mustEqual False result arg1-     mustEqual False result arg2-     procedureEnv << (name, (Just result, [arg1, arg2, arg3]))+-- | Translate all constraints into a LHS, RHS side of units.+flattenConstraints :: Constraints -> [([UnitInfo], [UnitInfo])]+flattenConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2)) -addProductIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addProductIntrinsic name =-  do result <- anyUnits Variable-     arg1   <- anyUnits Argument-     arg2   <- anyUnits Argument-     temp   <- mustAddUp arg1 arg2 1 1-     mustEqual False result temp-     procedureEnv << (name, (Just result, [arg1, arg2]))+-- | Shift UnitNames to the RHS, and all else to the LHS.+shiftTerms :: ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo])+shiftTerms (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift)+  where+    (lhsOk, lhsShift) = partition (not . isUnitName) lhs+    (rhsOk, rhsShift) = partition isUnitName rhs+    isUnitName (UnitPow (UnitName _) _) = True; isUnitName _ = False -addPowerIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addPowerIntrinsic name =-  do result <- anyUnits Variable-     arg1   <- anyUnits Argument-     arg2   <- anyUnits Argument-     mustEqual False result arg1-     mustEqual False arg2 (VarCol 1)-     procedureEnv << (name, (Just result, [arg1, arg2]))+--------------------------------------------------+-- Matrix solving functions based on HMatrix -addUnitlessIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addUnitlessIntrinsic name =-  do result <- anyUnits Variable-     arg    <- anyUnits Argument-     mustEqual False result (VarCol 1)-     mustEqual False arg (VarCol 1)-     procedureEnv << (name, (Just result, [arg]))+-- | Returns True iff the given matrix in reduced row echelon form+-- represents an inconsistent system of linear equations+isInconsistentRREF a = a @@> (rows a - 1, cols a - 1) == 1 && rank (takeColumns (cols a - 1) (dropRows (rows a - 1) a))== 0 -addUnitlessSubIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addUnitlessSubIntrinsic name =-  do arg <- anyUnits Variable-     mustEqual False arg (VarCol 1)-     procedureEnv << (name, (Nothing, [arg]))+-- | Returns given matrix transformed into Reduced Row Echelon Form+rref :: H.Matrix Double -> H.Matrix Double+rref a = snd $ rrefMatrices' a 0 0 [] -addUnitlessResult0ArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addUnitlessResult0ArgIntrinsic name =-  do result <- anyUnits Variable-     mustEqual False result (VarCol 1)-     procedureEnv << (name, (Just result, []))+-- | 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 [] -addUnitlessResult1ArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addUnitlessResult1ArgIntrinsic name =-  do result <- anyUnits Variable-     arg <- anyUnits Argument-     mustEqual False result (VarCol 1)-     procedureEnv << (name, (Just result, [arg]))+-- | 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 [] -addUnitlessResult2AnyArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addUnitlessResult2AnyArgIntrinsic name =-  do result <- anyUnits Variable-     arg1   <- anyUnits Argument-     arg2   <- anyUnits Argument-     mustEqual False result (VarCol 1)-     procedureEnv << (name, (Just result, [arg1, arg2]))+-- worker function+-- invariant: the matrix a is in rref except within the submatrix (j-k,j) to (n,n)+rrefMatrices' a j k mats+  -- Base cases:+  | j - k == n            = (mats, a)+  | j     == m            = (mats, a) -addUnitlessResult2SameArgIntrinsic :: (?assumeLiterals :: AssumeLiterals) => String -> State UnitEnv ()-addUnitlessResult2SameArgIntrinsic name =-  do result <- anyUnits Variable-     arg1   <- anyUnits Argument-     arg2   <- anyUnits Argument-     mustEqual False result (VarCol 1)-     mustEqual False arg1 arg2-     procedureEnv << (name, (Just result, [arg1, arg2]))+  -- When we haven't yet found the first non-zero number in the row, but we really need one:+  | a @@> (j - k, j) == 0 = case findIndex (/= 0) below of+    -- this column is all 0s below current row, must move onto the next column+    Nothing -> rrefMatrices' a (j + 1) (k + 1) mats+    -- we've found a row that has a non-zero element that can be swapped into this row+    Just i' -> rrefMatrices' (swapMat <> a) j k (swapMat:mats)+      where i       = j - k + i'+            swapMat = elemRowSwap n i (j - k) --- *************************************---   Unit inferences (Helpers)------ *************************************+  -- We have found a non-zero cell at (j - k, j), so transform it into+  -- a 1 if needed using elemRowMult, and then clear out any lingering+  -- non-zero values that might appear in the same column, using+  -- elemRowAdd:+  | otherwise             = rrefMatrices' a2 (j + 1) k mats2+  where+    n     = rows a+    m     = cols a+    below = getColumnBelow a (j - k, j) --- mustEqual - used for saying that two units must be the same- returns one of the variables---             (choice doesn't matter, but left is chosen).---             Returns the unit variables equaled upon-mustEqual :: (?assumeLiterals :: AssumeLiterals)-          => Bool -> VarCol -> VarCol -> State UnitEnv VarCol-mustEqual flagAsUnitlessIfLit (VarCol uv1) (VarCol uv2) =-  do n <- addRow-     modify $ liftUnitEnv $ incrElem (-1) (n, uv1) . incrElem 1 (n, uv2)-     ucats <- gets unitVarCats-     if flagAsUnitlessIfLit then-       case ?assumeLiterals of-         Mixed -> unitVarCats =: (map (\(n, cat) -> if ((n == uv1 || n == uv2) && ((cat == Literal True) || (cat == Literal False)))-                                                    then Literal True-                                                    else cat)  (zip [1..] ucats))-         _     -> return ()-      else return ()-     return $ VarCol uv1+    -- scale the row if the cell is not already equal to 1+    erm    = elemRowMult n (j - k) (recip (a @@> (j - k, j)))+    (a1, mats1) = if a @@> (j - k, j) /= 1 then+                    (erm <> a, erm:mats)+                  else (a, mats) --- mustAddUp - used for multipling and dividing. Creates a new 'temporary' column and returns---             the variable associated with it-mustAddUp :: VarCol -> VarCol -> Rational -> Rational -> State UnitEnv VarCol-mustAddUp (VarCol uv1) (VarCol uv2) k1 k2 =-  do m <- addCol Temporary-     n <- addRow-     modify $ liftUnitEnv $ incrElem (-1) (n, m) . incrElem k1 (n, uv1) . incrElem k2 (n, uv2)-     return $ VarCol m+    -- Locate any non-zero values in the same column as (j - k, j) and+    -- cancel them out. Optimisation: instead of constructing a+    -- 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 = (new <> m, new:ms)+      where+        new = runSTMatrix $ do+          new <- newMatrix 0 n n+          sequence [ writeMatrix new i' i' 1 | i' <- [0 .. (n - 1)] ]+          let f i | i >= n            = return ()+                  | i == j - k        = f (i + 1)+                  | a @@> (i, j) == 0 = f (i + 1)+                  | otherwise         = writeMatrix new i (j - k) (- (a @@> (i, j)))+                                        >> f (i + 1)+          f 0+          return new+    (a2, mats2) = findAdds 0 a1 mats1 +-- Get a list of values that occur below (i, j) in the matrix a.+getColumnBelow a (i, j) = concat . H.toLists $ subMatrix (i, j) (n - i, 1) a+  where n = rows a -sqrtUnits :: VarCol -> State UnitEnv VarCol-sqrtUnits (VarCol uv) =-  do m <- addCol Temporary-     n <- addRow-     modify $ liftUnitEnv $ incrElem (-1) (n, m) . incrElem 0.5 (n, uv)-     return $ VarCol m+-- 'Elementary row operation' matrices+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)) -anyUnits :: UnitVarCategory -> State UnitEnv VarCol-anyUnits category =-  do m <- addCol category-     return $ VarCol m+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 --- *************************************---    Matrix operations------ *************************************+elemRowSwap :: Int -> Int -> Int -> H.Matrix Double+elemRowSwap n i j+  | i == j          = ident n+  | i > j           = elemRowSwap n j i+  | otherwise       = extractRows ([0..i-1] ++ [j] ++ [i+1..j-1] ++ [i] ++ [j+1..n-1]) $ ident n  -inverse :: [Int] -> [Int]-inverse perm = [j + 1 | Just j <- map (flip elemIndex perm) [1 .. length perm]]+-------------------------------------------------- -fixValue :: Eq a => (a -> a) -> a -> a-fixValue f x = snd $ until (uncurry (==)) (\(x, y) -> (y, f y)) (x, f x)+-- Worker functions: --- The indexing for switchScaleElems and moveElem is 1-based, in line with Data.Matrix.+toDouble :: Rational -> Double+toDouble = fromRational +fromDouble :: Double -> Rational+fromDouble = toRational -moveElem :: Int -> Int -> [a] -> [a]-moveElem i j []             = []-moveElem i j xs | i > j     = moveElem j i xs-                 | otherwise = moveElemA i j xs Nothing-                                where moveElemA i    j []     (Just z) = [z]-                                      moveElemA i    j []     Nothing  = []-                                      moveElemA 1    j (x:xs) (Just z) = x : moveElemA 1 (j - 1) xs (Just z)-                                      moveElemA 1    j (x:xs) Nothing  = moveElemA 1 j xs (Just x)-                                      moveElemA i    j (x:xs) Nothing  = x : moveElemA (i - 1) j xs Nothing+findInconsistentRows :: H.Matrix Double -> H.Matrix Double -> [Int]+findInconsistentRows coA augA = [0..(rows augA - 1)] \\ consistent+  where+    consistent = head (filter (tryRows coA augA) (pset ( [0..(rows augA - 1)])) ++ [[]]) +    -- Rouché–Capelli theorem is that if the rank of the coefficient+    -- matrix is not equal to the rank of the augmented matrix then+    -- the system of linear equations is inconsistent.+    tryRows coA augA ns = (rank coA' == rank augA')+      where+        coA'  = extractRows ns coA+        augA' = extractRows ns augA -incrElem :: Num a => a -> (Int, Int) -> Matrix a -> Matrix a-incrElem value pos matrix = setElem (matrix ! pos + value) pos matrix+    pset = filterM (const [True, False]) -moveCol :: Int -> Int -> Matrix a -> Matrix a-moveCol i j m-    | i > j = moveCol j i m-    | otherwise = matrix (nrows m) (ncols m)-                     $ \(r, c) -> if (c < i || c > j)       then m ! (r, c)-                                  else if (c >= i && c < j) then m ! (r, c+1)-                                       else                      m ! (r, i)+extractRows = flip (?) -- hmatrix 0.17 changed interface+m @@> i = m `atIndex` i

@@ -13,662 +13,642 @@    See the License for the specific language governing permissions and    limitations under the License. -}-{---  Units of measure extension to Fortran--TODO:- * Deal with variable shadowing in "contained" functions.- * Better errors with line number info---}---{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE DoAndIfThenElse #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}--module Camfort.Specification.Units.InferenceFrontend (doInferUnits) where--import Data.Data-import Data.Char-import Data.Function-import Data.List-import Data.Matrix-import qualified Data.Map as M-import Data.Maybe-import Data.Ratio-import Data.Generics.Uniplate.Operations-import Data.Label.Monadic hiding (modify)-import Control.Monad.State.Strict hiding (gets)-import Control.Monad-import Control.Monad.Writer.Strict-import GHC.Prim--import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Types as FAT-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-import qualified Language.Fortran.Util.SecondParameter as FUS--import Camfort.Analysis.CommentAnnotator-import Camfort.Analysis.Annotations hiding (Unitless)-import Camfort.Analysis.Types-import Camfort.Specification.Units.Debug-import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.InferenceBackend-import Camfort.Specification.Units.Solve-import qualified Camfort.Specification.Units.Parser as Parser-import Camfort.Transformation.Syntax--import qualified Debug.Trace as D--type A1 = FA.Analysis (UnitAnnotation A)-type Params = (?criticals      :: Bool,-               ?solver         :: Solver,-               ?debug          :: Bool,-               ?assumeLiterals :: AssumeLiterals,-               ?nameMap        :: FAR.NameMap,-               ?argumentDecls  :: Bool)--realName :: (?nameMap :: FAR.NameMap) => F.Name -> F.Name-realName v = v `fromMaybe` (v `M.lookup` ?nameMap)-plumb f x = do { f x ; return x }---- Helper for transforming the 'previous' annotation-onPrev :: (a -> a) -> FA.Analysis a -> FA.Analysis a-onPrev f ann = ann { FA.prevAnnotation = f (FA.prevAnnotation ann) }---- Instances for embedding parsed specifications into the AST-instance ASTEmbeddable A1 Parser.UnitStatement where-  annotateWithAST ann ast =-    onPrev (\ann -> ann { unitSpec = Just ast }) ann---- Link annotaiton comments to declaration statements-instance Linkable A1 where-  link ann (b@(F.BlStatement _ _ _ (F.StDeclaration {}))) =-      onPrev (\ann -> ann { unitBlock = Just b }) ann-  link ann b = ann---- Core procedure for inferring units-doInferUnits ::-    Params => F.ProgramFile A1-           -> State UnitEnv ()-doInferUnits pf = do-    (pf', parserReport) <- return $ runWriter (annotateComments Parser.unitParser pf)-    report <<++ (intercalate "\n" parserReport)-    let ?argumentDecls = False in descendBiM perProgramUnit pf'-    ---    ifDebug (report <<++ "Finished inferring prog units")-    ifDebug debugGaussian-    ---    inferInterproceduralUnits pf'-    return ()---- ***************************************------ *  Unit inference (main, over all AST)------ ***************************************---- Check units per program unit, with special handling of functions and subroutines--- which need adding to the set of constraints-perProgramUnit :: Params-    => F.ProgramUnit A1-    -> State UnitEnv (F.ProgramUnit A1)-perProgramUnit p@(F.PUMain _ _ _ body subprogs) = do-    resetTemps-    descendBiM perBlock body-    descendBiM perProgramUnit subprogs-    return p--perProgramUnit p@(F.PUModule _ _ _ body subprogs) = do-    resetTemps-    puname =: (Just $ FA.puName p)-    descendBiM perBlock p-    descendBiM perProgramUnit subprogs-    return p--perProgramUnit p@(F.PUSubroutine ann span rec name args body subprogs) = do-    resetTemps-    addProcedure rec name Nothing args body span-    descendBiM perProgramUnit subprogs-    return p--perProgramUnit p@(F.PUFunction ann span retTy rec name args result-                                                     body subprogs) = do-    resetTemps-    addProcedure rec name (Just name) args body span-    descendBiM perProgramUnit subprogs-    return p--perProgramUnit p = do-    resetTemps-    descendBiM perBlock p-    return p--addProcedure :: Params-    => Bool -- Recursive or not-    -> F.Name-    -> Maybe F.Name -- Maybe return name-    -> (Maybe (F.AList F.Expression A1)) -- Arguments-    -> [F.Block A1] -- Body-    -> FU.SrcSpan-    -> State UnitEnv ()-addProcedure rec name rname args body span = do-    -- Do just the declarations first-    let ?argumentDecls = True in mapM_ perStatement [s | s@(F.StDeclaration {}) <- universeBi body :: [F.Statement A1]]-    --descendBiM perBlock body-    uenv <- gets varColEnv-    resultVar <- case rname of-                   Just rname ->-                     case (lookupWithoutSrcSpanRealName rname uenv) of-                        Just (uvar, _) -> return $ Just uvar-                        Nothing        -> do m <- addCol Variable-                                             varColEnv << (VarBinder (rname, span), (VarCol m, []))-                                             return $ (Just (VarCol m))-                   Nothing -> return Nothing--    let argVars = fromMaybe [] (fmap (map (lookupUnitByName uenv) . F.aStrip) args)--    procedureEnv << (name, (resultVar, argVars))-    descendBiM perBlock body-    if rec-      then do descendBiM perBlock body-              return ()-      else return ()-    -- Intermediate solve for procedures (subroutines & functions)-    ifDebug (report <<++ "Pre doing row reduce")-    consistent <- solveSystemM ""-    success =: consistent--    linearSystem =. reduceRows 1-    ifDebug (report <<++ "Post doing reduce")-    ifDebug (debugGaussian)-    return ()-  where-    lookupUnitByName uenv ve@(F.ExpValue _ _ (F.ValVariable _)) =-        maybe (VarCol 1) fst $ lookupWithoutSrcSpan v uenv-          where v = FA.varName ve----- Check units per block-perBlock :: Params-         => F.Block A1-         -> State UnitEnv (F.Block A1)-perBlock b@(F.BlComment ann span _) = do-    case (unitSpec (FA.prevAnnotation ann), unitBlock (FA.prevAnnotation ann)) of-      -- Found a unit comment associated to a block-      (Just (Parser.UnitAssignment (Just vars) unitsAST), Just block) -> do-         let units = toUnitInfo unitsAST-         unitsConverted <- convertUnit units-         case block of-              bl@(F.BlStatement ann span _ (F.StDeclaration _ _ _ _ decls)) ->-                flip mapM_ vars (\var ->-                  mapM_ (processVar' (Just var) [unitsConverted]) (getNamesAndInits decls))-              _ -> return ()-      -- Found a derived unit declaration-      (Just (Parser.UnitAlias name unitsAST), _) -> do-         let unitInfo = toUnitInfo unitsAST-         learnDerivedUnit (name, unitInfo)-      _ -> return ()-    return b--  where-    processVar' varReal unitC (var, init, span) = do-       if (Just (realName var) == varReal) then hasDeclaration <<++ var else return ()-       processVar varReal unitC (var, init, span)-    learnDerivedUnit (name, spec) =-          do denv <- gets derivedUnitEnv-             when (isJust $ lookup name denv) $ error "Redeclared unit of measure"-             unit <- convertUnit spec-             denv <- gets derivedUnitEnv-             when (isJust $ lookup name denv) $ error "Recursive unit-of-measure definition"-             derivedUnitEnv << (name, unit)-    -- Note we get the real names here since we are working with a user-specified-    -- variable which is associated to this decl-    getNamesAndInits x =-        [(FA.varName e, i, s) | (F.DeclVariable _ _ e@(F.ExpValue _ s (F.ValVariable v)) _ i) <--                    (universeBi (F.aStrip x) :: [F.Declarator A1])]-     ++ [(FA.varName e, i, s) | (F.DeclArray _ _ e@(F.ExpValue _ s (F.ValVariable v)) _ _ i) <--                    (universeBi (F.aStrip x) :: [F.Declarator A1])]-     -- TODO: generate constraints for indices-    dimDeclarators x = concat-         [F.aStrip dims | (F.DeclArray _ _ _ dims _ _) <--                    (universeBi (F.aStrip x) :: [F.Declarator A1])]--{- TODO: investigate-    unitVarCat :: Variable -> Maybe ProcedureNames -> UnitVarCategory-    unitVarCat v proc | Just (n, r, args) <- proc, v `elem` args = Argument-                  | otherwise                                = Variable--}--perBlock b@(F.BlStatement _ _ _ s) = do-    perStatement s-    return b--perBlock b = do-    mapM_ perDoSpecification (universeBi b)-    mapM_ perExpr (universeBi b)-    descendBiM (plumb perBlock) b-    return b--processVar :: Params-           => Maybe F.Name-           -> [UnitConstant]-           -> (F.Name, Maybe (F.Expression A1), FU.SrcSpan)-           -> State UnitEnv ()-processVar (Just dvar) units (v, initExpr, span) | dvar == (realName v) = do-      system <- gets linearSystem-      let m = ncols (fst system) + 1-      unitVarCats <<++ (if ?argumentDecls then Argument else Variable) -- TODO: check how much we need this: (unitVarCat v proc)-      extendConstraints units-      varColEnv << (VarBinder (v, span), (VarCol m, []))-      uv <- gets varColEnv-      -- If the declaration has a null expression, do not create a unifying variable-      case initExpr of-          Nothing -> return ()-          Just e  -> do-            uv <- perExpr e-            mustEqual False (VarCol m) uv-            return ()-processVar dvar units (v, initExpr, span) | otherwise = return ()----- Do specifications (e.g. i = 1, n, s) enforces an equality constraint on the--- units between each component (all must have the same unit)-perDoSpecification ::-     Params-  => F.DoSpecification A1 -> State UnitEnv ()-perDoSpecification (F.DoSpecification _ _-                      st@(F.StExpressionAssign _ _ ei e0) en step) = do-   uiv <- perExpr ei-   e0v <- perExpr e0-   env <- perExpr en-   mustEqual True uiv e0v-   mustEqual True e0v env-   case step of-     Nothing    -> return ()-     Just stepE -> do stepv <- perExpr stepE-                      mustEqual True env stepv-                      return ()---- TODO: see if we need to insert anymore statement-specific constraints here-perStatement ::-     Params-   => F.Statement A1 -> State UnitEnv ()-perStatement (F.StDeclaration _ span spec atr decls) = do-    uenv <- gets varColEnv-    mapM_ (\(v, i, s) -> if notAlreadyDeclared uenv v-                           then processVar (Just (realName v)) [] (v, i, s)-                           else return ())  (getNamesAndInits decls)-  where-    -- Variable may have been declared already due to link with comment-    notAlreadyDeclared uenv v =-      case lookupWithoutSrcSpan v uenv of-        Nothing -> True-        Just _  -> False--    getNamesAndInits x =-        [(FA.varName e, i, s) |-           (F.DeclVariable _ _ e@(F.ExpValue _ s (F.ValVariable _)) _ i)-              <- (universeBi (F.aStrip x) :: [F.Declarator A1])]-     ++ [(FA.varName e, i, s) |-           (F.DeclArray _ _ e@(F.ExpValue _ s (F.ValVariable _)) _ _ i)-              <- (universeBi (F.aStrip x) :: [F.Declarator A1])]--perStatement (F.StExpressionAssign _ span e1 e2) = do-    uv1 <- perExpr e1-    uv2 <- perExpr e2-    mustEqual False uv1 uv2-    return ()--perStatement (F.StPointerAssign _ _ e1 e2) = do-    uv1 <- perExpr e1-    uv2 <- perExpr e2-    mustEqual False uv1 uv2-    return ()--perStatement (F.StCall _ _ e@(F.ExpValue _ _ (F.ValVariable vReal)) args) = do-    uvs <- fromMaybe (return []) (fmap (mapM perArgument . F.aStrip) args)-    case (lookup (map toUpper vReal) intrinsicsDict) of-       Just fun -> fun vReal-       Nothing  -> return ()-    uv@(VarCol uvn) <- anyUnits Temporary-    --uvs <- inferArgUnits-    --let uvs' = justArgUnits args uvs-    calls << (vReal, (Just uv, uvs))---perStatement s = do-    mapM_ perDoSpecification (universeBi s)-    descendBiM (plumb perExpr) s-    return ()---inferInterproceduralUnits ::-    Params => F.ProgramFile A1 -> State UnitEnv ()-inferInterproceduralUnits x =-  do --reorderColumns-     if ?criticals then reorderVarCols else return ()-     consistent <- solveSystemM "inconsistent"-     if consistent then-         do system <- gets linearSystem-            let dontAssumeLiterals = case ?assumeLiterals of-                                       Poly     -> True-                                       Unitless -> False-                                       Mixed    -> False-            inferInterproceduralUnits' x dontAssumeLiterals system -- edited-            return ()-     else-         return ()--inferInterproceduralUnits' ::-    Params => F.ProgramFile A1 -> Bool -> LinearSystem-           -> State UnitEnv (F.ProgramFile A1)-inferInterproceduralUnits' x haveAssumedLiterals system1 =-  do addInterproceduralConstraints x-     consistent <- solveSystemM "inconsistent"-     if not consistent then-          do  linearSystem =: system1-              return x-      else do-        system2 <- gets linearSystem-        if system1 == system2-          then if ?criticals then nextStep else checkUnderdeterminedM >> nextStep-          else inferInterproceduralUnits' x haveAssumedLiterals system2-  where nextStep | haveAssumedLiterals = return x-                 | otherwise           = do consistent <- assumeLiteralUnits-                                            if not consistent-                                             then return x-                                             else do system3 <- gets linearSystem-                                                     inferInterproceduralUnits' x True system3--assumeLiteralUnits :: (?solver :: Solver, ?debug :: Bool) => State UnitEnv Bool-assumeLiteralUnits =-  do system@(matrix, vector) <- gets linearSystem-     mapM_ assumeLiteralUnits' [1 .. ncols matrix]-     consistent <- solveSystemM "underdetermined"-     when (not consistent) $ linearSystem =: system-     return consistent--assumeLiteralUnits' m =-      do (matrix, vector) <- gets linearSystem-         ucats <- gets unitVarCats-         let n = find (\n -> matrix ! (n, m) /= 0) [1 .. nrows matrix]-             m' = n >>= (\n -> find (\m -> matrix ! (n, m) /= 0) [1 .. ncols matrix])-             nonLiteral n m = matrix ! (n, m) /= 0 && ucats !! (m - 1) /= (Literal True)-             m's = n >>= (\n -> find (nonLiteral n) [1 .. ncols matrix])-         when (ucats !! (m - 1) == (Literal True) && (m' /= Just m || isJust m's)) $ do-           n' <- addRow-           modify $ liftUnitEnv $ setElem 1 (n', m)--addInterproceduralConstraints ::-    (?debug :: Bool) => F.ProgramFile A1 -> State UnitEnv ()-addInterproceduralConstraints x =-  do-    cs <- gets calls-    penv <- gets procedureEnv-    mapM_ (addCall penv) cs-  where-    addCall penv (name, (result, args)) =-      do case lookup name penv of-           Just (r, as) -> let (r1, r2) = decodeResult result r-                           in handleArgs (args ++ r1) (as ++ r2)-           Nothing      -> return ()--    handleArgs actualVars dummyVars =-      do order <- gets reorderedCols-         let actual = map (\(VarCol uv) -> uv) actualVars-             dummy = map (\(VarCol uv) -> uv) dummyVars-         mapM_ (handleArg $ zip dummy actual) dummy--    -- experimentation but now deprecated.-{--    handleArgNew dummyToActual dummy =-        do grid0 <- debugGaussian'-           mapM (\(l, r) -> do n <- addRow-                               modify $ liftUnitEnv $ setElem 1 (n, l)-                               modify $ liftUnitEnv $ setElem (-1) (n, r)-                ) dummyToActual-           grid1 <- debugGaussian'-           if (grid0 == grid1) then-               return ()-           else-             do report <<++ "HANDLED AND DIFFERENT!"-                report <<++ ("\n" ++ grid0)-                report <<++ ("\n" ++ grid1)-                return ()-}--    -- TODO: this can be optimised-    handleArg dummyToActual dummy =-      do (matrix, vector) <- gets linearSystem-         --grid0 <- debugGaussian'-         ifDebug (debugGaussian)--         ifDebug (report <<++ ("hArg - " ++ show dummyToActual ++ "-" ++ show dummy))--         let -- find the first row with a non-zero column for the variable-             n = maybe 1 id $ find (\n -> matrix ! (n, dummy) /= 0) [1 .. nrows matrix]--             -- find the first non-zero column on the row just selected-             Just m = find (\m -> matrix ! (n, m) /= 0) [1 .. ncols matrix]--         ifDebug (report <<++ ("n = " ++ show n ++ ", m = " ++ show m))--         if (m == dummy) then-           do  let -- Get list of columns with non-zero coefficients to the right of the focus-                   ms = filter (\m -> matrix ! (n, m) /= 0) [m .. ncols matrix]--                   -- Get the list of columns to which the non-zero coeffecients-                   -- are paired by 'dummyToActual' relation.-                   m's = mapMaybe (flip lookup dummyToActual) ms-                   pairs = --if (length m's == 1) then -- i.e. there is not a-                           --  --direct relationship between variable and return-                           --    zip ms (repeat (head m's))-                           --else-                               (zip ms m's)--               ifDebug (report <<++ ("ms = " ++ show ms ++ ", m's' = "-                               ++ show m's-                               ++ ", their zip = " ++ show pairs-                               ++ " dA = " ++ show dummyToActual))--               if (True) -- length m's == length ms)-                 then do { newRow <- addRow' $ vector !! (n - 1);---                           mapM_ (handleArgPair matrix n newRow) pairs ; }-                           mapM_ (handleArgPair matrix n newRow) dummyToActual ; }-                 else return ()-         else-             return ()--    -- Copy the row-    handleArgPair matrix n newRow (m, m') = do-        modify $ liftUnitEnv $ setElem (matrix ! (n, m)) (newRow, m')--    decodeResult (Just r1) (Just r2) = ([r1], [r2])-    decodeResult Nothing Nothing = ([], [])-    decodeResult (Just _) Nothing = error "Subroutine used as a function!"-    decodeResult Nothing (Just _) = error "Function used as a subroutine!"--data BinOpKind = AddOp | MulOp | DivOp | PowerOp | LogicOp | RelOp-binOpKind :: F.BinaryOp -> BinOpKind-binOpKind F.Addition         = AddOp-binOpKind F.Subtraction      = AddOp-binOpKind F.Multiplication   = MulOp-binOpKind F.Division         = DivOp-binOpKind F.Exponentiation   = PowerOp-binOpKind F.Concatenation    = AddOp-binOpKind F.GT               = RelOp-binOpKind F.GTE              = RelOp-binOpKind F.LT               = RelOp-binOpKind F.LTE              = RelOp-binOpKind F.EQ               = RelOp-binOpKind F.NE               = RelOp-binOpKind F.Or               = LogicOp-binOpKind F.And              = LogicOp-binOpKind F.Equivalent       = RelOp-binOpKind F.NotEquivalent    = RelOp-binOpKind (F.BinCustom _)    = RelOp--(<**>) :: Maybe a -> Maybe a -> Maybe a-Nothing <**> x = x-(Just x) <**> y = (Just x)---{- OLD-    uenv <- gets varColEnv-    case lookupWithoutSrcSpan v uenv of-    let (VarName _ v, args) = head names--    case lookupWithoutSrcSpan v uenv of-       -- array variable?-       Just (uv, uvs@(_:_)) -> inferArgUnits' uvs >> return uv-       -- function call?-       Nothing | not (null args) -> do case (lookup (map toUpper v) intrinsicsDict) of-                                          Just fun -> fun v-                                          Nothing  -> return () -- error $ "I don't know the intrinsic " ++ v -- return ()-                                       uv@(VarCol uvn) <- anyUnits Temporary-                                       debugInfo << (uvn, (srcSpan ve, pprint ve))-                                       uvs <- inferArgUnits-                                       let uvs' = justArgUnits args uvs-                                       calls << (v, (Just uv, uvs'))-                                       return uv-       -- scalar variable or external function call?-       Just (uv, []) -> inferArgUnits >> return uv-       -- default specifier-       _ | v == "*" -> inferLiteral ve-       -- just bad code-       x -> case lookupCaseInsensitive v penv of-              Just (Just uv, argUnits) ->-                   if (null args) then inferArgUnits' argUnits >> return uv-                   else  do uv <- anyUnits Tempgit orary-                            uvs <- inferArgUnits-                            let uvs' = justArgUnits args uvs-                            calls << (v, (Just uv, uvs'))-                            return uv--              Nothing -> error $ "\n" ++ (showSrcFile . srcSpan $ ve) ++ ": undefined variable " ++ v ++ " at " ++ (showSrcSpan . srcSpan $ ve)-  where inferArgUnits = sequence [mapM perExpr exprs | (_, exprs) <- names]-        inferArgUnits' uvs = sequence [(perExpr expr) >>= (\uv' -> mustEqual True uv' uv) | ((_, exprs), uv) <- zip names uvs, expr <- exprs, not (nullF.Expression [expr])]--        justArgUnits [NullF.Expression _ _] _ = []  -- zero-argument function call-        justArgUnits _ uvs = head uvs-        -}---- TODO, create unit vars for every index and make sure consistent-perIndex :: Params => F.Name -> F.Index A1 -> State UnitEnv ()-perIndex v (F.IxSingle _ _ _ e) = return ()- {--  uenv <- gets varColEnv-  arrV <- case lookpuWithoutSrcSpan v env-           Nothing -> do-              uv@(ValCol uvn) <- anyUnits Temporary-              return uv-           Just (uv, uvs) ->--}--perExpr :: Params => F.Expression A1 -> State UnitEnv VarCol-perExpr e@(F.ExpValue _ span (F.ValVariable _)) = do-    let v = FA.varName e-    uenv <- gets varColEnv-    case lookupWithoutSrcSpan v uenv of-      Nothing ->-        case lookupWithoutSrcSpanRealName (realName v) uenv of-           Nothing -> do uv@(VarCol uvn) <- anyUnits Temporary-                         return uv-           Just (uv, _) -> return uv-      Just (uv, _) -> return uv--perExpr e@(F.ExpValue _ span v) = perLiteral v-  where-    perLiteral :: Params => F.Value A1 -> State UnitEnv VarCol-    perLiteral val = do-      uv@(VarCol uvn) <- anyUnits (Literal (?assumeLiterals /= Mixed))-      debugInfo << (uvn, (span, show val))-      return uv--perExpr e@(F.ExpBinary _ _ op e1 e2) = do-    uv1 <- perExpr e1-    uv2 <- perExpr e2-    (VarCol n) <- case binOpKind op of-                    AddOp   -> mustEqual True uv1 uv2-                    MulOp   -> mustAddUp uv1 uv2 1 1-                    DivOp   -> mustAddUp uv1 uv2 1 (-1)-                    PowerOp -> powerUnits uv1 e2-                    LogicOp -> mustEqual True uv1 uv2-                    RelOp   -> do mustEqual True uv1 uv2-                                  return $ VarCol 1-    debugInfo << (n, (FU.getSpan e, pprint e))-    return (VarCol n)-  where-    pprint e = "" -- TODO pprint--perExpr (F.ExpUnary _ _ _ e) = perExpr e-perExpr (F.ExpSubscript _ _ e alist) = do-    descendBiM (plumb (perIndex (FA.varName e))) alist-    perExpr e--perExpr f@(F.ExpFunctionCall _ span e@(F.ExpValue _ _ (F.ValVariable vReal)) args) = do-    uv <- anyUnits Temporary-    argsU <- fromMaybe (return []) (fmap (mapM perArgument . F.aStrip) args)-    calls << (vReal, (Just uv, argsU))-    return uv--perExpr f@(F.ExpDataRef _ _ e1 e2) = do-    perExpr e2-    perExpr e1-perExpr f@(F.ExpImpliedDo _ _ exprs spec) = do-    perDoSpecification spec-    uv <- anyUnits Temporary-    exprsU <- mapM perExpr (F.aStrip exprs)-    mapM_ (mustEqual True uv) exprsU-    return uv-perExpr f@(F.ExpInitialisation _ _ exprs) = do-    uv <- anyUnits Temporary-    exprsU <- mapM perExpr (F.aStrip exprs)-    mapM_ (mustEqual True uv) exprsU-    return uv-perExpr f@(F.ExpReturnSpec _ _ e) = do-    perExpr e--perArgument :: Params =>-    F.Argument A1 -> State UnitEnv VarCol-perArgument (F.Argument _ _ _ expr) = perExpr expr--handleExpression :: Params-    => F.Expression A1-    -> State UnitEnv (F.Expression A1)-handleExpression x = do-    perExpr x-    return x---- TODO: error handling in powerUnits-powerUnits :: Params-           => VarCol -> F.Expression A1 -> State UnitEnv VarCol--powerUnits (VarCol uv) (F.ExpValue _ _ (F.ValInteger powerString)) =-  case fmap (fromInteger . fst) $ listToMaybe $ reads powerString of-    Just power -> do-      m <- addCol Temporary-      n <- addRow-      modify $ liftUnitEnv $ incrElem (-1) (n, m) . incrElem power (n, uv)-      return $ VarCol m-    Nothing -> mustEqual False (VarCol uv) (VarCol 1)-powerUnits uv e =-  do mustEqual False uv (VarCol 1)-     uv <- perExpr e-     mustEqual False uv (VarCol 1)--lookupWithoutSrcSpanRealName :: Params => F.Name -> [(VarBinder, a)] -> Maybe a-lookupWithoutSrcSpanRealName v env = snd `fmap` find f env-      where-        f (VarBinder (w, _), _) = (map toUpper (realName w)) == map toUpper v++{-+  Units of measure extension to Fortran: frontend+-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternGuards #-}++module Camfort.Specification.Units.InferenceFrontend+  ( initInference, runCriticalVariables, runInferVariables, runInconsistentConstraints, getConstraint )+where++import Data.Data (Data)+import Data.List (nub)+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Set as S+import Data.Maybe (isJust, fromMaybe, catMaybes)+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+import qualified Language.Fortran.Analysis as FA++import Camfort.Analysis.CommentAnnotator (annotateComments)+import Camfort.Analysis.Annotations+import Camfort.Specification.Units.Environment+import Camfort.Specification.Units.Monad+import Camfort.Specification.Units.InferenceBackend+import qualified Camfort.Specification.Units.Parser as P++import qualified Debug.Trace as D+import qualified Numeric.LinearAlgebra as H -- for debugging++--------------------------------------------------++-- | Prepare to run an inference function.+initInference :: UnitSolver ()+initInference = do+  pf <- gets usProgramFile+  -- Parse unit annotations found in comments and link to their+  -- corresponding statements in the AST.+  let (linkedPF, parserReport) = runWriter $ annotateComments P.unitParser 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.++  -- First, find all given unit annotations and insert them into our+  -- mappings.  Also obtain all unit alias definitions.+  insertGivenUnits++  -- For function or subroutine parameters (or return variables) that+  -- are not given explicit units, give them a parametric polymorphic+  -- unit.+  insertParametricUnits++  -- Any other variables get assigned a unique undetermined unit named+  -- after the variable. This assumes that all variables have unique+  -- names, which the renaming module already has assured.+  insertUndeterminedUnits++  -- Now take the information that we have gathered and annotate the+  -- variable expressions within the AST with it.+  annotateAllVariables++  -- Annotate the literals within the program based upon the+  -- Literals-mode option.+  annotateLiterals++  -- With the variable expressions annotated, we now propagate the+  -- information throughout the AST, giving units to as many+  -- expressions as possible, and also constraints wherever+  -- appropriate.+  propagateUnits++  -- Gather up all of the constraints that we identified in the AST.+  -- These constraints will include parametric polymorphic units that+  -- have not yet been instantiated into their particular uses.+  abstractCons <- extractConstraints++  -- Eliminate all parametric polymorphic units by copying them for+  -- each specific use cases and substituting a unique call-site+  -- identifier that distinguishes each use-case from the others.+  cons <- applyTemplates abstractCons++  -- Remove any traces of CommentAnnotator, since the annotations can+  -- cause generic operations traversing the AST to get confused.+  modifyProgramFile cleanLinks++  modify $ \ s -> s { usConstraints = cons }++  debugLogging++cleanLinks :: F.ProgramFile UA -> F.ProgramFile UA+cleanLinks = transformBi (\ a -> a { unitBlock = Nothing, unitSpec = Nothing } :: UnitAnnotation A)++--------------------------------------------------+-- Inference functions++-- | Return a list of critical variables as UnitInfo list (most likely+-- to be of the UnitVar constructor).+runCriticalVariables :: UnitSolver [UnitInfo]+runCriticalVariables = do+  cons <- usConstraints `fmap` get+  return $ criticalVariables cons++-- | Return a list of variable names mapped to their corresponding+-- unit that was inferred.+runInferVariables :: UnitSolver [(String, UnitInfo)]+runInferVariables = do+  cons <- usConstraints `fmap` get+  return $ inferVariables cons++-- | Return a possible list of unsolvable constraints.+runInconsistentConstraints :: UnitSolver (Maybe Constraints)+runInconsistentConstraints = do+  cons <- usConstraints `fmap` get+  return $ inconsistentConstraints cons++--------------------------------------------------++-- | Seek out any parameters to functions or subroutines that do not+-- already have units, and insert parametric units for them into the+-- map of variables to UnitInfo.+insertParametricUnits :: UnitSolver ()+insertParametricUnits = gets usProgramFile >>= (mapM_ paramPU . universeBi)+  where+    paramPU pu = do+      forM_ (indexedParams pu) $ \ (i, param) -> do+        -- Insert a parametric unit if the variable does not already have a unit.+        modifyVarUnitMap $ M.insertWith (curry snd) param (UnitParamPosAbs (fname, i))+      where+        fname = puName pu++-- | Return the list of parameters paired with its positional index.+indexedParams :: F.ProgramUnit UA -> [(Int, String)]+indexedParams pu+  | F.PUFunction _ _ _ _ _ (Just paList) (Just r) _ _ <- pu = zip [0..] $ varName r : map varName (F.aStrip paList)+  | F.PUFunction _ _ _ _ _ (Just paList) _ _ _        <- pu = zip [0..] $ fname     : map varName (F.aStrip paList)+  | F.PUSubroutine _ _ _ _ (Just paList) _ _          <- pu = zip [1..] $ map varName (F.aStrip paList)+  | otherwise                                               = []+  where+    fname = puName pu++--------------------------------------------------++-- | Any remaining variables with unknown units are given unit UnitVar+-- with a unique name (in this case, taken from the unique name of the+-- variable as provided by the Renamer), or UnitParamVarAbs if the+-- variables are inside of a function or subroutine.+insertUndeterminedUnits :: UnitSolver ()+insertUndeterminedUnits = do+  pf <- gets usProgramFile+  forM_ (universeBi pf) $ \ pu -> case pu of+    F.PUFunction {}   -> modifyPUBlocksM (transformBiM (toParamVar (puName pu))) pu+    F.PUSubroutine {} -> modifyPUBlocksM (transformBiM (toParamVar (puName pu))) pu+    _                 -> modifyPUBlocksM (transformBiM toUnitVar) pu++  where+    toParamVar :: String -> F.Expression UA -> UnitSolver (F.Expression UA)+    toParamVar fname v@(F.ExpValue _ _ (F.ValVariable _)) = do+      let vname = varName v+      modifyVarUnitMap $ M.insertWith (curry snd) vname (UnitParamVarAbs (fname, vname))+      return v+    toParamVar _ e = return e++    toUnitVar :: F.Expression UA -> UnitSolver (F.Expression UA)+    toUnitVar v@(F.ExpValue _ _ (F.ValVariable _)) = do+      let vname = varName v+      modifyVarUnitMap $ M.insertWith (curry snd) vname (UnitVar vname)+      return v+    toUnitVar e = return e++--------------------------------------------------++-- | Any units provided by the programmer through comment annotations+-- will be incorporated into the VarUnitMap.+insertGivenUnits :: UnitSolver ()+insertGivenUnits = do+  pf <- gets usProgramFile+  mapM_ checkComment [ b | b@(F.BlComment {}) <- universeBi pf ]+  where+    -- Look through each comment that has some kind of unit annotation within it.+    checkComment :: F.Block UA -> UnitSolver ()+    checkComment (F.BlComment a _ _)+      -- Look at unit assignment between variable and spec.+      | Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec+      , Just b                                       <- mBlock = insertUnitAssignments (toUnitInfo unitsAST) b vars+      -- Add a new unit alias.+      | Just (P.UnitAlias name unitsAST)             <- mSpec  = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST))+      | otherwise                                              = return ()+      where+        mSpec  = unitSpec (FA.prevAnnotation a)+        mBlock = unitBlock (FA.prevAnnotation a)++    -- Figure out the unique names of the referenced variables and+    -- then insert unit info under each of those names.+    insertUnitAssignments info (F.BlStatement _ _ _ (F.StDeclaration _ _ _ _ decls)) varRealNames = do+      -- figure out the 'unique name' of the varRealName that was found in the comment+      -- FIXME: account for module renaming+      -- FIXME: might be more efficient to allow access to variable renaming environ at this program point+      nameMap <- uoNameMap `fmap` ask+      let m = M.fromList [ (varUniqueName, info) | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi decls+                                                 , varRealName <- varRealNames+                                                 , let varUniqueName = varName e+                                                 , maybe False (== varRealName) (varUniqueName `M.lookup` nameMap) ]+      modifyVarUnitMap $ M.unionWith const m+      modifyGivenVarSet . S.union . S.fromList . M.keys $ m++--------------------------------------------------++-- | Take the unit information from the VarUnitMap and use it to+-- annotate every variable expression in the AST.+annotateAllVariables :: UnitSolver ()+annotateAllVariables = modifyProgramFileM $ \ pf -> do+  varUnitMap <- usVarUnitMap `fmap` get+  let annotateExp e@(F.ExpValue _ _ (F.ValVariable _))+        | Just info <- M.lookup (varName e) varUnitMap = setUnitInfo info e+      annotateExp e = e+  return $ transformBi annotateExp pf++--------------------------------------------------++-- | Give units to literals based upon the rules of the Literals mode.+--+-- LitUnitless: All literals are unitless.+-- LitPoly:     All literals are polymorphic.+-- LitMixed:    The literal "0" or "0.0" is fully parametric polymorphic.+--              All other literals are monomorphic, possibly unitless.+annotateLiterals :: UnitSolver ()+annotateLiterals = modifyProgramFileM (transformBiM annotateLiteralsPU)++annotateLiteralsPU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)+annotateLiteralsPU pu = do+  mode <- asks uoLiterals+  case mode of+    LitUnitless -> modifyPUBlocksM (transformBiM expUnitless) pu+    LitPoly     -> modifyPUBlocksM (transformBiM (withLiterals genParamLit)) pu+    LitMixed    -> modifyPUBlocksM (transformBiM expMixed) pu+  where+    -- Follow the LitMixed rules.+    expMixed e = case e of+      F.ExpValue _ _ (F.ValInteger i) | read i == (0 :: Int) -> withLiterals genParamLit e+                                      | otherwise            -> withLiterals genUnitLiteral e+      F.ExpValue _ _ (F.ValReal i) | read i == (0 :: Double) -> withLiterals genParamLit e+                                   | otherwise               -> withLiterals genUnitLiteral e+      _                                                      -> return e++    -- Set all literals to unitless.+    expUnitless e+      | isLiteral e = return $ setUnitInfo UnitlessLit e+      | otherwise   = return e++    -- Set all literals to the result of given monadic computation.+    withLiterals m e+      | isLiteral e = flip setUnitInfo e `fmap` m+      | otherwise   = return e++--------------------------------------------------++-- | Convert all parametric templates into actual uses, via substitution.+applyTemplates :: Constraints -> UnitSolver Constraints+-- postcondition: returned constraints lack all Parametric constructors+applyTemplates cons = do+  -- Get a list of the instances of parametric polymorphism from the constraints.+  let instances = nub [ (name, i) | UnitParamPosUse (name, _, i) <- universeBi cons ]+  -- Work through the instances, expanding their templates, and+  -- substituting the callId into the abstract parameters.+  concreteCons <- foldM (substInstance []) [] instances++  -- Also include aliases in the final set of constraints, where+  -- aliases are implemented by simply asserting that they are equal+  -- to their definition.+  aliasMap <- usUnitAliasMap `fmap` get+  let aliases = [ ConEq (UnitAlias name) def | (name, def) <- M.toList aliasMap ]+  let transAlias (UnitName a) | a `M.member` aliasMap = UnitAlias a+      transAlias u                                    = u++  return . transformBi transAlias . filter (not . isParametric) $ cons ++ concreteCons ++ aliases++-- | Look up the Parametric templates for a given function or+-- subroutine, and do the substitutions. Process any additional+-- polymorphic calls that are uncovered, unless they are recursive+-- calls that have already been seen in the current call stack.+substInstance :: [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints+substInstance callStack output (name, callId)+  -- Detected recursion: we do not support polymorphic-unit recursion,+  -- ergo all subsequent recursive calls are assumed to have the same+  -- unit-assignments as the first call.+  | name `elem` callStack = return output+  | otherwise             = do+  tmap <- gets usTemplateMap++  -- Look up the templates associated with the given function or+  -- subroutine name. And then transform the templates by generating+  -- new callIds for any constraints created by function or subroutine+  -- calls contained within the templates.+  --+  -- The reason for this is because functions called by functions can+  -- be used in a parametric polymorphic way.+  template <- transformBiM callIdRemap $ [] `fromMaybe` M.lookup name tmap++  -- Reset the usCallIdRemap field so that it is ready for the next+  -- set of templates.+  modify $ \ s -> s { usCallIdRemap = IM.empty }++  -- If any new instances are discovered, also process them.+  let instances = nub [ (name, i) | UnitParamPosUse (name, _, i) <- universeBi template ]+  template' <- foldM (substInstance (name:callStack)) [] instances++  -- Convert any remaining abstract parametric units into concrete ones.+  return . instantiate (name, callId) $ output ++ template ++ template'++-- | If given a usage of a parametric unit, rewrite the callId field+-- to follow an existing mapping in the usCallIdRemap state field, or+-- generate a new callId and add it to the usCallIdRemap state field.+callIdRemap :: UnitInfo -> UnitSolver UnitInfo+callIdRemap info = modifyCallIdRemapM $ \ idMap -> case info of+    UnitParamPosUse (n, p, i)+      | Just i' <- IM.lookup i idMap -> return (UnitParamPosUse (n, p, i'), idMap)+      | otherwise                    -> genCallId >>= \ i' ->+                                          return (UnitParamPosUse (n, p, i'), IM.insert i i' idMap)+    UnitParamVarUse (n, v, i)+      | Just i' <- IM.lookup i idMap -> return (UnitParamVarUse (n, v, i'), idMap)+      | otherwise                    -> genCallId >>= \ i' ->+                                          return (UnitParamVarUse (n, v, i'), IM.insert i i' idMap)+    UnitParamLitUse (l, i)+      | Just i' <- IM.lookup i idMap -> return (UnitParamLitUse (l, i'), idMap)+      | otherwise                    -> genCallId >>= \ i' ->+                                          return (UnitParamLitUse (l, i'), IM.insert i i' idMap)+    _                         -> return (info, idMap)+++-- | Convert a parametric template into a particular use+instantiate (name, callId) = transformBi $ \ info -> case info of+  UnitParamPosAbs (name, position) -> UnitParamPosUse (name, position, callId)+  UnitParamLitAbs litId            -> UnitParamLitUse (litId, callId)+  UnitParamVarAbs (fname, vname)   -> UnitParamVarUse (fname, vname, callId)+  _                                -> info++--------------------------------------------------++-- | Gather all constraints from the main blocks of the AST, as well as from the varUnitMap+extractConstraints :: UnitSolver Constraints+extractConstraints = do+  pf         <- gets usProgramFile+  varUnitMap <- gets usVarUnitMap+  return $ [ con | b <- mainBlocks pf, con@(ConEq {}) <- universeBi b ] +++           [ ConEq (UnitVar v) u | (v, u) <- M.toList varUnitMap ]++-- | A list of blocks considered to be part of the 'main' program.+mainBlocks :: F.ProgramFile UA -> [F.Block UA]+mainBlocks = concatMap getBlocks . universeBi+  where+    getBlocks (F.PUMain _ _ _ bs _)   = bs+    getBlocks (F.PUModule _ _ _ bs _) = bs+    getBlocks _                       = []++-- | Does the constraint contain any Parametric elements?+isParametric :: Constraint -> Bool+isParametric info = not . null $ [ () | UnitParamPosAbs _ <- universeBi info ] +++                                 [ () | UnitParamVarAbs _ <- universeBi info ] +++                                 [ () | UnitParamLitAbs _ <- universeBi info ]++--------------------------------------------------++-- | Decorate the AST with unit info.+propagateUnits :: UnitSolver ()+-- precondition: all variables have already been annotated+propagateUnits = modifyProgramFileM $ transformBiM propagatePU        <=<+                                      transformBiM propagateStatement <=<+                                      transformBiM propagateExp++propagateExp :: F.Expression UA -> UnitSolver (F.Expression UA)+propagateExp e = fmap uoLiterals ask >>= \ lm -> case e of+  F.ExpValue _ _ (F.ValVariable _)       -> return e -- all variables should already be annotated+  F.ExpValue _ _ (F.ValInteger _)        -> return e -- all literal numbers should already be annotated+  F.ExpValue _ _ (F.ValReal _)           -> return e -- all literal numbers should already be annotated+  F.ExpBinary _ _ F.Multiplication e1 e2 -> setF2 UnitMul (getUnitInfoMul lm e1) (getUnitInfoMul lm e2)+  F.ExpBinary _ _ F.Division e1 e2       -> setF2 UnitMul (getUnitInfoMul lm e1) (flip UnitPow (-1) `fmap` (getUnitInfoMul lm e2))+  F.ExpBinary _ _ F.Exponentiation e1 e2 -> setF2 UnitPow (getUnitInfo e1) (constantExpression e2)+  F.ExpBinary _ _ o e1 e2 | isOp AddOp o -> setF2C ConEq  (getUnitInfo e1) (getUnitInfo e2)+                          | isOp RelOp o -> setF2C ConEq  (getUnitInfo e1) (getUnitInfo e2)+  F.ExpFunctionCall {}                   -> propagateFunctionCall e+  _                                      -> whenDebug (tell ("propagateExp: unhandled: " ++ show e)) >> return e+  where+    -- Shorter names for convenience functions.+    setF2 f u1 u2  = return $ maybeSetUnitInfoF2 f u1 u2 e+    -- Remember, not only set a constraint, but also give a unit!+    setF2C f u1 u2 = return . maybeSetUnitInfo u1 $ maybeSetUnitConstraintF2 f u1 u2 e++propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA)+propagateFunctionCall e@(F.ExpFunctionCall a s f Nothing)                     = do+  (info, _)     <- callHelper f []+  return . setUnitInfo info $ F.ExpFunctionCall a s f Nothing+propagateFunctionCall e@(F.ExpFunctionCall a s f (Just (F.AList a' s' args))) = do+  (info, args') <- callHelper f args+  return . setUnitInfo info $ F.ExpFunctionCall a s f (Just (F.AList a' s' args'))++propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA)+propagateStatement stmt = case stmt of+  F.StExpressionAssign _ _ e1 e2               -> do+    return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) stmt+  F.StCall a s sub (Just (F.AList a' s' args)) -> do+    (_, args') <- callHelper sub args+    return $ F.StCall a s sub (Just (F.AList a' s' args'))+  F.StDeclaration {}                           -> transformBiM propagateDeclarator stmt+  _                                            -> return stmt++propagateDeclarator :: F.Declarator UA -> UnitSolver (F.Declarator UA)+propagateDeclarator decl = case decl of+  F.DeclVariable _ _ e1 _ (Just e2) -> do+    return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) decl+  F.DeclArray _ _ e1 _ _ (Just e2)  -> do+    return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) decl+  _                                 -> return decl++propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA)+propagatePU pu = do+  let name = puName pu+  let bodyCons = [ con | con@(ConEq {}) <- universeBi pu ] -- Constraints within the PU.++  varMap <- gets usVarUnitMap++  -- If any of the function/subroutine parameters was given an+  -- explicit unit annotation, then create a constraint between that+  -- explicit unit and the UnitParamPosAbs corresponding to the+  -- parameter. This way all other uses of the parameter get linked to+  -- the explicit unit annotation as well.+  givenCons <- fmap catMaybes . forM (indexedParams pu) $ \ (i, param) -> do+    case M.lookup param varMap of+      Just (UnitParamPosAbs {}) -> return Nothing+      Just u                    -> return . Just . ConEq u $ UnitParamPosAbs (name, i)+      _                         -> return Nothing++  let cons = givenCons ++ bodyCons+  modifyTemplateMap (M.insert name cons)+  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+  callId <- genCallId -- every call-site gets its own unique identifier+  let eachArg i arg@(F.Argument _ _ _ e)+        -- add site-specific parametric constraints to each argument+        | Just u <- getUnitInfo e = setConstraint (ConEq u (UnitParamPosUse (name, i, callId))) arg+        | otherwise               = arg+  let args' = zipWith eachArg [1..] args+  -- build a site-specific parametric unit for use on a return variable, if any+  let info = UnitParamPosUse (name, 0, callId)+  return (info, args')++-- | Generate a unique identifier for a call-site.+genCallId :: UnitSolver Int+genCallId = do+  st <- get+  let callId = usCallIds st+  put $ st { usCallIds = callId + 1 }+  return callId++-- | Generate a unique identifier for a literal encountered in the code.+genUnitLiteral :: UnitSolver UnitInfo+genUnitLiteral = do+  s <- get+  let i = usLitNums s+  put $ s { usLitNums = i + 1 }+  return $ UnitLiteral i++-- | Generate a unique identifier for a polymorphic literal encountered in the code.+genParamLit :: UnitSolver UnitInfo+genParamLit = do+  s <- get+  let i = usLitNums s+  put $ s { usLitNums = i + 1 }+  return $ UnitParamLitAbs i++--------------------------------------------------++-- | Extract the unit info from a given annotated piece of AST.+getUnitInfo :: F.Annotated f => f UA -> Maybe UnitInfo+getUnitInfo = unitInfo . FA.prevAnnotation . F.getAnnotation++-- | Extract the constraint from a given annotated piece of AST.+getConstraint :: F.Annotated f => f UA -> Maybe Constraint+getConstraint = unitConstraint . FA.prevAnnotation . F.getAnnotation++-- | Extract the unit info from a given annotated piece of AST, within+-- the context of a multiplication expression, and given a particular+-- mode for handling literals.+--+-- The point is that the unit-assignment of a literal constant can+-- vary depending upon whether it is being multiplied by a variable+-- with units, and possibly by global options that assume one way or+-- the other.+getUnitInfoMul :: LiteralsOpt -> F.Expression UA -> Maybe UnitInfo+getUnitInfoMul LitPoly e          = getUnitInfo e+getUnitInfoMul _ e+  | isJust (constantExpression e) = Just UnitlessLit+  | otherwise                     = getUnitInfo e++-- | Set the UnitInfo field on a piece of AST.+setUnitInfo :: F.Annotated f => UnitInfo -> f UA -> f UA+setUnitInfo info = 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 c = modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c }))++--------------------------------------------------++-- Various helper functions for setting the UnitInfo or Constraint of a piece of AST+maybeSetUnitInfo :: F.Annotated f => Maybe UnitInfo -> f UA -> f UA+maybeSetUnitInfo Nothing e  = e+maybeSetUnitInfo (Just u) e = setUnitInfo u e++maybeSetUnitInfoF2 :: F.Annotated f => (a -> b -> UnitInfo) -> Maybe a -> Maybe b -> f UA -> f UA+maybeSetUnitInfoF2 f (Just u1) (Just u2) e = setUnitInfo (f u1 u2) e+maybeSetUnitInfoF2 _ _ _ e                 = e++maybeSetUnitConstraintF2 :: F.Annotated f => (a -> b -> Constraint) -> Maybe a -> Maybe b -> f UA -> f UA+maybeSetUnitConstraintF2 f (Just u1) (Just u2) e = setConstraint (f u1 u2) e+maybeSetUnitConstraintF2 _ _ _ e                 = e++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+  F.PUMain a s n b pus                    -> flip fmap (f b) $ \ b' -> F.PUMain a s n b' pus+  F.PUModule a s n b pus                  -> flip fmap (f b) $ \ b' -> F.PUModule a s n b' pus+  F.PUSubroutine a s r n p b subs         -> flip fmap (f b) $ \ b' -> F.PUSubroutine a s r n p b' subs+  F.PUFunction   a s r rec n p res b subs -> flip fmap (f b) $ \ b' -> F.PUFunction a s r rec n p res b' subs+  F.PUBlockData  a s n b                  -> flip fmap (f b) $ \ b' -> F.PUBlockData  a s n b'++-- Is it a literal, literally?+isLiteral (F.ExpValue _ _ (F.ValReal _)) = True+isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True+isLiteral _ = False++--------------------------------------------------++-- | Statically computes if the expression is a constant value.+constantExpression :: F.Expression a -> Maybe Double+constantExpression (F.ExpValue _ _ (F.ValInteger i)) = Just $ read i+constantExpression (F.ExpValue _ _ (F.ValReal r))    = Just $ read r+-- FIXME: expand...+constantExpression _                                 = Nothing++-- | Asks the question: is the operator within the given category?+isOp :: BinOpKind -> F.BinaryOp -> Bool+isOp cat = (== cat) . binOpKind++data BinOpKind = AddOp | MulOp | DivOp | PowerOp | LogicOp | RelOp deriving Eq+binOpKind :: F.BinaryOp -> BinOpKind+binOpKind F.Addition         = AddOp+binOpKind F.Subtraction      = AddOp+binOpKind F.Multiplication   = MulOp+binOpKind F.Division         = DivOp+binOpKind F.Exponentiation   = PowerOp+binOpKind F.Concatenation    = AddOp+binOpKind F.GT               = RelOp+binOpKind F.GTE              = RelOp+binOpKind F.LT               = RelOp+binOpKind F.LTE              = RelOp+binOpKind F.EQ               = RelOp+binOpKind F.NE               = RelOp+binOpKind F.Or               = LogicOp+binOpKind F.And              = LogicOp+binOpKind F.Equivalent       = RelOp+binOpKind F.NotEquivalent    = RelOp+binOpKind (F.BinCustom _)    = RelOp++--------------------------------------------------++debugLogging :: UnitSolver ()+debugLogging = whenDebug $ do+    (tell . unlines . map (\ (ConEq u1 u2) -> "  ***AbsConstraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2) ++ "\n")) =<< extractConstraints+    pf <- gets usProgramFile+    cons <- usConstraints `fmap` get+    vum <- usVarUnitMap `fmap` get+    tell . unlines $ [ "  " ++ show info ++ " :: " ++ n | (n, info) <- M.toList vum ]+    tell "\n\n"+    uam <- usUnitAliasMap `fmap` get+    tell . unlines $ [ "  " ++ n ++ " = " ++ show info | (n, info) <- M.toList uam ]+    tell . unlines $ map (\ (ConEq u1 u2) -> "  ***Constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2) ++ "\n") cons+    tell $ show cons ++ "\n\n"+    forM_ (universeBi pf) $ \ pu -> case pu of+      F.PUFunction {}+        | Just (ConConj cons) <- getConstraint pu ->+          whenDebug . tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> "    constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons+      F.PUSubroutine {}+        | Just (ConConj cons) <- getConstraint pu ->+          whenDebug . tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> "    constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons+      _ -> return ()+    let (unsolvedM, inconsists, colA) = constraintsToMatrix cons+    let solvedM = rref unsolvedM+    tell "\n--------------------------------------------------\n"+    tell $ show colA+    tell "\n--------------------------------------------------\n"+    tell $ show unsolvedM+    tell "\n--------------------------------------------------\n"+    tell . show $ (H.takeRows (H.rank solvedM) solvedM)+    tell "\n--------------------------------------------------\n"+    tell $ "Rank: " ++ show (H.rank solvedM) ++ "\n"+    tell $ "Is inconsistent RREF? " ++ show (isInconsistentRREF solvedM) ++ "\n"+    tell $ "Inconsistent rows: " ++ show (inconsistentConstraints cons) ++ "\n"+    tell "--------------------------------------------------\n"+    tell $ "Critical Variables: " ++ show (criticalVariables cons) ++ "\n"+    tell $ "Infer Variables: " ++ show (inferVariables cons) ++ "\n"++--------------------------------------------------++-- convenience+puName :: F.ProgramUnit UA -> F.Name+puName pu+  | F.Named n <- FA.puName pu = n+  | otherwise               = "_nameless"++varName :: F.Expression UA -> F.Name+varName = FA.varName

@@ -0,0 +1,170 @@+{-+   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 DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | Defines the monad for the units-of-measure modules -}+module Camfort.Specification.Units.Monad+  ( UA, UnitSolver, UnitOpts(..), unitOpts0, UnitLogs, UnitState(..), LiteralsOpt(..), UnitException+  , whenDebug, modifyVarUnitMap, modifyGivenVarSet, modifyUnitAliasMap+  , VarUnitMap, GivenVarSet, UnitAliasMap, TemplateMap, CallIdMap+  , modifyTemplateMap, modifyProgramFile, modifyProgramFileM, modifyCallIdRemapM+  , runUnitSolver, evalUnitSolver, execUnitSolver )+where++import Control.Monad.RWS.Strict+import Control.Monad.Trans.Except+import Data.Char (toLower)+import Data.Data (Data)+import Data.List (find, isPrefixOf)+import qualified Data.Map as M+import qualified Data.IntMap 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 Camfort.Specification.Units.Environment (UnitInfo, UnitAnnotation, Constraints(..))+import Camfort.Analysis.Annotations (Annotation, A, UA)++--------------------------------------------------++-- | The monad+type UnitSolver a = ExceptT UnitException (RWS UnitOpts UnitLogs UnitState) a++--------------------------------------------------++-- Not in use, but might be useful someday.+type UnitException = ()++--------------------------------------------------++-- Read-only options for the unit solver.++-- | Some options about how to handle literals.+data LiteralsOpt+  = LitPoly     -- ^ All literals are polymorphic.+  | LitUnitless -- ^ All literals are unitless.+  | LitMixed    -- ^ The literal "0" or "0.0" is fully parametric+                -- polymorphic. All other literals are monomorphic,+                -- possibly unitless.+  deriving (Show, Eq, Ord, Data)++instance Read LiteralsOpt where+  readsPrec _ s = case find ((`isPrefixOf` map toLower s) . fst) ms of+                    Just (str, con) -> [(con, drop (length str) s)]+                    Nothing         -> []+    where+      ms = [ ("poly", LitPoly), ("unitless", LitUnitless), ("mixed", LitMixed)+           , ("litpoly", LitPoly), ("litunitless", LitUnitless), ("litmixed", LitMixed) ]++data UnitOpts = UnitOpts+  { uoDebug          :: Bool         -- ^ debugging mode?+  , uoLiterals       :: LiteralsOpt  -- ^ how to handle literals+  , uoNameMap        :: FAR.NameMap  -- ^ map of unique names to original names+  }+  deriving (Show, Read, Data, Eq, Ord)++unitOpts0 :: UnitOpts+unitOpts0 = UnitOpts False LitMixed M.empty++-- | Only run the argument if debugging mode enabled.+whenDebug :: UnitSolver () -> UnitSolver ()+whenDebug m = fmap uoDebug ask >>= \ d -> when d m++--------------------------------------------------++-- Track some logging information in the monad.+type UnitLogs = String++--------------------------------------------------++-- | Variable unique name => unit+type VarUnitMap   = M.Map F.Name UnitInfo+-- | Set of variables given explicit unit annotations+type GivenVarSet  = S.Set F.Name+-- | Alias name => definition+type UnitAliasMap = M.Map String UnitInfo+-- | Function/subroutine name -> associated, parametric polymorphic constraints+type TemplateMap  = M.Map F.Name Constraints+-- | Map of CallId to CallId+type CallIdMap    = IM.IntMap Int++-- | Working state for the monad+data UnitState = UnitState+  { usProgramFile  :: F.ProgramFile UA+  , usVarUnitMap   :: VarUnitMap+  , usGivenVarSet  :: GivenVarSet+  , usUnitAliasMap :: UnitAliasMap+  , usTemplateMap  :: TemplateMap+  , usLitNums      :: Int+  , usCallIds      :: Int+  , usCallIdRemap  :: CallIdMap+  , usConstraints  :: Constraints }+  deriving (Show, Data)++unitState0 pf = UnitState { usProgramFile  = pf+                          , usVarUnitMap   = M.empty+                          , usGivenVarSet  = S.empty+                          , usUnitAliasMap = M.empty+                          , usTemplateMap  = M.empty+                          , usLitNums      = 0+                          , usCallIds      = 0+                          , usCallIdRemap  = IM.empty+                          , usConstraints  = [] }++-- helper functions+modifyVarUnitMap :: (VarUnitMap -> VarUnitMap) -> UnitSolver ()+modifyVarUnitMap f = modify (\ s -> s { usVarUnitMap = f (usVarUnitMap s) })++modifyGivenVarSet :: (GivenVarSet -> GivenVarSet) -> UnitSolver ()+modifyGivenVarSet f = modify (\ s -> s { usGivenVarSet = f (usGivenVarSet s) })++modifyUnitAliasMap :: (UnitAliasMap -> UnitAliasMap) -> UnitSolver ()+modifyUnitAliasMap f = modify (\ s -> s { usUnitAliasMap = f (usUnitAliasMap s) })++modifyTemplateMap :: (TemplateMap -> TemplateMap) -> UnitSolver ()+modifyTemplateMap f = modify (\ s -> s { usTemplateMap = f (usTemplateMap s) })++modifyProgramFile :: (F.ProgramFile UA -> F.ProgramFile UA) -> UnitSolver ()+modifyProgramFile f = modify (\ s -> s { usProgramFile = f (usProgramFile s) })++modifyProgramFileM :: (F.ProgramFile UA -> UnitSolver (F.ProgramFile UA)) -> UnitSolver ()+modifyProgramFileM f = do+  pf <- fmap usProgramFile get+  pf' <- f pf+  modify (\ s -> s { usProgramFile = pf' })++modifyCallIdRemapM :: (CallIdMap -> UnitSolver (a, CallIdMap)) -> UnitSolver a+modifyCallIdRemapM f = do+  idMap <- gets usCallIdRemap+  (x, idMap') <- f idMap+  modify (\ s -> s { usCallIdRemap = idMap' })+  return x++--------------------------------------------------++-- | Run the unit solver monad.+runUnitSolver :: UnitOpts -> F.ProgramFile UA -> UnitSolver a -> (Either UnitException a, UnitState, UnitLogs)+runUnitSolver o pf m = runRWS (runExceptT m) o (unitState0 pf)++evalUnitSolver :: UnitOpts -> F.ProgramFile UA -> UnitSolver a -> (Either UnitException a, UnitLogs)+evalUnitSolver o pf m = (ea, l) where (ea, _, l) = runUnitSolver o pf m++execUnitSolver :: UnitOpts -> F.ProgramFile UA -> UnitSolver a -> Either UnitException (UnitState, UnitLogs)+execUnitSolver o pf m = case runUnitSolver o pf m of+  (Left e, _, _)  -> Left e+  (Right _, s, l) -> Right (s, l)

@@ -153,7 +153,7 @@ lexer' (x:xs)  | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId  | isNumber x = aux isNumber TNum- | otherwise = failWith $ "Not valid unit syntax at " ++ show (x:xs)+ | otherwise = Left NotAnnotation -- failWith $ "Not valid unit syntax at " ++ show (x:xs)  where    aux p cons =      let (target, rest) = span p xs@@ -165,6 +165,6 @@  parseUnit tokens  happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = failWith $ "Could not parse specification at: " ++ show t+happyError t = Left NotAnnotation -- failWith $ "Could not parse specification at: " ++ show t  }

@@ -1,122 +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 ImplicitParams, BangPatterns #-}--module Camfort.Specification.Units.Solve where--import Data.Ratio-import Data.List-import qualified Data.Matrix as DM-import qualified Data.Vector as V-import Control.Exception-import System.IO.Unsafe-import qualified Debug.Trace as D---import Language.Fortran-import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.SolveHMatrix---- Top-level, select the solver-solveSystem :: (?solver :: Solver) => LinearSystem -> Consistency LinearSystem-solveSystem = case ?solver of---                  LAPACK -> solveSystemL---                  Custom -> solveSystemC-                  Custom -> solveSystemH------------------------------------------------------ CUSTOM SOLVER------------------------------------------------------- Top-level custom solver-solveSystemC :: LinearSystem -> Consistency LinearSystem-solveSystemC system = solveSystem' system 1 1--solveSystem' :: LinearSystem -> Col -> Row -> Consistency LinearSystem-solveSystem' (matrix, vector) m k-  | m > DM.ncols matrix = efmap (cutSystem k) $ checkSystem (matrix, vector) k-  | otherwise = elimRow (matrix, vector) n m k-                where n = find (\n -> matrix DM.! (n, m) /= 0) [k .. DM.nrows matrix]--cutSystem :: Int -> LinearSystem -> LinearSystem-cutSystem k (matrix, vector) = (matrix', vector')-  where matrix' = DM.submatrix 1 (k - 1) 1 (DM.ncols matrix) matrix-        vector' = take (k - 1) vector--checkSystem :: LinearSystem -> Row -> Consistency LinearSystem-checkSystem (matrix, vector) k-  | k > DM.nrows matrix = Ok (matrix, vector)-  | vector !! (k - 1) /= Unitful [] = let vars = V.toList $ DM.getRow k matrix-                                          bad = Bad (matrix, vector) k (vector !! (k - 1), vars)-                                      in bad-  | otherwise = checkSystem (matrix, vector) (k + 1)--elimRow :: LinearSystem -> Maybe Row -> Col -> Row -> Consistency LinearSystem-elimRow system Nothing m k = solveSystem' system (m + 1) k-elimRow (matrix, vector) (Just n) m k = -- (show (m, k)) `D.trace`- solveSystem' system' (m + 1) (k + 1)-  where matrix' = let s = matrix DM.! (n, m) in-                    (if (k == n) then id else DM.switchRows k n)-                       (if s == 1 then matrix else DM.scaleRow (recip $ s) n matrix)-        vector' = switchScaleElems k n (fromRational $ recip $ matrix DM.! (n, m)) vector-        system' = elimRow' (matrix', vector') k m--msteeper matrix k m = msteep matrix 1-                       where-                         r = DM.nrows matrix-                         msteep matrix n | n > r = matrix-                                         | n == k = msteep matrix (n+1)-                                         | otherwise = let s = (- matrix DM.! (n, m))-                                                       in if s == 0 then msteep matrix (n+1)-                                                          else msteep (DM.combineRows n s k matrix) (n+1)--elimRow' :: LinearSystem -> Row -> Col -> LinearSystem-elimRow' (matrix, vector) k m = (matrix', vector')-  where mstep matrix n = let s = (- matrix DM.! (n, m)) in if s == 0 then matrix else DM.combineRows n s k matrix-        matrix' = foldl mstep matrix $ [1 .. k - 1] ++ [k + 1 .. DM.nrows matrix]-        --matrix' = msteeper matrix k m-        vector'' = [x - fromRational (matrix DM.! (n, m)) * vector !! (k - 1) | (n, x) <- zip [1..] vector]-        (a, _ : b) = splitAt (k - 1) vector''-        vector' = a ++ vector !! (k - 1) : b--switchScaleElems :: Num a => Int -> Int -> a -> [a] -> [a]-switchScaleElems i j factor list = a ++ factor * b : c-  where (lj, b:rj) = splitAt (j - 1) list-        (a, _:c) = splitAt (i - 1) (lj ++ list !! (i - 1) : rj)------------------------------------------------------- Top-level custom solver based on HMatrix-solveSystemH :: LinearSystem -> Consistency LinearSystem-solveSystemH system@(m,v) =-  case convertToHMatrix system of-    Left  (n:_)       -> Bad system (DM.nrows m) (v !! n, V.toList (DM.getRow n m))-    Right (m', units) -> Ok sys'-      where-        m2   = rref m'-        m3   = takeRows (rank m2) m2-        sys' = convertFromHMatrix (m3, units)------------------------------------------------------- Top-level custom solver based on HMatrix--- This version uses "Either" result instead of "Consistency".-solveSystemH_Either :: LinearSystem -> Either [Int] LinearSystem-solveSystemH_Either system@(m,v) =-  case convertToHMatrix system of-    Left  ns          -> Left ns-    Right (m', units) -> Right sys'-      where-        m2   = rref m'-        m3   = takeRows (rank m2) m2-        sys' = convertFromHMatrix (m3, units)

@@ -1,215 +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 FlexibleContexts #-}--module Camfort.Specification.Units.SolveHMatrix-  ( rref, rrefMatrices, convertToHMatrix, convertFromHMatrix, isInconsistentRREF-  , dispf, Units, lu, rank, takeRows )-where--import Data.Ratio-import Debug.Trace (trace)-import Numeric.LinearAlgebra (-    atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols,-    Matrix, takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks,-    ident, flatten, lu, dispf-  )-import Numeric.LinearAlgebra.Devel (-    newMatrix, writeMatrix, runSTMatrix-  )-import Control.Monad (filterM)-import Control.Monad.ST-import qualified Data.Matrix as Old (nrows, ncols, toList, Matrix, fromList)-import Foreign.Storable (Storable)-import Data.List (findIndex, nub, sort, (\\))-import Data.Maybe (fromMaybe)-import Camfort.Specification.Units.Environment (LinearSystem, UnitConstant(..))-import Language.Fortran (MeasureUnit)---- | Returns True iff the given matrix in reduced row echelon form--- represents an inconsistent system of linear equations-isInconsistentRREF a = a @@> (rows a - 1, cols a - 1) == 1 && rank (takeColumns (cols a - 1) (dropRows (rows a - 1) a))== 0---- | Returns given matrix transformed into Reduced Row Echelon Form-rref :: Matrix Double -> Matrix Double-rref a = snd $ rrefMatrices' a 0 0 []---- | List of matrices that when multiplied transform input into--- Reduced Row Echelon Form-rrefMatrices :: Matrix Double -> [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 :: Matrix Double -> 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-  -- Base cases:-  | j - k == n            = (mats, a)-  | j     == m            = (mats, a)--  -- When we haven't yet found the first non-zero number in the row, but we really need one:-  | a @@> (j - k, j) == 0 = case findIndex (/= 0) below of-    -- this column is all 0s below current row, must move onto the next column-    Nothing -> rrefMatrices' a (j + 1) (k + 1) mats-    -- we've found a row that has a non-zero element that can be swapped into this row-    Just i' -> rrefMatrices' (swapMat <> a) j k (swapMat:mats)-      where i       = j - k + i'-            swapMat = elemRowSwap n i (j - k)--  -- We have found a non-zero cell at (j - k, j), so transform it into-  -- a 1 if needed using elemRowMult, and then clear out any lingering-  -- non-zero values that might appear in the same column, using-  -- elemRowAdd:-  | otherwise             = rrefMatrices' a2 (j + 1) k mats2-  where-    n     = rows a-    m     = cols a-    below = getColumnBelow a (j - k, j)--    -- scale the row if the cell is not already equal to 1-    erm    = elemRowMult n (j - k) (recip (a @@> (j - k, j)))-    (a1, mats1) = if a @@> (j - k, j) /= 1 then-                    (erm <> a, erm:mats)-                  else (a, mats)--    -- Locate any non-zero values in the same column as (j - k, j) and-    -- cancel them out. Optimisation: instead of constructing a-    -- 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 = (new <> m, new:ms)-      where-        new = runSTMatrix $ do-          new <- newMatrix 0 n n-          sequence [ writeMatrix new i' i' 1 | i' <- [0 .. (n - 1)] ]-          let f i | i >= n            = return ()-                  | i == j - k        = f (i + 1)-                  | a @@> (i, j) == 0 = f (i + 1)-                  | otherwise         = writeMatrix new i (j - k) (- (a @@> (i, j)))-                                        >> f (i + 1)-          f 0-          return new-    (a2, mats2) = findAdds 0 a1 mats1---- Get a list of values that occur below (i, j) in the matrix a.-getColumnBelow a (i, j) = concat . toLists $ subMatrix (i, j) (n - i, 1) a-  where n = rows a---- 'Elementary row operation' matrices-elemRowMult n i k = diag (fromList (replicate i 1.0 ++ [k] ++ replicate (n - i - 1) 1.0))---elemRowAdd :: Int -> Int -> Int -> Double -> 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--elemRowAdd_spec n i j k-  | i < 0 || i >= n = undefined-  | j < 0 || j >= n = undefined-  | otherwise       = build n n f-  where-    f (i', j') | i == i' && j == j' = k-               | i' == j'           = 1-               | otherwise          = 0--elemRowSwap n i j-  | i == j          = ident n-  | i > j           = elemRowSwap n j i-  | otherwise       = extractRows ([0..i-1] ++ [j] ++ [i+1..j-1] ++ [i] ++ [j+1..n-1]) $ ident n-------------------------------------------------------type Units = [MeasureUnit]---- | Convert a LinearSystem into an hmatrix and a list of units that are used-convertToHMatrix :: LinearSystem -> Either [Int] (Matrix Double, Units)-convertToHMatrix (a, ucs) = case findInconsistentRows a' augA of-                              [] -> Right (augA, units)-                              ns -> Left ns-  where-    a'       = convertMatrixToHMatrix a-    m        = cols a'-    units    = ucsToUnits ucs-    unitA    = unitsToUnitA ucs units-    augA     = fromBlocks [[a', unitA]]---- | Convert an hmatrix and the list of units used back into a LinearSystem-convertFromHMatrix :: (Matrix Double, [MeasureUnit]) -> LinearSystem-convertFromHMatrix (a, units) = (a', ucs')-  where-    ulen  = length units-    a'    = convertHMatrixToMatrix (takeColumns (cols a - ulen) a)-    unitA = dropColumns (cols a - ulen) a-    ucs   = unitAToUcs unitA units-    -- special case: when there are no units, ensure the empty list is replaced with [Unitful [] ...]-    ucs'  = if null ucs then replicate (rows a) (Unitful []) else ucs----- Worker functions:--convertMatrixToHMatrix :: Old.Matrix Rational -> Matrix Double-convertMatrixToHMatrix a = (Old.nrows a >< Old.ncols a) . map toDouble $ Old.toList a--convertHMatrixToMatrix :: Matrix Double -> Old.Matrix Rational-convertHMatrixToMatrix a = Old.fromList (rows a) (cols a) . map fromDouble . toList $ flatten a--toDouble :: Rational -> Double-toDouble = fromRational--fromDouble :: Double -> Rational-fromDouble = toRational--unitsToUnitA :: [UnitConstant] -> Units -> Matrix Double-unitsToUnitA ucs units = unitA-  where-    unitA = fromLists . flip map ucs $ \ uc -> case uc of-              Unitful us -> flip map units (toDouble . fromMaybe 0 . flip lookup us)-              _          -> map (const 0) units--ucsToUnits :: [UnitConstant] -> Units-ucsToUnits ucs = sort . nub . (ucs >>=) $ \ uc -> case uc of-                   Unitful us -> map fst us-                   _          -> []--unitAToUcs :: Matrix Double -> Units -> [UnitConstant]-unitAToUcs unitA units =-  flip map (toLists unitA) (Unitful . filter ((/= 0) . snd) . zip units . map fromDouble)--findInconsistentRows :: Matrix Double -> Matrix Double -> [Int]-findInconsistentRows coA augA = [0..(rows augA - 1)] \\ consistent-  where-    consistent = head (filter (tryRows coA augA) (pset ( [0..(rows augA - 1)])) ++ [[]])--    -- Rouché–Capelli theorem is that if the rank of the coefficient-    -- matrix is not equal to the rank of the augmented matrix then-    -- the system of linear equations is inconsistent.-    tryRows coA augA ns = (rank coA' == rank augA')-      where-        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

@@ -1,50 +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.--}--module Camfort.Specification.Units.Strip where--import Data.Data-import Data.Char-import Data.Generics.Uniplate.Operations--import Camfort.Analysis.Annotations hiding (Unitless)-import Camfort.Specification.Units.Environment-import Camfort.Specification.Units.Synthesis-import Camfort.Transformation.Syntax--{-| DEPRECATED: Provide functionality for stripping out unit annotations -}--{--removeUnitsInBlock :: Block Annotation -> Block Annotation-removeUnitsInBlock = transformBi deleteUnits--deleteUnits :: Decl Annotation -> Decl Annotation-deleteUnits (Decl a sp@(s1, s2) d t) | hasUnits t =-  Decl a' (dropLine sp) d t'-  where a' = a { refactored = Just $ toCol0 s1 }-        t' = deleteUnit t-deleteUnits (MeasureUnitDef a sp@(s1, s2) d) =-  NullDecl a' sp'-  where a' = a { refactored = Just s1 }-        sp' = (toCol0 s1, snd $ dropLine sp)-deleteUnits decl = decl--deleteUnit :: Type Annotation -> Type Annotation-deleteUnit (BaseType aa tt attrs kind len) =-  BaseType aa tt (filter (not . isUnit) attrs) kind len-deleteUnit (ArrayT dims aa tt attrs kind len) =-  ArrayT dims aa tt (filter (not . isUnit) attrs) kind len--}

@@ -14,10 +14,11 @@    limitations under the License. -} -{-# LANGUAGE ImplicitParams, DoAndIfThenElse, ConstraintKinds #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables, ImplicitParams, DoAndIfThenElse, ConstraintKinds #-}  module Camfort.Specification.Units.Synthesis-                (synthesiseUnits, pprintUnitConstant) where+  (runSynthesis)+where  import Data.Function import Data.List@@ -25,9 +26,12 @@ import Data.Maybe import Data.Ratio (numerator, denominator) import qualified Data.Map as M+import qualified Data.Set as S import Data.Generics.Uniplate.Operations import Data.Label.Monadic hiding (modify) 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@@ -35,141 +39,66 @@ import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Util.Position as FU +import qualified Camfort.Specification.Units.Parser as P+import Camfort.Analysis.CommentAnnotator import qualified Camfort.Output as O (srcSpanToSrcLocs) import Camfort.Analysis.Annotations hiding (Unitless) import Camfort.Specification.Units.Environment+import Camfort.Specification.Units.Monad import qualified Debug.Trace as D --- *************************************---   Insert unit declarations into code------ *************************************--type A1 = FA.Analysis (UnitAnnotation A)-type Params = ?nameMap :: FAR.NameMap---- Run this after checking/inference-synthesiseUnits :: Params => Bool -> F.ProgramFile A1 -> State UnitEnv (F.ProgramFile A1)-synthesiseUnits inferReport pf = transformBiM (perBlock inferReport) pf--perBlock :: Params => Bool -> F.Block A1 -> State UnitEnv (F.Block A1)--- Found a declaration to which we might want to insert a comment-perBlock inferReport s@(F.BlStatement a span@(FU.SrcSpan lp up) _-                               d@(F.StDeclaration _ _ _ _ decls)) = do-    vColEnv <- gets varColEnv-    let declNames = getNames (F.aStrip decls)-    if inferReport-      -- If we are just producing an inference report-      -- Then add to report and return the original statement-      then do-        -- Find all units associated to this declaration-        units <- mapM (\d -> findUnit d vColEnv) declNames-        mapM (\u -> fromMaybe (return ()) (fmap (\u -> report <<++ mkReport u) u)) units-        return s--      else do-        -- Otherwise, replace this node with a comment node-        -- which will get output by the reprint algorithm (along-        -- with the original statement node) *IFF* we haven't-        -- already got a declaration here-        hasDec <- gets hasDeclaration-        let findUnitIfUndec d | d `elem` hasDec = Nothing-                              | otherwise       = Just $ findUnit d vColEnv-        units <- sequence $ mapMaybe findUnitIfUndec declNames-        -- count-        (n, ad) <- gets evUnitsAdded-        evUnitsAdded =: (n + (length units), ad)-        -- Create comments for each-        let unitDecls = mapMaybe (fmap mkComment) units-        return $ (F.BlComment a' span0 (intercalate "\n" unitDecls))-    where-     -- Helper for making a report-     mkReport (var, unit) = show (spanLineCol span) ++ "\t" ++ mkInfo (var, unit)--     -- Helper for building unit specification-     mkInfo   (var, unit) = "unit (" ++ pprintUnitConstant unit  ++ ")"-                                    ++ " :: " ++ realName var-     -- Helper for building unit spec annotation comment-     mkComment (var, unit) = tabs ++ "!= " ++ mkInfo (var, unit)--     -- Calculate tab space sbased on start of declaration line-     tabs =  take (FU.posColumn lp  - 1) (repeat ' ')-     -- Create a zero-length span for the new comment node-     span0 = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0})--     -- Create new annotation which labels this as a refactored node-     ap = (prevAnnotation (FA.prevAnnotation a)) { refactored = Just loc }-     a' = a {FA.prevAnnotation = (FA.prevAnnotation a) { prevAnnotation = ap }}--     -- Start source loc-     loc  = fst $ O.srcSpanToSrcLocs span--     -- Helper for calculating the real names (not gensymed ones)-     realName v = v `fromMaybe` (v `M.lookup` ?nameMap)--     -- Lookup the unit for a variable-     findUnit v colEnv =-        case lookupWithoutSrcSpan v colEnv of-          Just (VarCol m, _) -> do u <- lookupUnit m-                                   case u of-                                     Nothing -> return Nothing-                                     Just u  -> return $ Just (v, u)-          Nothing            -> return $ Nothing--     -- All names being declared by this declaration statement-     getNames ds =-          [FA.varName e | (F.DeclVariable _ _ e@(F.ExpValue {}) _ _)-             <- universeBi ds :: [F.Declarator A1]]-       ++ [FA.varName e | (F.DeclArray _ _ e@(F.ExpValue {}) _ _ _)-             <- universeBi ds :: [F.Declarator A1]]--perBlock _ b = return b+-- | Insert unit declarations into the ProgramFile as comments.+runSynthesis :: [(String, UnitInfo)] -> UnitSolver [(String, UnitInfo)]+runSynthesis vars = do+  modifyProgramFileM $ descendBiM (synthBlocks vars)   -- descendBiM finds the head of lists+  return vars --- Turn the internal representation into a user-readable spec-pprintUnitConstant :: UnitConstant -> String-pprintUnitConstant (UnitlessC 1) = "1"-pprintUnitConstant (UnitlessC r) = "1**(" ++ show r ++")"-pprintUnitConstant (Unitful ucs)  =-     numeratorU-  ++ (if not (null ucsNeg') then " / " else "")-  ++ denominatorU-  where numeratorU = if (null ucsPos) then "1" else numeratorA-        numeratorA = intercalate " " (map (uncurry pprintPow) ucsPos)-        denominatorU = intercalate " " (map (uncurry pprintPow) ucsNeg')-        ucsNeg' = map (\(n, r) -> (n, abs r)) ucsNeg-        (ucsNeg, ucsPos) = break ((>0) . snd) ucs'-        ucs' = sortBy (compare `on` snd) ucs-        pprintPow n 1 = n-        pprintPow n r = n ++ "**" ++ show' r-        show' r =-          if denominator r == 1-          then show $ numerator r-          else '(' : (show $ numerator r) ++ '/' : (show $ denominator r) ++ ")"+-- Should be invoked on the beginning of a list of blocks+synthBlocks :: [(String, UnitInfo)] -> [F.Block UA] -> UnitSolver [F.Block UA]+synthBlocks vars = fmap reverse . foldM (synthBlock vars) [] -lookupUnit :: Col -> State UnitEnv (Maybe UnitConstant)-lookupUnit m = do-    -- m is the column corresopnding to the variable for which-    -- we are looking up the unit-    system@(matrix, vector)  <- gets linearSystem-    ucats   <- gets unitVarCats-    badCols <- gets underdeterminedCols-    vColEnv <- gets varColEnv-    let n = find (\n -> matrix ! (n, m) /= 0) [1 .. nrows matrix]-    let defaultUnit = if ucats !! (m - 1) == Argument then Nothing else Just (Unitful [])-    return $ maybe defaultUnit (lookupUnit' ucats badCols system m) n+-- Process an individual block while building up a list of blocks (in+-- reverse order) to ultimately replace the original list of+-- blocks. We're looking for blocks containing declarations, in+-- particular, in order to possibly insert a unit annotation before+-- them.+synthBlock :: [(String, UnitInfo)] -> [F.Block UA] -> F.Block UA -> UnitSolver [F.Block UA]+synthBlock vars bs b@(F.BlStatement a ss@(FU.SrcSpan lp up) _ (F.StDeclaration _ _ _ _ decls)) = do+  pf    <- usProgramFile `fmap` get+  nMap  <- uoNameMap `fmap` ask+  gvSet <- usGivenVarSet `fmap` get+  newBs <- fmap catMaybes . forM (universeBi decls) $ \ e -> case e of+    e@(F.ExpValue _ _ (F.ValVariable _))+      | name `S.notMember` gvSet            -- not a member of the already-given variables+      , Just u <- lookup name vars -> do    -- and a unit has been inferred+        -- Pick the start source loc from the existing decl.+        let loc   = fst $ O.srcSpanToSrcLocs ss+        -- Create new annotation which labels this as a refactored node.+        let newA  = a { FA.prevAnnotation = (FA.prevAnnotation a) {+                           prevAnnotation = (prevAnnotation (FA.prevAnnotation a)) {+                               refactored = Just loc } } }+        -- 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   = "= " ++ showUnitDecl nMap (e, u)+        let space = FU.posColumn lp - 1+        let newB  = F.BlComment newA newSS . insertSpacing space $ commentText pf txt+        return $ Just newB+      where+        name = FA.varName e+    (e :: F.Expression UA) -> return Nothing+  return (b:reverse newBs ++ bs)+synthBlock _ bs b = return (b:bs) -lookupUnit' :: [UnitVarCategory] -> [Int] -> LinearSystem -> Int -> Int -> Maybe UnitConstant-lookupUnit' ucats badCols (matrix, vector) m n-  | not $ null ms = Nothing-  | ucats !! (m - 1) /= Argument && m `notElem` badCols = Just $ vector !! (n - 1)-  | ms' /= [m] = Nothing-  | otherwise = Just $ vector !! (n - 1)-  where ms = filter significant [1 .. ncols matrix]-        significant m' = m' /= m && matrix ! (n, m') /= 0 && ucats !! (m' - 1) == Argument-        ms' = filter (\m -> matrix ! (n, m) /= 0) [1 .. ncols matrix]+-- Insert the correct comment markers around the given text string, depending on Fortran version.+-- FIXME: use Fortran meta information when I have finished adding it to ProgramFile.+commentText :: F.ProgramFile UA -> String -> String+commentText _ text = "!" ++ text -lineCol :: FU.Position -> (Int, Int)-lineCol p  = (fromIntegral $ FU.posLine p, fromIntegral $ FU.posColumn p)+-- Insert a given amount of spacing before the string.+insertSpacing :: Int -> String -> String+insertSpacing n = (replicate n ' ' ++) -spanLineCol :: FU.SrcSpan -> ((Int, Int), (Int, Int))-spanLineCol (FU.SrcSpan l u) = (lineCol l, lineCol u)+-- Pretty print a unit declaration.+showUnitDecl nameMap (e, u) = "unit(" ++ show u ++ ") :: " ++ (v `fromMaybe` M.lookup v nameMap)+  where v = FA.varName e

@@ -41,7 +41,7 @@ type TCommon p = (Maybe String, [(Variable, Type p)])  -- Typed and "located" common block representation--- TODO: include column + line information +-- TODO: include column + line information type TLCommon p = (Filename, (String, TCommon p))  -- Top-level functions for eliminating common blocks in a set of files@@ -51,26 +51,26 @@ commonElimToModules d ps = let (ps', (r, cg)) = runState (analyseCommons ps) ("", [])                                (r', ps'') = introduceModules d cg                                psR = updateUseDecls ps' cg-                           in  (r ++ r', psR ++ ps'') +                           in  (r ++ r', psR ++ ps'')   -analyseCommons :: [(Filename, Program A)] -> State (Report, [TLCommon A]) [(Filename, Program A)] -analyseCommons pss = let +analyseCommons :: [(Filename, Program A)] -> State (Report, [TLCommon A]) [(Filename, Program A)]+analyseCommons pss = let                           defs' :: Filename -> ProgUnit A -> State (Report, [TLCommon A]) (ProgUnit A)                           defs' fname p = case (getSubName p) of                                             Just pname -> transformBiM (collectCommons fname pname) p-                                            Nothing -> case p of -                                                         IncludeProg a sp ds f -> +                                            Nothing -> case p of+                                                         IncludeProg a sp ds f ->                                                             -- ("doing an include: " ++ (show fname)) `trace`                                                             let -- create dummy block                                                                 a0 = unitAnnotation-                                                                b = Block a (UseBlock (UseNil a0) nullLoc) +                                                                b = Block a (UseBlock (UseNil a0) nullLoc)                                                                             (ImplicitNull a0) sp ds                                                                             (NullStmt a0 nullSpan)                                                              in do (Block _ _ _ _ ds' _) <- transformBiM (collectCommons fname fname) b                                                                    return $ IncludeProg a sp ds' f-                                                         otherwise -> return p +                                                         otherwise -> return p                           -- defs' f (Sub _ _ _ (SubName _ n) _ b) rs = (concat rs) ++ [(f, (n, snd $ runState (collectTCommons' b) []))]                           -- Don't support functions yet                           -- defs' f (Function _ _ _ (SubName _ n) _ _ b) rs = (concat rs) ++ [(f, (n, snd $ runState (collectTCommons b) []))]@@ -80,11 +80,11 @@                                               return (f, ps')) pss  collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A)-collectCommons fname pname b = +collectCommons fname pname b =     let tenv = typeEnv b-                    +         commons' :: Decl A -> State (Report, [TLCommon A]) (Decl A)-        commons' f@(Common a sp cname exprs) = +        commons' f@(Common a sp cname exprs) =             do let r' = (show $ srcLineCol $ fst sp) ++ ": removed common declaration\n"                (r, env) <- get                put (r ++ r', (fname, (pname, (cname, typeCommonExprs exprs))):env)@@ -93,13 +93,13 @@          typeCommonExprs :: [Expr Annotation] -> [(Variable, Type Annotation)]         typeCommonExprs [] = []-        typeCommonExprs ((Var _ sp [(VarName _ v, _)]):es) = +        typeCommonExprs ((Var _ sp [(VarName _ v, _)]):es) =             case (tenvLookup v tenv) of                  Just t -> (v, t) : (typeCommonExprs es)                  Nothing -> error $ "Variable " ++ (show v) ++ " is of an unknown type at: " ++ show sp         typeCommonExprs (e:_) = error $ "Not expecting a non-variable expression in expression at: " ++ show (srcSpan e) -    in transformBiM commons' b            +    in transformBiM commons' b  {- Comparison functions for common block names and variables -} cmpTLConFName :: TLCommon A -> TLCommon A -> Ordering@@ -131,18 +131,18 @@  -- Freshen the names for a common block and generate a renamer from the old block to this freshenCommonNames :: TLCommon A -> (TLCommon A, RenamerCoercer)-freshenCommonNames (fname, (pname, (cname, fields))) = +freshenCommonNames (fname, (pname, (cname, fields))) =         let mkRenamerAndCommon (r, tc) (v, t) =                            let v' = (caml $ commonName cname) ++ "_" ++ v-                           in (Data.Map.insert v (Just v', Nothing) r, (v', t) : tc) +                           in (Data.Map.insert v (Just v', Nothing) r, (v', t) : tc)             (r, fields') = foldl mkRenamerAndCommon (Data.Map.empty, []) fields         in ((fname, (pname, (cname, fields'))), Just r) --- From a list of typed and located common blocks +-- From a list of typed and located common blocks -- group by the common block name, and then group/sort within such that the "mode" block is first groupSortCommonBlock :: [TLCommon A] -> [[[TLCommon A]]] groupSortCommonBlock commons = let -- Group by names of the common blocks-                                  gcs = groupBy (\x y -> cmpEq $ cmpTLConBNames x y) commons +                                  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                               in gccs@@ -158,7 +158,7 @@                                  -- a renamer between this and every module                                  gcrcs = map (\grp -> -- grp are block decls all for the same block                                                  let (com, r) = freshenCommonNames (head (head grp))-                                                 in  map (\c -> (c, r)) (head grp) ++ +                                                 in  map (\c -> (c, r)) (head grp) ++                                                      map (\c -> (c, mkRenamerCoercerTLC c com)) (concat $ tail grp)) gccs                                  -- Now re-sort based on the file and program unit                                  gcrcs' = sortBy (cmpFst cmpTLConFName) (sortBy (cmpFst cmpTLConPName) (concat gcrcs))@@ -166,8 +166,8 @@   updateUseDecls :: [(Filename, Program A)] -> [TLCommon A] -> [(Filename, Program A)]-updateUseDecls fps tcs = -      let tcrs = mkTLCommonRenamers tcs +updateUseDecls fps tcs =+      let tcrs = mkTLCommonRenamers tcs            concatUses :: Uses A -> Uses A -> Uses A           concatUses (UseNil p) y      = y@@ -181,14 +181,14 @@           importIncludeCommons p = foldl (\p' iname -> ("Iname = " ++ iname) `trace` matchPUnitAlt iname p') p (reduceCollect inames p)            matchPUnitAlt :: Filename -> ProgUnit A -> ProgUnit A-          matchPUnitAlt fname p = ("fname = " ++ fname ++ "\n" ++ (show ((lookups' fname) (lookups' fname tcrs)))) `trace` +          matchPUnitAlt fname p = ("fname = " ++ fname ++ "\n" ++ (show ((lookups' fname) (lookups' fname tcrs)))) `trace`                                 let tcrs' = (lookups' fname) (lookups' fname tcrs)                                     srcloc = useSrcLoc p                                     uses = mkUseStatements srcloc tcrs'                                     p' = transformBi ((flip concatUses) uses) p                                 in let ?fname = fname in removeDecls (map snd tcrs') p' -                                      +           matchPUnit :: Filename -> ProgUnit A -> ProgUnit A           matchPUnit fname p = let pname = case getSubName p of                                               Nothing -> fname -- If no subname is available, use the filename@@ -198,7 +198,7 @@                                    uses = mkUseStatements srcloc tcrs'                                    p' = transformBi ((flip concatUses) uses) p                                in let ?fname = fname in removeDecls (map snd tcrs') p'-                                                +           -- Given the list of renamed/coercerd variables form common blocks, remove any declaration sites           removeDecls :: (?fname :: Filename) => [RenamerCoercer] -> ProgUnit A -> ProgUnit A           removeDecls rcs p = let (p', remainingAssignments) = runState (transformBiM (removeDecl rcs) p) []@@ -207,34 +207,34 @@           -- Removes a declaration and collects a list of any default values given at declaration time           -- (which then need to be turned into separate assignment statements)           removeDecl :: (?fname :: Filename) => [RenamerCoercer] -> Decl A -> State [Fortran A] (Decl A)-          removeDecl rcs d@(Decl p srcP vars typ) = -               (modify (++ assgns)) >> (return $ if (vars' == []) then  NullDecl p' srcP +          removeDecl rcs d@(Decl p srcP vars typ) =+               (modify (++ assgns)) >> (return $ if (vars' == []) then  NullDecl p' srcP                                                                   else  Decl p' srcP vars' typ)                where-                   (assgns, vars') = foldl matchVar ([],[]) vars +                   (assgns, vars') = foldl matchVar ([],[]) vars                    p'    = if (length vars == length vars') then p else p { refactored = Just (fst srcP) } -                   matchVar :: ([Fortran A], [(Expr A, Expr A, Maybe Int)]) +                   matchVar :: ([Fortran A], [(Expr A, Expr A, Maybe Int)])                              -> (Expr A, Expr A, Maybe Int)                             -> ([Fortran A], [(Expr A, Expr A, Maybe Int)])-                   matchVar (assgns, decls) dec@(lvar@(Var _ _ [(VarName _ v, _)]), e, _) = +                   matchVar (assgns, decls) dec@(lvar@(Var _ _ [(VarName _ v, _)]), e, _) =                                  if (hasRenaming v rcs) then                                     case e of                                      -- Renaming exists and no default, then remove-                                        NullExpr _ _ -> (assgns, decls)  +                                        NullExpr _ _ -> (assgns, decls)                                      -- Renaming exists but has default, so create an assignment for this                                         e            -> ((Assg p' srcP lvar e) : assgns, decls)                                  else -- no renaming, preserve declaration                                        (assgns, dec : decls)                    matchVar (assgns, decls) _ = (assgns, decls)           removeDecl _ d = return d-                     +        in each fps (\(f, p) -> (f, map importIncludeCommons $ transformBi (matchPUnit f) p))  -- Adds additional statements to the start of the statement block in a program unit addToProgUnit :: ProgUnit A -> [Fortran A] -> ProgUnit A addToProgUnit p [] = p-addToProgUnit (IncludeProg p sp decl Nothing) stmts = IncludeProg p sp decl (Just $ +addToProgUnit (IncludeProg p sp decl Nothing) stmts = IncludeProg p sp decl (Just $                                                            prependStatements (Just $ afterEnd sp) (NullStmt unitAnnotation (afterEnd sp)) stmts) addToProgUnit (IncludeProg p sp decl (Just f)) stmts = IncludeProg p sp decl (Just $ prependStatements Nothing f stmts) addToProgUnit p stmts = transformBi (flip addToBlock stmts) p@@ -248,7 +248,7 @@ prependStatements :: Maybe SrcSpan -> Fortran A -> [Fortran A] -> Fortran A prependStatements sp stmt ss = FSeq p' sp' (foldl1 (FSeq p' sp') ss) stmt                                   where p' = (annotation stmt) { refactored = Just (fst sp') }-                                        sp' = case sp of +                                        sp' = case sp of                                                 Nothing -> srcSpan stmt                                                 Just s  -> s @@ -256,7 +256,7 @@ useSrcLoc (Main _ _ _ _ b _)      = useSrcLocB b useSrcLoc (Sub _ _ _ _ _ b)       = useSrcLocB b useSrcLoc (Function _ _ _ _ _ _ b)= useSrcLocB b-useSrcLoc (Module _ s _ _ _ _ _)  = fst s -- TOOD: this isn't very accurate +useSrcLoc (Module _ s _ _ _ _ _)  = fst s -- TOOD: this isn't very accurate useSrcLoc (BlockData _ s _ _ _ _) = fst s useSrcLocB (Block _ (UseBlock _ s) _ _ _ _) = s @@ -269,7 +269,7 @@ -- make the use statements for a particular program unit's common blocks mkUseStatements :: SrcLoc -> [(TCommon A, RenamerCoercer)] -> Uses A mkUseStatements s [] = UseNil (unitAnnotation)-mkUseStatements s (((name, _), r):trs) = +mkUseStatements s (((name, _), r):trs) =                         let a = unitAnnotation { refactored = Just s, newNode = True } -- previously-- Just (toCol0 s)                         in Uses a (Use (commonName name) (renamerToUse r)) (mkUseStatements s trs) a @@ -282,7 +282,7 @@      | otherwise      = error "Can't generate renamer between different common blocks\n"                            where                              generate [] [] theta = theta-                             generate ((var1, ty1):vtys1) ((var2, ty2):vtys2) theta = +                             generate ((var1, ty1):vtys1) ((var2, ty2):vtys2) theta =                                  let varR = if (var1 == var2) then Nothing else Just var2                                      typR = if (ty1  ==  ty2) then Nothing else Just (ty1, ty2)                                  in generate vtys1 vtys2 (Data.Map.insert var1 (varR, typR) theta)@@ -296,20 +296,20 @@     if (n1 == n2) then          let  coherent ::  [(Variable, Type A)] -> [(Variable, Type A)] -> (Report, Bool)               coherent []               []                = ("", True)-              coherent ((var1, ty1):xs) ((var2, ty2):ys) +              coherent ((var1, ty1):xs) ((var2, ty2):ys)                       | af ty1 == af ty2 = let (r', c) = coherent xs ys                                            in (r', c && True)-                      | otherwise = let r = (var1 ++ ":" ++ (pprint ty1) ++ "(" ++ (show $ af ty1) ++ ")" ++ " differs from " ++ +                      | otherwise = let r = (var1 ++ ":" ++ (pprint ty1) ++ "(" ++ (show $ af ty1) ++ ")" ++ " differs from " ++                                              var2 ++ ":" ++ (pprint ty2) ++ "(" ++ (show $ af ty2) ++ ")" ++ "\n")                                         (r', _) = coherent xs ys                                     in (r ++ r', False)               coherent _ _ = ("Common blocks of different field lengths", False) -- Doesn't say which is longer-         in coherent vtys1 vtys2 +         in coherent vtys1 vtys2      else ("", True) -- Not sure if this is supposed to fail here- in retrospect I think no           -- False -> ("Trying to compare differently named common blocks: " ++ show n1 ++ " and " ++ show n2 ++ "\n", False) -introduceModules :: Directory -> [TLCommon A] -> (Report, [(Filename, Program A)]) +introduceModules :: Directory -> [TLCommon A] -> (Report, [(Filename, Program A)]) introduceModules d cenv = mapM (mkModuleFile d) (map (head . head) (groupSortCommonBlock cenv))  @@ -321,12 +321,11 @@         in (r, (fullpath, [mkModule modname varTys modname]))  mkModule :: String -> [(Variable, Type A)] -> String -> ProgUnit A-mkModule name vtys fname = +mkModule name vtys fname =                       let a = unitAnnotation { refactored = Just loc }-                          loc = SrcLoc (fname ++ ".f90") 0 0 +                          loc = SrcLoc (fname ++ ".f90") 0 0                           sp = (loc, loc)                           toDecl (v, t) = Decl a sp [(Var a sp [(VarName a (name ++ "_" ++ v), [])], NullExpr a sp, Nothing)] -- note here could pull in initialising definition? What if conflicts- highlight as potential source of error?                                                             t                           decls = foldl1 (DSeq a) (map toDecl vtys)                       in Module a (loc, loc) (SubName a fname) (UseNil a) (ImplicitNone a) decls []-

@@ -35,7 +35,6 @@  import Camfort.Analysis.Annotations import Camfort.Analysis.IntermediateReps-import Camfort.Analysis.Loops import Camfort.Analysis.Syntax import Camfort.Transformation.Syntax import Camfort.Analysis.Types

@@ -18,6 +18,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}  module Camfort.Traverse where @@ -44,6 +45,14 @@ import Data.Monoid  import Debug.Trace++#if __GLASGOW_HASKELL__ < 800+instance Monoid x => Monad ((,) x) where+    return a = (mempty, a)+    (x, a) >>= k = let (x', b) = k a+                   in (mappend x x', b)+#endif+  -- Data-type generic comonad-style traversal 

@@ -73,13 +73,13 @@          "show version number"      , Option ['e']     ["exclude"] (ReqArg Excludes "FILES")          "files to exclude (comma separated list, no spaces)"-     , Option ['s']     ["units-solver"]  (ReqArg (Solver . read) "ID")-         "units-of-measure solver. ID = Custom or LAPACK"      , 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 []        ["debug"] (NoArg Debug)+         "enable debug mode"      ]  compilerOpts :: [String] -> IO ([Flag], [String])@@ -113,10 +113,9 @@            , (FileOrDir -> [Filename] -> FileOrDir -> Options -> IO ()            , String))] analyses =-    [("asts", (asts,-        "blank analysis, outputs analysis files with AST information")),-     ("lva", (lvaA, "live-variable analysis")),-     ("loops", (loops, "loop information")),+    [--("asts", (asts,+--        "blank analysis, outputs analysis files with AST information")),+--     ("lva", (lvaA, "live-variable analysis")),      ("count", (countVarDecls, "count variable declarations")),      ("ast", (ast, "print the raw AST -- for development purposes")),      ("stencils-check", (stencilsCheck, "stencil spec checking")),@@ -129,7 +128,7 @@      ("units-synth", (unitsSynth, "unit-of-measure synthesise specs.")) ]  -- * Usage and about information-version = "0.802"+version = "0.804" introMsg = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure." usage = "Usage: camfort <MODE> <INPUT> [OUTPUT] [OPTIONS...]\n" menu =

@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Camfort.Analysis.CommentAnnotatorSpec (spec) where++import Test.Hspec++import Data.Data+import Data.Generics.Uniplate.Data+import Control.Monad.Writer.Strict++import Language.Fortran.AST+import Language.Fortran.ParserMonad+import Language.Fortran.Util.Position++import Camfort.Analysis.CommentAnnotator++p = SrcSpan (Position 0 1 1) (Position 0 1 1)++spec =+  describe "Comment annotator" $ do+    it "annotates with no comment blocks" $+      runWriter (annotateComments (\_ -> Right "") pf) `shouldBe` (pf, [])++    it "links & annotates single comment block" $+      runWriter (annotateComments (\_ -> Right "hello") pf2) `shouldBe` (pf2e, [])++    it "link multiple comments to single statement" $+      runWriter (annotateComments (\s -> Right $ "!!!" ++ s) pf3) `shouldBe` (pf3e, [])++    it "link comments to separate targets" $+      runWriter (annotateComments (\s -> Right $ "!!!" ++ s) 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." ])++data A = A+  { annLink :: Maybe (Block A)+  , annAST :: Maybe String }+  deriving (Data, Eq, Show)++instance ASTEmbeddable A String where+  annotateWithAST a str = a { annAST = Just str }++instance Linkable A where+  link a block = a { annLink = Just block }++-- Some helper functions+varGen x = ExpValue ea p (ValVariable x)+intGen i = ExpValue ea p (ValInteger (show i))+wrapBlocks bs = ProgramFile (MetaInfo { miVersion = Fortran90 }) [ ([], pu) ] []+  where+    pu = PUModule ea p "my_module" bs Nothing++-- Test cases++ea = A Nothing Nothing++pf = wrapBlocks bs+bs = [ BlStatement ea p Nothing (StPause ea p Nothing) ]++pf2 = wrapBlocks bs2+bs2 =+  [ BlComment ea p "something"+  , BlStatement ea p Nothing (StPause ea p Nothing) ]++pf2e = wrapBlocks bs2e+bs2e =+  [ BlComment (A (Just (bs2e !! 1)) (Just "hello")) p "something"+  , BlStatement ea p Nothing (StPause ea p Nothing) ]++pf3 = wrapBlocks bs3+bs3 =+  [ BlComment ea p "mistral"+  , BlComment ea p "orhan"+  , BlComment ea p "jean-pierre"+  , BlComment ea p "contrastin"+  , BlStatement ea p Nothing (StPause ea p Nothing) ]++pf3e = wrapBlocks bs3e+bs3e =+  [ BlComment (A (Just (last bs3e)) (Just "!!!mistral")) p "mistral"+  , BlComment (A (Just (last bs3e)) (Just "!!!orhan")) p "orhan"+  , BlComment (A (Just (last bs3e)) (Just "!!!jean-pierre")) p "jean-pierre"+  , BlComment (A (Just (last bs3e)) (Just "!!!contrastin")) p "contrastin"+  , BlStatement ea p Nothing (StPause ea p Nothing) ]++pf4 = wrapBlocks bs4+bs4 =+  [ BlComment ea p "mistral"+  , BlComment ea p "contrastin"+  , BlStatement ea p Nothing (StPause ea p Nothing)+  , BlComment ea p "dominic"+  , BlComment ea p "orchard"+  , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ]++pf4e = wrapBlocks bs4e+bs4e =+  [ BlComment (A (Just (bs4e !! 2)) (Just "!!!mistral")) p "mistral"+  , BlComment (A (Just (bs4e !! 2)) (Just "!!!contrastin")) p "contrastin"+  , BlStatement ea p Nothing (StPause ea p Nothing)+  , BlComment (A (Just (last bs4e)) (Just "!!!dominic")) p "dominic"+  , BlComment (A (Just (last bs4e)) (Just "!!!orchard")) p "orchard"+  , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ]++pf5 = wrapBlocks bs5+bs5 =+  [ BlComment ea p "comment 1"+  , BlComment ea p "comment 2"+  , BlStatement ea p Nothing (StPause ea p Nothing) ]++pf5e = wrapBlocks bs5e+bs5e =+  [ BlComment (A (Just (last bs5e)) Nothing) p "comment 1"+  , BlComment (A (Just (last bs5e)) Nothing) p "comment 2"+  , BlStatement ea p Nothing (StPause ea p Nothing) ]

@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}+module Camfort.Helpers.VecSpec where++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck (Arbitrary(..), Gen(..))++import Camfort.Helpers.Vec++instance Arbitrary a => Arbitrary (Vec Z a) where+      arbitrary = return Nil+instance (Arbitrary (Vec n a), Arbitrary a) => Arbitrary (Vec (S n) a) where+      arbitrary = do x  <- arbitrary :: Gen a+                     xs <- arbitrary :: Gen (Vec n a)+                     return $ Cons x xs++spec :: Spec+spec = +    describe "Vector" $+        it "TODO" +            pending

@@ -0,0 +1,88 @@+{-# LANGUAGE ImplicitParams #-}++module Camfort.Specification.Stencils.CheckSpec (spec) where++import Camfort.Analysis.CommentAnnotator+import Camfort.Specification.Stencils.Model+import Camfort.Specification.Stencils.CheckBackend+import Camfort.Specification.Stencils.CheckFrontend+import qualified Camfort.Specification.Stencils.Grammar as SYN+import Camfort.Specification.Stencils.Syntax++import Test.Hspec hiding (Spec)+import qualified Test.Hspec as Test++promoteErrors :: Either String x -> Either AnnotationParseError x+promoteErrors (Left x)  = Left (ProbablyAnnotation x)+promoteErrors (Right x) = Right x++parseAndConvert x = let ?renv = [] in SYN.specParser x >>= (promoteErrors . synToAst)+extract (Right (Right [(_, s)])) = s++spec :: Test.Spec+spec = describe "Stencils - Check" $ do+  it "parse and convert simple exact stencil (1)" $+      (parseAndConvert "= stencil forward(depth=1, dim=1) :: x")+      `shouldBe`+        (Right $ Right $ [(["x"], Specification $ Left $+         Exact (Spatial NonLinear (Sum [Product [Forward 1 1 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 $ Left $+         Exact (Spatial NonLinear (Sum [Product [Forward 1 1 True]])))])++  it "parse and convert simple exact stencil with irreflexive (2a)" $+      (parseAndConvert "= stencil centered(depth=1, dim=2, irreflexive) :: x, y, z")+      `shouldBe`+        (Right $ Right $ [(["x","y","z"], Specification $ Left $+         Exact (Spatial NonLinear (Sum [Product [Centered 1 2 False]])))])++  it "parse and convert simple exact stencil with irreflexive (2b)" $+     let ?dimensionality = 2 in+      ((extract $+        parseAndConvert "= stencil centered(depth=1, dim=2, irreflexive) :: x, y, z")+      `eqByModel`+      (Specification $ Left $ Exact (Spatial NonLinear+                                    (Sum [Product [Centered 1 2 False]]))))+       `shouldBe` True+++  it "parse and convert simple upper bounded stencil (3)" $+      (parseAndConvert "= stencil atmost, forward(depth=1, dim=1) :: x")+      `shouldBe`+        (Right $ Right $ [(["x"], Specification $ Left $+         Bound Nothing (Just $ Spatial NonLinear+                  (Sum [Product [Forward 1 1 True]])))])++  it "parse and convert simple lower bounded stencil (4)" $+      (parseAndConvert "= stencil atleast, backward(depth=2, dim=1) :: x")+      `shouldBe`+        (Right $ Right $ [(["x"], Specification $ Left $+         Bound (Just $ Spatial NonLinear+                  (Sum [Product [Backward 2 1 True]])) Nothing)])++{- This is no longer applicable+  it "parse and convert modified bounded stencil (4)" $+      (parseAndConvert "= stencil reflexive(dims=1), irreflexive(dims=2), centered(depth=1, dim=3) :: x")+      `shouldBe`+        (Right $ Right $ [(["x"], Specification $ Left $+         Exact (Spatial NonLinear [2] (Sum [Product [Centered 1 3]])))])+-}++  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")+      `shouldBe`+        (Right $ Right $ [(["frob"], Specification $ Left $+         Bound (Just $ Spatial Linear+                  (Sum [Product [Forward 1 1 True, Centered 1 2 True],+                        Product [Forward 1 1 True, Backward 3 4 True]])) Nothing)])++  it "parse and convert stencil with irreflexivity on a product(6)" $+     let ?dimensionality = 2 in+      ((extract $+        parseAndConvert "= stencil forward(depth=1, dim=2, irreflexive)*backward(depth=1,dim=1) :: x, y, z")+      `eqByModel`+      (Specification $ Left $ Exact (Spatial NonLinear+                                    (Sum [Product [Forward 1 2 False, Backward 1 1 True]]))))

@@ -0,0 +1,86 @@+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 reflexive stencil" $+      parse "= stencil reflexive(dims=1,2) :: a"+      `shouldBe`+        Right (SpecDec (Spatial [Reflexive [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, reflexive(dims=1,2), \+             \       forward(depth=1, dim=1) :: x"+      `shouldBe`+        Right (SpecDec (Spatial [AtLeast,Reflexive [1,2]] (Just $ Forward 1 1)) ["x"])++    it "basic stencil with reflexive and irreflexive" $+      parse "= stencil atleast, reflexive(dims=2),  \+            \        irreflexive(dims=1), forward(depth=1, dim=1) :: frob"+      `shouldBe`+        Right (SpecDec (Spatial [AtLeast, Irreflexive [1], Reflexive [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 "temporal" $+      parse "= stencil dependency(a,b,c,foo), mutual :: foo, bar"+      `shouldBe`+       Right (SpecDec (Temporal ["a","b","c","foo"] True) ["foo", "bar"])++{- Should no longer be possible+    it "complex stencil" $+      parse "= stencil atleast, reflexive(dims=1,2), readonce, \+            \ (forward(depth=1, dim=1) + r) * backward(depth=3, dim=4) \+            \ :: frob"+      `shouldBe`+       Right (SpecDec (Spatial [AtLeast,ReadOnce,Reflexive [1,2]]+             (Just $ And (Or (Forward 1 1) (Var "r")) (Backward 3 4))) ["frob"])++    it "invalid stencil (atLeast/atMost)" $+      parse "= stencil atleast, atmost, reflexive(dims=1,2), \+             \       forward(depth=1, dim=1) :: x"+      `shouldBe`+        (Left $ ProbablyAnnotation $+          "Conflicting modifiers: cannot use 'atLeast' and 'atMost' together")++    it "invalid stencil (reflexive/irreflexive on same dim)" $+      parse "= stencil atleast, irreflexive(dims=2), reflexive(dims=1,2), \+             \ forward(depth=1, dim=1) :: x"+      `shouldBe`+        (Left $ ProbablyAnnotation $+              "Conflicting modifiers: stencil marked as both\+              \ irreflexive and reflexive in dimensions = 2")+-}+++parse = specParser++-- Local variables:+-- mode: haskell+-- haskell-program-name: "cabal repl test-suite:spec"+-- End:

@@ -0,0 +1,135 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ImplicitParams #-}++module Camfort.Specification.Stencils.ModelSpec (spec) where++import Camfort.Helpers.Vec+import Camfort.Specification.Stencils+import Camfort.Specification.Stencils.Synthesis+import Camfort.Specification.Stencils.Model+import Camfort.Specification.Stencils.Syntax hiding (Spec)+import qualified Camfort.Specification.Stencils.Syntax as Syn++import Camfort.Analysis.Annotations+import qualified Language.Fortran.AST as F+import Language.Fortran.Util.Position++import Data.Bits+import Data.List+import Data.Map hiding (map)++import Test.Hspec+import Test.QuickCheck+import Test.Hspec.QuickCheck++spec :: Spec+spec = do+  describe "Stencils - Model" $ do+    describe "Test soundness of model 1" $ modelHasLeftInverse+    describe "Test soundness of model 2" $ modelHasApproxLeftInverse variations2+    describe "Test soundness of model 3" $ modelHasApproxLeftInverse variations3++  describe "Consistency of model with paper" $ do+    describe "Quickcheck" $ it "" $ property $ propPairwisePerm++    describe "Manual for absolute rep" $ do+      it "Check absolute rep (0)" $+                   (sort $ pp           [1,2,absoluteRep] [5,1,7])+        `shouldBe` (sort $ pairwisePerm [1,2,absoluteRep] [5,1,7])++      it "Check absolute rep (1)" $+                   (sort $ pp           [1,absoluteRep] [5,1])+        `shouldBe` (sort $ pairwisePerm [1,absoluteRep] [5,1])++      it "Check absolute rep (2)" $+                   (sort $ pp           [absoluteRep,2,absoluteRep] [absoluteRep,1,7])+        `shouldBe` (sort $ pairwisePerm [absoluteRep,2,absoluteRep] [absoluteRep,1,7])+++propPairwisePerm :: [Int] -> [Int] -> Bool+propPairwisePerm x y = if (length x == length y && length x < 16)+                         then (sort . nub $ pp x y)+                           == (sort . nub $ pairwisePerm x y)+                         else True++pp :: [Int] -> [Int] -> [[Int]]+pp x y =+ let n = length x+ in map (\i ->+     map (\j ->+          ((x !! j) `times` (not (testBit i j))+   `plus` ((y !! j) `times` testBit i j))+          ) [0..(n-1)]+       ) [0 :: Int .. ((2^n)-1)]+    where times x True = x+          times x False = 0+          plus x y = x + y+++variations :: [([[Int]], Syn.Result Spatial)]+variations =+  [ ([ [1], [0] ],+    Exact $ Spatial NonLinear (Sum [Product [Forward 1 1 True]]))++  , ([ [absoluteRep,1], [absoluteRep,0] ],+    Exact $ Spatial NonLinear (Sum [Product [Forward 1 2 True]]))++  , ([ [1,1], [0,1], [1,0], [0,0] ],+    Exact $ Spatial NonLinear (Sum [Product [Forward 1 1 True, Forward 1 2 True]]))++  , ([ [-1, 1], [0, 1] ],+    Exact $ Spatial NonLinear (Sum [Product [Backward 1 1 True, Forward 1 2 False]]))++  , ([ [-1], [0] ],+    Exact $ Spatial NonLinear (Sum [Product [Backward 1 1 True]]))++  , ([ [absoluteRep,-1], [absoluteRep,0] ],+    Exact $ Spatial NonLinear (Sum [Product [Backward 1 2 True]]))++  , ([ [-1,-1], [0,-1], [-1,0], [0,0] ],+    Exact $ Spatial NonLinear (Sum [Product [Backward 1 1 True, Backward 1 2 True]]))++  , ( [ [0,-1], [1,-1], [0,0], [1,0], [1,1], [0,1], [2,-1], [2,0], [2,1] ],+    Exact $ Spatial NonLinear+              (Sum [Product [ Forward 2 1 True, Centered 1 2 True ] ] ))++  , ( [ [-1,0], [-1,1], [0,0], [0,1], [1,1], [1,0], [-1,2], [0,2], [1,2] ],+    Exact $ Spatial NonLinear+              (Sum [Product [ Forward 2 2 True, Centered 1 1 True ] ] ))+ ]++variations2 :: [(Syn.Result [[Int]], Int, Syn.Result Spatial)]+variations2 =+  [+  -- Stencil which has some absolute component (not represented in the spec)+    (Exact [ [0, absoluteRep], [1, absoluteRep] ], 2,+    Exact $ Spatial NonLinear (Sum [Product [Forward 1 1 True]]))++ -- Spec on bounds+ ,  (Bound Nothing (Just $ [ [0, absoluteRep], [1, absoluteRep],+                             [2, absoluteRep] ]), 2,+     Bound Nothing+           (Just $ Spatial NonLinear (Sum [Product [Forward 2 1 True]])))+ ]++variations3 :: [(Syn.Result [[Int]], Int, Syn.Result Spatial)]+variations3 =+  [+ -- Spec on bounds+    (Bound Nothing (Just $ [ [0, absoluteRep, 0], [1, absoluteRep, 0],+                             [2, absoluteRep, 0],+                             [0, absoluteRep, 1], [1, absoluteRep, 1],+                             [2, absoluteRep, 1]]), 3,+     Bound Nothing+           (Just $ Spatial NonLinear (Sum [Product [Forward 1 3 True, Forward 2 1 True]])))+  ]++modelHasLeftInverse = mapM_ check (zip variations [0..])+  where check ((ixs, spec), n) = it ("("++show n++")") $ sort mdl `shouldBe` sort ixs+          where mdl = map fst . toList . fromExact . model $ spec++modelHasApproxLeftInverse vars = mapM_ check (zip vars [(0 :: Int)..])+  where check ((ixs, dims, spec), n) =+          it ("("++show n++")") $ mdl' `shouldBe` (fmap sort ixs)+            where mdl = let ?globalDimensionality = dims in mkModel spec+                  mdl' = fmap (sort . map fst . toList) mdl

@@ -0,0 +1,464 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++module Camfort.Specification.StencilsSpec (spec) where++import Control.Monad.Writer.Strict hiding (Sum, Product)+import Data.List++import Camfort.Functionality+import Camfort.Helpers.Vec+import Camfort.Specification.Stencils+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.Analysis.Annotations+import qualified Language.Fortran.AST as F+import Language.Fortran.Util.Position++import Data.Map.Strict (toList)+import qualified Data.IntMap as IM+import qualified Data.Set as S++import Test.Hspec+import Test.QuickCheck+import Test.Hspec.QuickCheck++spec :: Spec+spec =+  describe "Stencils" $ do+    describe "Idempotence of spanBounding" $ do+      it "(0)" $ property $ prop_spanBoundingIdem zeroN+      it "(1)" $ property $ prop_spanBoundingIdem oneN+      it "(2)" $ property $ prop_spanBoundingIdem twoN+      it "(3)" $ property $ prop_spanBoundingIdem threeN+      it "(4)" $ property $ prop_spanBoundingIdem fourN++    describe "Associativity of spanBounding" $ do+      it "(0)" $ property $ prop_spanBoundingAssoc zeroN+      it "(1)" $ property $ prop_spanBoundingAssoc oneN+      it "(2)" $ property $ prop_spanBoundingAssoc twoN+      it "(3)" $ property $ prop_spanBoundingAssoc threeN+      it "(4)" $ property $ prop_spanBoundingAssoc fourN++    describe "Un-permutable permutations on vectors" $ do+      it "(0)" $ property $ prop_perms_invertable zeroN+      it "(1)" $ property $ prop_perms_invertable oneN+      it "(2)" $ property $ prop_perms_invertable twoN+      it "(3)" $ property $ prop_perms_invertable threeN+      it "(4)" $ property $ prop_perms_invertable fourN++    describe "Some checks on containing spans" $ do+      it "(0)" $ containedWithin (Cons 1 (Cons 1 Nil), Cons 2 (Cons 2 Nil))+                          (Cons 0 (Cons 0 Nil), Cons 3 (Cons 3 Nil))+                  `shouldBe` True+      it "(1)" $ containedWithin (Cons 0 (Cons 0 Nil), Cons 3 (Cons 3 Nil))+                          (Cons 1 (Cons 1 Nil), Cons 2 (Cons 2 Nil))+                  `shouldBe` False+      it "(2)" $ containedWithin (Cons 2 (Cons 2 Nil), Cons 2 (Cons 2 Nil))+                          (Cons 1 (Cons 1 Nil), Cons 2 (Cons 2 Nil))+                  `shouldBe` True+      it "(3)" $ containedWithin (Cons 2 (Cons 2 Nil), Cons 3 (Cons 3 Nil))+                          (Cons 1 (Cons 1 Nil), Cons 2 (Cons 2 Nil))+                  `shouldBe` False+      it "(4)" $ containedWithin (Cons 2 Nil, Cons 2 Nil)+                                 (Cons 2 Nil, Cons 2 Nil)+                  `shouldBe` True+++    it "sorting on indices" $+      shouldBe (sort [ Cons 1 (Cons 2 (Cons 1 Nil))+                      , Cons 2 (Cons 2 (Cons 3 Nil))+                      , Cons 1 (Cons 3 (Cons 3 Nil))+                      , Cons 0 (Cons 3 (Cons 1 Nil))+                      , Cons 1 (Cons 0 (Cons 2 Nil))+                      , Cons 1 (Cons 1 (Cons 1 Nil))+                      , Cons 2 (Cons 1 (Cons 1 Nil)) ])+                ([ Cons 1 (Cons 1 (Cons 1 Nil))+                , Cons 2 (Cons 1 (Cons 1 Nil))+                , Cons 1 (Cons 2 (Cons 1 Nil))+                , Cons 0 (Cons 3 (Cons 1 Nil))+                , Cons 1 (Cons 0 (Cons 2 Nil))+                , Cons 2 (Cons 2 (Cons 3 Nil))+                , Cons 1 (Cons 3 (Cons 3 Nil))+                ] :: [Vec (S (S (S Z))) Int])++    it "composeRegions (1,0)-(1,0) span and (2,0)-(2,0) span" $+      shouldBe (composeConsecutiveSpans+                  (Cons 1 (Cons 0 Nil), Cons 1 (Cons 0 Nil))+                  (Cons 2 (Cons 0 Nil), Cons 2 (Cons 0 Nil)))+               ([(Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil))])++    it "composeRegions failing on (1,0)-(2,0) span and (4,0)-(5,0) span" $+      shouldBe (composeConsecutiveSpans+                  (Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil))+                  (Cons 4 (Cons 0 Nil), Cons 5 (Cons 0 Nil)))+               []++    it "composeRegions failing on (1,0)-(2,0) span and (3,1)-(3,1) span" $+      shouldBe (composeConsecutiveSpans+                  (Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil))+                  (Cons 3 (Cons 1 Nil), Cons 3 (Cons 1 Nil)))+               []++    it "five point stencil 2D" $+      -- Sort the expected value for the sake of easy equality+      shouldBe (inferMinimalVectorRegions fivepoint)+               (sort [ (Cons (-1) (Cons 0 Nil), Cons 1 (Cons 0 Nil))+                     , (Cons 0 (Cons (-1) Nil), Cons 0 (Cons 1 Nil)) ])++    it "seven point stencil 3D" $+      shouldBe+        (inferMinimalVectorRegions sevenpoint)+        (sort+           [ (Cons (-1) (Cons 0 (Cons 0 Nil)), Cons 1 (Cons 0 (Cons 0 Nil)))+           , (Cons 0 (Cons (-1) (Cons 0 Nil)), Cons 0 (Cons 1 (Cons 0 Nil)))+           , (Cons 0 (Cons 0 (Cons (-1) Nil)), Cons 0 (Cons 0 (Cons 1 Nil))) ])++    describe "Example stencil inferences" $ do+      it "five point stencil 2D" $+        (inferFromIndices $ VL fivepoint)+        `shouldBe`+         (exactSp $ Spatial Linear+                     (Sum [ Product [ Centered 0 1 True, Centered 1 2 True]+                          , Product [ Centered 0 2 True, Centered 1 1 True]+                          ]))++      it "seven point stencil 2D" $+        (inferFromIndices $ VL sevenpoint)+        `shouldBe`+          (exactSp $ Spatial Linear+                       (Sum [ Product [ Centered 0 1 True, Centered 0 2 True, Centered 1 3 True]+                            , Product [ Centered 0 1 True, Centered 0 3 True, Centered 1 2 True]+                            , Product [ Centered 0 2 True, Centered 0 3 True, Centered 1 1 True]+                            ]))++      it "five point stencil 2D with blip" $+         (inferFromIndices $ VL fivepointErr)+         `shouldBe`+          (exactSp $ Spatial Linear+                         (Sum [ Product [ Forward 1 1 True, Forward 1 2 True],+                                Product [ Centered 0 1 True, Centered 1 2 True],+                                Product [ Centered 0 2 True, Centered 1 1 True] ]))++      it "centered forward" $+         (inferFromIndices $ VL centeredFwd)+         `shouldBe`+          (exactSp $ Spatial Linear (Sum [ Product [ Forward 1 1 True+                                                  , Centered 1 2 True] ]))++    describe "2D stencil verification" $+      mapM_ (test2DSpecVariation (Neighbour "i" 0) (Neighbour "j" 0)) variations++    describe "2D stencil verification relative" $+      mapM_ (\(a, b, x, y) -> test2DSpecVariation a b (x, y)) variationsRel+++    describe "3D stencil verification" $+      mapM_ test3DSpecVariation variations3D++    describe ("Synthesising indexing expressions from offsets is inverse to" +++              "extracting offsets from indexing expressions; and vice versa") $+      it "isomorphism" $ property prop_extract_synth_inverse++    describe ("Inconsistent induction variable usage tests") $ do+      it "consistent (1) a(i,j) = b(i+1,j+1) + b(i,j)" $+        (indicesToSpec' ["i", "j"]+                        [Neighbour "i" 0, Neighbour "j" 0]+                        [[offsetToIx "i" 1, offsetToIx "j" 1],+                         [offsetToIx "i" 0, offsetToIx "j" 0]])+         `shouldBe` (Just $ Specification $ Left $ Exact+                       (Spatial Linear+                         (Sum [Product [Forward 1 1 False, Forward 1 2 False],+                               Product [Centered 0 1 True, Centered 0 2 True]])))+      it "consistent (2) a(i,c,j) = b(i,j+1) + b(i,j) \+                        \:: forward(depth=1,dim=2)*reflexive(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 $ Left $ Exact+                       (Spatial Linear+                         (Sum [Product [Forward 1 2 True, Centered 0 1 True]])))++      it "consistent (3) a(i+1,c,j) = b(j,i+1) + b(j,i) \+                        \:: backward(depth=1,dim=2)*reflexive(dim=1)" $+        (indicesToSpec' ["i", "j"]+                        [Neighbour "i" 1, Constant (F.ValInteger "0"), Neighbour "j" 0]+                        [[offsetToIx "j" 0, offsetToIx "i" 1],+                         [offsetToIx "j" 0, offsetToIx "i" 0]])+         `shouldBe` (Just $ Specification $ Left $ Exact+                       (Spatial Linear+                         (Sum [Product [Backward 1 2 True, Centered 0 1 True]])))++      it "consistent (4) a(i+1,j) = b(0,i+1) + b(0,i) \+                         \:: backward(depth=1,dim=2)" $+        (indicesToSpec' ["i", "j"]+                        [Neighbour "i" 1, Neighbour "j" 0]+                        [[offsetToIx "j" absoluteRep, offsetToIx "i" 1],+                         [offsetToIx "j" absoluteRep, offsetToIx "i" 0]])+         `shouldBe` (Just $ Specification $ Left $ Exact+                       (Spatial Linear+                         (Sum [Product [Backward 1 2 True]])))++      it "consistent (5) a(i) = b(i,i+1) \+                        \:: reflexive(dim=1)*forward(depth=1,dim=2,irreflexive)" $+        (indicesToSpec' ["i", "j"]+                        [Neighbour "i" 0]+                        [[offsetToIx "i" 0, offsetToIx "i" 1]])+         `shouldBe` (Just $ Specification $ Left $ Exact+                       (Spatial Linear+                         (Sum [Product [Forward 1 2 False,+                                        Centered 0 1 True]])))++      it "consistent (6) a(i) = b(i) + b(0) \+                        \:: reflexive(dim=1)" $+        (indicesToSpec' ["i", "j"]+                        [Neighbour "i" 0]+                        [[offsetToIx "i" 0], [offsetToIx "i" absoluteRep]])+         `shouldBe` (Just $ Specification $ Left $ Exact+                       (Spatial Linear+                         (Sum [Product [Centered 0 1 True]])))++      it "inconsistent (1) RHS" $+        (indicesToSpec' ["i", "j"]+                        [Neighbour "i" 0, Neighbour "j" 0]+                        [[offsetToIx "i" 1, offsetToIx "j" 1],+                         [offsetToIx "j" 0, offsetToIx "i" 0]])+         `shouldBe` Nothing++      it "inconsistent (2) RHS to LHS" $+        (indicesToSpec' ["i", "j"]+                        [Neighbour "i" 0]+                        [[offsetToIx "i" 1, offsetToIx "j" 1],+                         [offsetToIx "j" 0, offsetToIx "i" 0]])+         `shouldBe` Nothing++    -------------------------+    -- Some integration tests+    -------------------------++    let file = "tests/Camfort/Specification/Stencils/example2.f"+    program <- runIO $ readForparseSrcDir file []++    describe "integration test on inference for example2.f" $ do+      it "stencil infer" $+         (fst $ callAndSummarise (infer AssignMode) program)+           `shouldBe`+           "\ntests/Camfort/Specification/Stencils/example2.f\n\+            \((24,8),(24,53)) \tstencil readOnce, (reflexive(dim=1))*(centered(depth=1, dim=2)) \+                                     \+ (reflexive(dim=2))*(centered(depth=1, dim=1)) :: a\n\+            \((32,7),(32,26)) \tstencil readOnce, (backward(depth=1, dim=1)) :: a\n\+            \((40,8),(40,62)) \tstencil readOnce, (centered(depth=1, dim=1)) \+                                                \+ (centered(depth=1, dim=2)) :: a\n\+            \((41,8),(41,35)) \tstencil readOnce, (reflexive(dim=1))*(reflexive(dim=2)) :: a"++      it "stencil check" $+         (fst $ callAndSummarise (\f p -> (check f p, p)) program)+           `shouldBe`+           "\ntests/Camfort/Specification/Stencils/example2.f\n\+            \(24:8,24:53)\tCorrect.\n(32:7,32:26)\tCorrect."++    let file = "tests/Camfort/Specification/Stencils/example3.f"+    program <- runIO $ readForparseSrcDir file []++    -- describe "integration test on inference for example3.f" $ do+    --   it "stencil infer" $+    --      (fst $ callAndSummarise (infer AssignMode) program)+    --        `shouldBe`+    --         "\ntests/Camfort/Specification/Stencils/example3.f\n\+    --          \((15,2),(15,20)) \tstencil readOnce, (reflexive(dim=3)) :: a\n\+    --          \((20,8),(20,26)) \tstencil readOnce, (reflexive(dim=3)) :: a\n\+    --          \((23,7),(23,17)) \tstencil readOnce, (reflexive(dim=1)) :: d\n\+    --          \((24,7),(24,19)) \tstencil readOnce, (reflexive(dim=2)) :: a\n"++    let file = "tests/Camfort/Specification/Stencils/example4.f"+    program <- runIO $ readForparseSrcDir file []++    describe "integration test on inference for example4.f" $ do+      it "stencil infer" $+         (fst $ callAndSummarise (infer AssignMode) program)+           `shouldBe`+            "\ntests/Camfort/Specification/Stencils/example4.f\n\+             \((6,8),(6,33)) \tstencil (reflexive(dim=1)) :: x"+++exactSp = Specification . Left . Exact++{- Properties of `spanBoundingBox`: idempotent and associative -}+prop_spanBoundingIdem :: Natural n -> Span (Vec n Int) -> Bool+prop_spanBoundingIdem w x = spanBoundingBox x x == normaliseSpan x++prop_spanBoundingAssoc :: Natural n -> Span (Vec n Int)+                                    -> Span (Vec n Int)+                                    -> Span (Vec n Int) -> Bool+prop_spanBoundingAssoc w x y z =+  (==) (spanBoundingBox x (spanBoundingBox y z))+       (spanBoundingBox (spanBoundingBox x y) z)++{- Permutations that come with 'unpermute' functions are invertable -}+prop_perms_invertable :: (Permutable n) => Natural n -> Vec n Int -> Bool+prop_perms_invertable w xs =+  replicate (fact (lengthV xs)) xs == map (\(xs, f) -> f xs) (permutationsV xs)+  where+    fact 0 = 1+    fact n = n * fact (n - 1)++zeroN  = Zero+oneN   = Succ zeroN+twoN   = Succ oneN+threeN = Succ twoN+fourN  = Succ threeN++-- 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)+            ]+-- Indices for the 3D seven point stencil+sevenpoint = [ Cons (-1) (Cons 0 (Cons 0 Nil)), Cons 0 (Cons (-1) (Cons 0 Nil))+             , Cons 0 (Cons 0 (Cons 1 Nil)), Cons 0 (Cons 1 (Cons 0 Nil))+             , Cons 1 (Cons 0 (Cons 0 Nil)), Cons 0 (Cons 0 (Cons (-1) Nil))+             , Cons 0 (Cons 0 (Cons 0 Nil))+             ]+centeredFwd = [ Cons 1 (Cons 0 Nil), Cons 0 (Cons 1 Nil), Cons 0 (Cons (-1) Nil)+              , Cons 1 (Cons 1 Nil), Cons 0 (Cons 0 Nil), Cons 1 (Cons (-1) Nil)+              ] :: [ Vec (S (S Z)) Int ]++-- Examples of unusal patterns+fivepointErr = [ 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)+               , Cons 1 (Cons 1 Nil) ] :: [ Vec (S (S Z)) Int ]++{- Construct arbtirary vectors and test up to certain sizes -}+instance Arbitrary a => Arbitrary (Vec Z a) where+    arbitrary = return Nil++instance (Arbitrary (Vec n a), Arbitrary a) => Arbitrary (Vec (S n) a) where+    arbitrary = do x  <- arbitrary+                   xs <- arbitrary+                   return $ Cons x xs++test2DSpecVariation a b (input, expectation) =+    it ("format=" ++ show input) $ do++       -- Test inference+       (indicesToSpec' ["i", "j"]+                       [a, b]+                       (map fromFormatToIx input))+          `shouldBe` Just expectedSpec+  where+    expectedSpec = Specification . Left $ expectation+    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)++variations =+  [ ( [ [0,0] ]+    , Exact $ Spatial Linear (Sum [Product [ Centered 0 1 True, Centered 0 2 True]])+    )+  , ( [ [1,0] ]+    , Exact $ Spatial Linear (Sum [Product [Forward 1 1 False, Centered 0 2 True]])+    )+  , ( [ [1,0], [0,0], [0,0] ]+    , Exact $ Spatial NonLinear (Sum [Product [Forward 1 1 True, Centered 0 2 True]])+    )+  , ( [ [0,1], [0,0] ]+    , Exact $ Spatial Linear (Sum [Product [Forward 1 2 True, Centered 0 1 True]])+    )+  , ( [ [1,1], [0,1], [1,0], [0,0] ]+    , Exact $ Spatial Linear (Sum [Product [Forward 1 1 True, Forward 1 2 True]])+    )+  , ( [ [-1,0], [0,0] ]+    , Exact $ Spatial Linear (Sum [Product [Backward 1 1 True, Centered 0 2 True]])+    )+  , ( [ [0,-1], [0,0], [0,-1] ]+    , Exact $ Spatial NonLinear (Sum [Product [Backward 1 2 True, Centered 0 1 True]])+    )+  , ( [ [-1,-1], [0,-1], [-1,0], [0,0], [0, -1] ]+    , Exact $ Spatial NonLinear (Sum [Product [Backward 1 1 True, Backward 1 2 True]])+    )+  , ( [ [0,-1], [1,-1], [0,0], [1,0], [1,1], [0,1] ]+    , Exact $ Spatial Linear $ Sum [ Product [ Forward 1 1 True, Centered 1 2 True] ]+    )+   -- Stencil which is non-contiguous in one direction+  , ( [ [0, 4], [1, 4] ]+    , Bound (Just (Spatial Linear (Sum [Product [Forward 1 1 True]])))+            (Just (Spatial Linear (Sum [Product [Forward 1 1 True, Forward 4 2 True]])))+    )+  ]++variationsRel =+  [   -- Stencil which has non-relative indices in one dimension+    (Neighbour "i" 0, Constant (F.ValInteger "0"), [ [0, absoluteRep], [1, absoluteRep] ]+    , Exact $ Spatial Linear (Sum [Product [Forward 1 1 True]])+    )+  , (Neighbour "i" 1, Neighbour "j" 0, [ [0,0] ]+    , Exact $ Spatial Linear (Sum [Product [ Backward 1 1 False, Centered 0 2 True]])+    )+  , (Neighbour "i" 0, Neighbour "j" 1, [ [0,1] ]+    , Exact $ Spatial Linear (Sum [Product [Centered 0 1 True, Centered 0 2 True]])+    )+  , (Neighbour "i" 1, Neighbour "j" (-1), [ [1,0], [0,0], [0,0] ]+    , Exact $ Spatial NonLinear (Sum [Product [Forward 1 2 False, Backward 1 1 True]])+    )+  , (Neighbour "i" 0, Neighbour "j" (-1), [ [0,1], [0,0] ]+    , Exact $ Spatial Linear (Sum [Product [Forward 2 2 False, Centered 0 1 True]])+    )+  -- [0,1] [0,0] [0,-1]+  , (Neighbour "i" 1, Neighbour "j" 0, [ [1,1], [1,0], [1,-1] ]+    , Exact $ Spatial Linear (Sum [Product [Centered 0 1 True, Centered 1 2 True]])+    )+  , (Neighbour "i" 1, Neighbour "j" 0, [ [-2,0], [-1,0] ]+    , Bound (Just (Spatial Linear (Sum [Product [Centered 0 2 True]])))+            (Just (Spatial Linear (Sum [Product [Backward 3 1 True, Centered 0 2 True]]))))++  , (Constant (F.ValInteger "0"), Neighbour "j" 0, [ [absoluteRep,1], [absoluteRep,0], [absoluteRep,-1] ]+    , Exact $ Spatial Linear (Sum [Product [Centered 1 2 True]])+    )+  ]++test3DSpecVariation (input, expectation) =+    it ("format=" ++ show input) $ do++      -- Test inference+      (indicesToSpec' ["i", "j", "k"]+                      [Neighbour "i" 0, Neighbour "j" 0, Neighbour "k" 0]+                      (map fromFormatToIx input))+           `shouldBe` Just expectedSpec++  where+    expectedSpec = Specification . Left $ expectation+    fromFormatToIx [ri,rj,rk] =+      [offsetToIx "i" ri, offsetToIx "j" rj, offsetToIx "k" rk]+++variations3D =+  [ ( [ [-1,0,-1], [0,0,-1], [-1,0,0], [0,0,0] ]+    ,  Exact $ Spatial Linear (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]])+    )+  , ( [ [1,1,0], [0,1,0] ]+    ,  Exact $ Spatial Linear (Sum [Product [Forward 1 1 True, Forward 1 2 False, Centered 0 3 True]])+    )+  , ( [ [-1,0,-1], [0,0,-1], [-1,0,0], [0,0,0] ]+    ,  Exact $ Spatial Linear (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]])+    )+  ]++prop_extract_synth_inverse :: F.Name -> Int -> Bool+prop_extract_synth_inverse v o =+     ixToNeighbour' [v] (offsetToIx v o) == Neighbour v o++-- Local variables:+-- mode: haskell+-- haskell-program-name: "cabal repl test-suite:spec"+-- End:

@@ -0,0 +1,127 @@+{-# LANGUAGE ImplicitParams #-}+module Camfort.Specification.UnitsSpec (spec) where++import qualified Data.ByteString.Char8 as B++import Camfort.Input+import Camfort.Functionality+import Camfort.Output+import Camfort.Specification.Units+import Camfort.Specification.Units.InferenceBackend+import Camfort.Specification.Units.Environment+import Data.List+import Data.Maybe+import qualified Data.Array as A+import qualified Numeric.LinearAlgebra as H+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 Test.Hspec+import Test.QuickCheck+import Test.Hspec.QuickCheck++spec :: Spec+spec = do+  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",UnitVar "e"]+      it "testCons4" $ do+        criticalVariables testCons4 `shouldBe` [UnitVar "simple2_a22"]+      it "testCons5" $ do+        criticalVariables testCons5 `shouldSatisfy` null+    describe "Infer Variables" $ do+      it "testCons5" $ do+        inferVariables testCons5 `shouldBe` testCons5_infer++--------------------------------------------------++testCons1 = [ ConEq (UnitName "kg") (UnitName "m")+            , ConEq (UnitVar "x") (UnitName "m")+            , ConEq (UnitVar "y") (UnitName "kg")]++testCons1_flattened = [([UnitPow (UnitName "kg") 1.0],[UnitPow (UnitName "m") 1.0])+                      ,([UnitPow (UnitVar "x") 1.0],[UnitPow (UnitName "m") 1.0])+                      ,([UnitPow (UnitVar "y") 1.0],[UnitPow (UnitName "kg") 1.0])]++testCons1_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "kg") (-1.0)])+                    ,([UnitPow (UnitVar "x") 1.0],[UnitPow (UnitName "m") 1.0])+                    ,([UnitPow (UnitVar "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") (UnitAlias "accel")+            ,ConEq (UnitVar "simple1_t4") (UnitName "s")+            ,ConEq (UnitVar "simple1_v3") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0)))+            ,ConEq (UnitVar "simple1_x1") (UnitName "m")+            ,ConEq (UnitVar "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") 1.0,UnitPow (UnitAlias "accel") (-1.0)],[])+                    ,([UnitPow (UnitVar "simple1_t4") 1.0],[UnitPow (UnitName "s") 1.0])+                    ,([UnitPow (UnitVar "simple1_v3") 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0)])+                    ,([UnitPow (UnitVar "simple1_x1") 1.0],[UnitPow (UnitName "m") 1.0])+                    ,([UnitPow (UnitVar "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") (UnitVar "e")+            , ConEq (UnitVar "a") (UnitMul (UnitVar "b") (UnitMul (UnitVar "c") (UnitVar "d")))+            , ConEq (UnitVar "d") (UnitName "m") ]++testCons3_shifted = [([UnitPow (UnitVar "a") 1.0,UnitPow (UnitVar "e") (-1.0)],[])+                    ,([UnitPow (UnitVar "a") 1.0,UnitPow (UnitVar "b") (-1.0),UnitPow (UnitVar "c") (-1.0),UnitPow (UnitVar "d") (-1.0)],[])+                    ,([UnitPow (UnitVar "d") 1.0],[UnitPow (UnitName "m") 1.0])]++testCons4 = [ConEq (UnitVar "simple2_a11") (UnitParamPosUse ("simple2_sqr3",0,0))+            ,ConEq (UnitVar "simple2_a22") (UnitParamPosUse ("simple2_sqr3",1,0))+            ,ConEq (UnitVar "simple2_a11") (UnitVar "simple2_a11")+            ,ConEq (UnitVar "simple2_a22") (UnitVar "simple2_a22")+            ,ConEq (UnitParamPosUse ("simple2_sqr3",0,0)) (UnitMul (UnitParamPosUse ("simple2_sqr3",1,0)) (UnitParamPosUse ("simple2_sqr3",1,0)))]++testCons5 = [ConEq (UnitVar "simple2_a11") (UnitParamPosUse ("simple2_sqr3",0,0))+            ,ConEq (UnitAlias "accel") (UnitParamPosUse ("simple2_sqr3",1,0))+            ,ConEq (UnitVar "simple2_a11") (UnitVar "simple2_a11")+            ,ConEq (UnitVar "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",UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0)))+                  ,("simple2_a22",UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))]

@@ -0,0 +1,42 @@+module Camfort.Transformation.CommonSpec (spec) where++import System.FilePath+import System.Directory++import Test.Hspec++import Camfort.Helpers+import Camfort.Functionality++samplesBase :: FilePath+samplesBase = "tests" </> "Camfort" </> "Transformation" </> "samples"++data Example = Example FilePath FilePath++examples =+  [ Example "toArgs.f90" "toArgs.expected.f90"+  , Example "toArgs2.f90" "toArgs2.expected.f90"+  ]++readExpected :: FilePath -> IO String+readExpected filename = do+  let path = samplesBase </> filename+  readFile path++readActual :: FilePath -> IO String+readActual argumentFilename = do+  let argumentPath = samplesBase </> argumentFilename+  let outFile = argumentPath `addExtension` "out"+  commonToArgs argumentPath [] outFile ()+  actual <- readFile outFile+  removeFile outFile+  return actual++spec :: Spec+spec =+  describe "Issue #9" $+    context "lalala" $ do+      expected <- runIO $ readExpected "toArgs.expected.f90"+      actual <- runIO $ readActual "toArgs.f90"+      it "it eliminates common statement" $+        actual `shouldBe` expected

@@ -0,0 +1,68 @@+{-+   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 ScopedTypeVariables #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE FlexibleContexts #-}++module Camfort.Transformation.EquivalenceElimSpec where++import System.FilePath+import System.Directory++import Test.Hspec++import Camfort.Transformation.EquivalenceElim+import Camfort.Functionality+import Camfort.Helpers+import Camfort.Input++samplesBase :: FilePath+samplesBase = "tests" </> "Camfort" </> "Transformation" </> "samples"++readExpected :: FilePath -> IO String+readExpected filename = do+  let path = samplesBase </> filename+  readFile path++readActual :: FilePath -> IO String+readActual argumentFilename = do+  let argumentPath = samplesBase </> argumentFilename+  let outFile = argumentPath `addExtension` "out"+  equivalences argumentPath [] outFile ()+  actual <- readFile outFile+  removeFile outFile+  return actual++spec :: Spec+spec =+  describe "Equivalence elimination test" $ do+      expected <- runIO $ readExpected "equiv.expected.f90"+      actual <- runIO $ readActual "equiv.f90"+      it "it eliminates equivalence statements" $+        actual `shouldBe` expected+      ----+      report <- runIO $ doRefactor (mapM refactorEquivalences) (samplesBase </> "equiv.f90") [] "equiv.expected.f90"+      it "report is as expected" $+        report `shouldBe` expectedReport+++expectedReport =+  "equiv.f90\+  \6:2     removed equivalence\+  \14:2    addded copy:   y = transfer(x,y) due to refactored equivalence\+  \15:2    addded copy:   z(2) = transfer(x,z(2)) due to refactored equivalence\+  \o.f90\+  \17:0    removed dead code"