camfort-0.800: src/Camfort/Specification/Units/Debug.hs
{-
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)