diff --git a/camfort.cabal b/camfort.cabal --- a/camfort.cabal +++ b/camfort.cabal @@ -1,5 +1,5 @@ name: camfort -version: 0.804 +version: 0.900 synopsis: CamFort - Cambridge Fortran infrastructure description: CamFort is a tool for the analysis, transformation, verification of Fortran code. @@ -12,11 +12,15 @@ stability: experimental build-type: Simple -category: Language, tools +category: Language cabal-version: >= 1.18 tested-with: GHC >= 7.8 +extra-source-files: tests/Camfort/Specification/Stencils/*.f + tests/Camfort/Specification/Units/*.f90 + tests/Camfort/Transformation/samples/*.f90 + source-repository head type: git location: https://github.com/camfort/camfort @@ -25,13 +29,8 @@ main-is: Main.hs hs-source-dirs: src other-modules: Camfort.Analysis.Annotations - Camfort.Analysis.CallGraph Camfort.Analysis.CommentAnnotator - Camfort.Analysis.IntermediateReps - Camfort.Analysis.LVA Camfort.Analysis.Simple - Camfort.Analysis.Syntax - Camfort.Analysis.Types Camfort.Specification.Stencils.Annotation Camfort.Specification.Stencils.CheckBackend Camfort.Specification.Stencils.CheckFrontend @@ -50,30 +49,21 @@ Camfort.Specification.Units.Parser Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim - Camfort.Transformation.CommonBlockElimToCalls Camfort.Transformation.DeadCode - Camfort.Transformation.DerivedTypeIntro Camfort.Transformation.EquivalenceElim - Camfort.Transformation.Syntax Camfort.Helpers + Camfort.Helpers.Syntax Camfort.Helpers.Vec Camfort.Functionality Camfort.Input Camfort.Output Camfort.Reprint - Camfort.PrettyPrint - Camfort.Traverse Main 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, uniplate >= 1.6.10, - comonad >= 3, - fclabels >= 2, - haskell-src >= 1.0.1, syz >= 0.2, syb >= 0.4, matrix >=0.2.2, @@ -83,11 +73,10 @@ text >= 0.11.2.3, array >= 0.4, directory >= 1.2, - language-fortran >= 0.5.1, transformers >= 0.4, GenericPretty >= 1.2, QuickCheck >= 2.8, - fortran-src >= 0.1.0.2, + fortran-src >= 0.1.0.3, filepath, fgl >= 5.5, bytestring >= 0.10 @@ -97,13 +86,8 @@ hs-source-dirs: src build-tools: alex, happy exposed-modules: Camfort.Analysis.Annotations - Camfort.Analysis.CallGraph Camfort.Analysis.CommentAnnotator - Camfort.Analysis.IntermediateReps - Camfort.Analysis.LVA Camfort.Analysis.Simple - Camfort.Analysis.Syntax - Camfort.Analysis.Types Camfort.Specification.Stencils.Annotation Camfort.Specification.Stencils.CheckBackend Camfort.Specification.Stencils.CheckFrontend @@ -122,29 +106,20 @@ Camfort.Specification.Units.Parser Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim - Camfort.Transformation.CommonBlockElimToCalls Camfort.Transformation.DeadCode - Camfort.Transformation.DerivedTypeIntro Camfort.Transformation.EquivalenceElim - Camfort.Transformation.Syntax Camfort.Helpers + Camfort.Helpers.Syntax Camfort.Helpers.Vec Camfort.Functionality Camfort.Input Camfort.Output Camfort.Reprint - Camfort.PrettyPrint - Camfort.Traverse 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, uniplate >= 1.6.10, - comonad >= 3, - fclabels >= 2, - haskell-src >= 1.0.1, syz >= 0.2, syb >= 0.4, matrix >=0.2.2, @@ -153,11 +128,10 @@ text >= 0.11.2.3, array >= 0.4, directory >= 1.2, - language-fortran >= 0.5.1, transformers >= 0.4, vector >= 0.1, GenericPretty >= 1.2, - fortran-src >= 0.1.0.2, + fortran-src >= 0.1.0.3, filepath, bytestring >= 0.10, fgl >= 5.5 @@ -182,10 +156,10 @@ directory >= 1.2, hspec >= 2.2, QuickCheck >= 2.8, - fortran-src >= 0.1.0.2, + fortran-src >= 0.1.0.3, uniplate >= 1.6.10, mtl >= 2.1, - bytestring >= 0.10, + bytestring >= 0.10, array >= 0.4, hmatrix >= 0.15, camfort diff --git a/dist/build/Camfort/Specification/Stencils/Grammar.hs b/dist/build/Camfort/Specification/Stencils/Grammar.hs deleted file mode 100644 --- a/dist/build/Camfort/Specification/Stencils/Grammar.hs +++ /dev/null @@ -1,883 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*- Mode: Haskell -*- -{-# LANGUAGE DeriveDataTypeable, PatternGuards #-} -module Camfort.Specification.Stencils.Grammar -( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where - -import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace) -import Data.List (intersect, sort, isPrefixOf) -import Data.Data - -import Debug.Trace - -import Camfort.Analysis.CommentAnnotator -import Camfort.Specification.Stencils.Syntax (showL) -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn4 :: (Specification) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (Specification) -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: ((String, Region)) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> ((String, Region)) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (Region) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (Region) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (Bool) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (Bool) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (Spec) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (Spec) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (Mod) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (Mod) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: ([Mod]) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> ([Mod]) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Mod) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Mod) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: ([String]) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> ([String]) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyInTok :: (Token) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x36\x00\x61\x00\x00\x00\x5d\x00\x5a\x00\xfe\xff\x23\x00\x5c\x00\x18\x00\x4b\x00\x0b\x00\x00\x00\x59\x00\x00\x00\x00\x00\x58\x00\x57\x00\x56\x00\x55\x00\x00\x00\x18\x00\x54\x00\x53\x00\x07\x00\x52\x00\x50\x00\x4f\x00\x4e\x00\x4c\x00\x23\x00\x00\x00\x2d\x00\x18\x00\x1f\x00\x51\x00\x18\x00\x18\x00\x00\x00\x4d\x00\x00\x00\x47\x00\x1f\x00\x4a\x00\x49\x00\x48\x00\x46\x00\x45\x00\x00\x00\x18\x00\x1f\x00\x44\x00\x43\x00\x41\x00\x40\x00\x3b\x00\x00\x00\x2e\x00\x42\x00\x3f\x00\x3e\x00\x00\x00\x3a\x00\x35\x00\x34\x00\x00\x00\x33\x00\x32\x00\x30\x00\x3d\x00\x3d\x00\x3d\x00\x29\x00\x00\x00\x28\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x2f\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x39\x00\x37\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x2b\x00\x00\x00\x1e\x00\x20\x00\x13\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x0a\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xec\xff\x00\x00\x00\x00\x00\x00\xe9\xff\xeb\xff\x00\x00\xe8\xff\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\xea\xff\xe9\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf7\xff\xfd\xff\xe5\xff\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xfc\xff\xf1\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\x00\x00\x00\x00\xf2\xff\xf2\xff\xf2\xff\x00\x00\xf3\xff\x00\x00\x00\x00\xf9\xff\xfa\xff\xfb\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x03\x00\x04\x00\x02\x00\x06\x00\x07\x00\x03\x00\x06\x00\x07\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x03\x00\x10\x00\x04\x00\x03\x00\x06\x00\x07\x00\x02\x00\x16\x00\x02\x00\x0b\x00\x0c\x00\x0d\x00\x12\x00\x13\x00\x10\x00\x04\x00\x08\x00\x17\x00\x06\x00\x07\x00\x16\x00\x02\x00\x0b\x00\x0c\x00\x0d\x00\x08\x00\x02\x00\x10\x00\x04\x00\x05\x00\x06\x00\x07\x00\x02\x00\x16\x00\x00\x00\x01\x00\x12\x00\x13\x00\x06\x00\x07\x00\x12\x00\x13\x00\x01\x00\x02\x00\x08\x00\x02\x00\x02\x00\x05\x00\x01\x00\x17\x00\x17\x00\x17\x00\x11\x00\x05\x00\x11\x00\x11\x00\x17\x00\xff\xff\x09\x00\x09\x00\x15\x00\x15\x00\x09\x00\x11\x00\xff\xff\x03\x00\x15\x00\xff\xff\x11\x00\x11\x00\x0f\x00\x11\x00\x09\x00\xff\xff\x10\x00\x0a\x00\x0a\x00\x0a\x00\x15\x00\x17\x00\x15\x00\x15\x00\x15\x00\x13\x00\x10\x00\x10\x00\x02\x00\x10\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x14\x00\x14\x00\xff\xff\x19\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x0c\x00\x0d\x00\x1d\x00\x0e\x00\x0f\x00\x47\x00\x1e\x00\x1f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x49\x00\x14\x00\x0d\x00\x4a\x00\x0e\x00\x0f\x00\x31\x00\x15\x00\x25\x00\x10\x00\x11\x00\x12\x00\x24\x00\x25\x00\x14\x00\x0d\x00\x37\x00\x30\x00\x1e\x00\x1f\x00\x15\x00\x26\x00\x10\x00\x11\x00\x12\x00\x27\x00\x06\x00\x14\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x29\x00\x15\x00\x04\x00\x02\x00\x24\x00\x25\x00\x0e\x00\x0f\x00\x24\x00\x25\x00\x06\x00\x04\x00\x2e\x00\x17\x00\x21\x00\x20\x00\x02\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x49\x00\x46\x00\x47\x00\x41\x00\x00\x00\x3e\x00\x3f\x00\x42\x00\x43\x00\x40\x00\x39\x00\x00\x00\x0c\x00\x44\x00\x00\x00\x3a\x00\x3b\x00\x3d\x00\x3c\x00\x2b\x00\x00\x00\x29\x00\x2c\x00\x2d\x00\x2e\x00\x34\x00\x33\x00\x35\x00\x36\x00\x37\x00\x25\x00\x29\x00\x29\x00\x04\x00\x17\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x23\x00\x16\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 26) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26) - ] - -happy_n_terms = 26 :: Int -happy_n_nonterms = 9 :: Int - -happyReduce_1 = happySpecReduce_1 0# happyReduction_1 -happyReduction_1 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4 - (RegionDec (fst happy_var_1) (snd happy_var_1) - )} - -happyReduce_2 = happyReduce 4# 0# happyReduction_2 -happyReduction_2 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut8 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn4 - (SpecDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_3 = happyReduce 5# 1# happyReduction_3 -happyReduction_3 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut6 happy_x_5 of { happy_var_5 -> - happyIn5 - ((happy_var_3, happy_var_5) - ) `HappyStk` happyRest}} - -happyReduce_4 = happyReduce 10# 2# happyReduction_4 -happyReduction_4 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6 - (Forward (read happy_var_5) (read happy_var_8) happy_var_9 - ) `HappyStk` happyRest}}} - -happyReduce_5 = happyReduce 10# 2# happyReduction_5 -happyReduction_5 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6 - (Backward (read happy_var_5) (read happy_var_8) happy_var_9 - ) `HappyStk` happyRest}}} - -happyReduce_6 = happyReduce 10# 2# happyReduction_6 -happyReduction_6 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6 - (Centered (read happy_var_5) (read happy_var_8) happy_var_9 - ) `HappyStk` happyRest}}} - -happyReduce_7 = happyReduce 6# 2# happyReduction_7 -happyReduction_7 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - happyIn6 - (Centered 0 (read happy_var_5) True - ) `HappyStk` happyRest} - -happyReduce_8 = happySpecReduce_3 2# happyReduction_8 -happyReduction_8 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (Or happy_var_1 happy_var_3 - )}} - -happyReduce_9 = happySpecReduce_3 2# happyReduction_9 -happyReduction_9 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (And happy_var_1 happy_var_3 - )}} - -happyReduce_10 = happySpecReduce_3 2# happyReduction_10 -happyReduction_10 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6 - (happy_var_2 - )} - -happyReduce_11 = happySpecReduce_1 2# happyReduction_11 -happyReduction_11 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6 - (Var happy_var_1 - )} - -happyReduce_12 = happySpecReduce_1 3# happyReduction_12 -happyReduction_12 happy_x_1 - = happyIn7 - (False - ) - -happyReduce_13 = happySpecReduce_0 3# happyReduction_13 -happyReduction_13 = happyIn7 - (True - ) - -happyReduce_14 = happyReduce 4# 4# happyReduction_14 -happyReduction_14 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn8 - (Temporal happy_var_3 False - ) `HappyStk` happyRest} - -happyReduce_15 = happyReduce 5# 4# happyReduction_15 -happyReduction_15 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn8 - (Temporal happy_var_3 True - ) `HappyStk` happyRest} - -happyReduce_16 = happySpecReduce_3 4# happyReduction_16 -happyReduction_16 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn8 - (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3 - )}}} - -happyReduce_17 = happySpecReduce_2 4# happyReduction_17 -happyReduction_17 happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn8 - (Spatial [happy_var_1] happy_var_2 - )}} - -happyReduce_18 = happySpecReduce_2 4# happyReduction_18 -happyReduction_18 happy_x_2 - happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn8 - (Spatial [happy_var_1] happy_var_2 - )}} - -happyReduce_19 = happySpecReduce_1 4# happyReduction_19 -happyReduction_19 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn8 - (Spatial [] happy_var_1 - )} - -happyReduce_20 = happySpecReduce_1 5# happyReduction_20 -happyReduction_20 happy_x_1 - = happyIn9 - (ReadOnce - ) - -happyReduce_21 = happySpecReduce_2 6# happyReduction_21 -happyReduction_21 happy_x_2 - happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn10 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_22 = happySpecReduce_1 6# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10 - ([happy_var_1] - )} - -happyReduce_23 = happySpecReduce_1 7# happyReduction_23 -happyReduction_23 happy_x_1 - = happyIn11 - (AtMost - ) - -happyReduce_24 = happySpecReduce_1 7# happyReduction_24 -happyReduction_24 happy_x_1 - = happyIn11 - (AtLeast - ) - -happyReduce_25 = happySpecReduce_2 8# happyReduction_25 -happyReduction_25 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn12 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_26 = happySpecReduce_1 8# happyReduction_26 -happyReduction_26 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn12 - ([happy_var_1] - )} - -happyNewToken action sts stk [] = - happyDoAction 25# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - TId "stencil" -> cont 1#; - TId "region" -> cont 2#; - TId "readonce" -> cont 3#; - TId "reflexive" -> cont 4#; - TId "irreflexive" -> cont 5#; - TId "atmost" -> cont 6#; - TId "atleast" -> cont 7#; - TId "dims" -> cont 8#; - TId "dim" -> cont 9#; - TId "depth" -> cont 10#; - TId "forward" -> cont 11#; - TId "backward" -> cont 12#; - TId "centered" -> cont 13#; - TId "dependency" -> cont 14#; - TId "mutual" -> cont 15#; - TId happy_dollar_dollar -> cont 16#; - TNum happy_dollar_dollar -> cont 17#; - TPlus -> cont 18#; - TStar -> cont 19#; - TDoubleColon -> cont 20#; - TEqual -> cont 21#; - TLParen -> cont 22#; - TRParen -> cont 23#; - TComma -> cont 24#; - _ -> happyError' (tk:tks) - } - -happyError_ 25# tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseSpec tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) - -happySeq = happyDontSeq - - -data Specification - = RegionDec String Region - | SpecDec Spec [String] - deriving (Show, Eq, Ord, Typeable, Data) - -data Region - = Forward Int Int Bool - | Backward Int Int Bool - | Centered Int Int Bool - | Or Region Region - | And Region Region - | Var String - deriving (Show, Eq, Ord, Typeable, Data) - -data Spec - = Spatial [Mod] Region - | Temporal [String] Bool - deriving (Show, Eq, Ord, Typeable, Data) - -data Mod - = AtLeast - | AtMost - | ReadOnce - deriving (Show, Eq, Ord, Typeable, Data) - --------------------------------------------------- - -data Token - = TDoubleColon - | TStar - | TPlus - | TEqual - | TComma - | TLParen - | TRParen - | TId String - | TNum String - deriving (Show) - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -stripLeadingWhiteSpace (' ':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace ('\t':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace ('\n':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace xs = xs - - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer input | length (stripLeadingWhiteSpace input) >= 2 = - case stripLeadingWhiteSpace input of - -- Check the leading character is '=' for specification - '=':input' -> - -- First test to see if the input looks like an actual - -- specification of either a stencil or region - if (input' `hasPrefix` "stencil" || input' `hasPrefix` "region") - then lexer' input' - else Left NotAnnotation - _ -> Left NotAnnotation - where - hasPrefix [] str = False - hasPrefix (' ':xs) str = hasPrefix xs str - hasPrefix xs str = isPrefixOf str xs -lexer _ = Left NotAnnotation - - -lexer' :: String -> Either AnnotationParseError [ Token ] -lexer' [] = return [] -lexer' (' ':xs) = lexer' xs -lexer' ('\t':xs) = lexer' xs -lexer' (':':':':xs) = addToTokens TDoubleColon xs -lexer' ('*':xs) = addToTokens TStar xs -lexer' ('+':xs) = addToTokens TPlus xs -lexer' ('=':xs) = addToTokens TEqual xs --- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead. -lexer' (',':xs) - | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs') - | otherwise = addToTokens TComma xs -lexer' ('(':xs) = addToTokens TLParen xs -lexer' (')':xs) = addToTokens TRParen xs -lexer' (x:xs) - | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_' - | isNumber x = aux TNum isNumber - | otherwise - = failWith $ "Not an indentifier " ++ show x - where - aux f p = (f target :) `fmap` lexer' rest - where (target, rest) = span p (x:xs) -lexer' x - = failWith $ "Not a valid piece of stencil syntax " ++ show x - --------------------------------------------------- - --- specParser :: String -> Either AnnotationParseError Specification -specParser :: AnnotationParser Specification -specParser src = do - tokens <- lexer src - parseSpec tokens >>= modValidate - --- Check whether modifiers are used correctly -modValidate :: Specification -> Either AnnotationParseError Specification -modValidate (SpecDec (Spatial mods r) vars) = - do mods' <- modValidate' $ sort mods - return $ SpecDec (Spatial mods' r) vars - - where modValidate' [] = return $ [] - - modValidate' (AtLeast : AtLeast : xs) - = failWith "Duplicate 'atLeast' modifier; use at most one." - - modValidate' (AtMost : AtMost : xs) - = failWith "Duplicate 'atMost' modifier; use at most one." - - modValidate' (ReadOnce : ReadOnce : xs) - = failWith "Duplicate 'readOnce' modifier; use at most one." - - modValidate' (AtLeast : AtMost : xs) - = failWith $ "Conflicting modifiers: cannot use 'atLeast' and " - ++ "'atMost' together" - - modValidate' (x : xs) - = do xs' <- modValidate' xs - return $ x : xs' -modValidate x = return x - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = failWith $ "Could not parse specification at: " ++ show t -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 19 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 20 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - -{-# LINE 170 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/dist/build/Camfort/Specification/Units/Parser.hs b/dist/build/Camfort/Specification/Units/Parser.hs deleted file mode 100644 --- a/dist/build/Camfort/Specification/Units/Parser.hs +++ /dev/null @@ -1,759 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*- Mode: Haskell -*- - -{-# LANGUAGE DeriveDataTypeable #-} -module Camfort.Specification.Units.Parser ( unitParser - , UnitStatement(..) - , UnitOfMeasure(..) - , UnitPower(..) - ) where - -import Camfort.Analysis.CommentAnnotator -import Data.Data -import Data.List -import Data.Char (isLetter, isNumber, isAlphaNum, toLower) -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn4 :: (UnitStatement) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (UnitStatement) -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: (Maybe [String]) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (Maybe [String]) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: ([String]) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> ([String]) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (UnitPower) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (UnitPower) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Integer) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Integer) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (String) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (String) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyInTok :: (Token) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x44\x00\x41\x00\x0f\x00\x3c\x00\x05\x00\x2b\x00\x04\x00\x3d\x00\x00\x00\x00\x00\x3f\x00\xff\xff\x3b\x00\x01\x00\x34\x00\x00\x00\x35\x00\x10\x00\x36\x00\x0f\x00\x00\x00\x04\x00\x3a\x00\x00\x00\x39\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x19\x00\x0f\x00\x00\x00\x00\x00\x33\x00\xfd\xff\x00\x00\x38\x00\x00\x00\x19\x00\x00\x00\x2c\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x37\x00\x00\x00\x27\x00\x00\x00\x27\x00\x22\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1d\x00\x00\x00\x30\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x28\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xf8\xff\xf2\xff\xef\xff\xf7\xff\x00\x00\x00\x00\x00\x00\xf8\xff\xf7\xff\xf5\xff\x00\x00\x00\x00\xf4\xff\x00\x00\xfe\xff\x00\x00\x00\x00\xfc\xff\xf9\xff\xf3\xff\xf1\xff\xee\xff\xeb\xff\xe8\xff\xe9\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf0\xff\xfd\xff\x00\x00\xea\xff\x00\x00\xfa\xff\x00\x00\xed\xff\x00\x00\xec\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x02\x00\x02\x00\x08\x00\x02\x00\x02\x00\x03\x00\x0c\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x09\x00\x0b\x00\x0b\x00\x02\x00\x03\x00\x03\x00\x04\x00\x08\x00\x06\x00\x03\x00\x04\x00\x05\x00\x0b\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x06\x00\x03\x00\x04\x00\x05\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x07\x00\x08\x00\x07\x00\x08\x00\x03\x00\x04\x00\x08\x00\x09\x00\x05\x00\x05\x00\x00\x00\x0c\x00\x07\x00\x02\x00\x08\x00\x02\x00\x07\x00\x05\x00\x0a\x00\x0c\x00\x02\x00\x01\x00\x08\x00\x07\x00\x01\x00\xff\xff\xff\xff\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x09\x00\x0f\x00\x09\x00\x28\x00\x2a\x00\x09\x00\x09\x00\x0a\x00\x2b\x00\x0c\x00\x10\x00\x14\x00\x24\x00\x0b\x00\x14\x00\x0c\x00\x09\x00\x0a\x00\x1e\x00\x1f\x00\x26\x00\x20\x00\x24\x00\x06\x00\x07\x00\x0c\x00\x21\x00\x1e\x00\x1f\x00\x17\x00\x20\x00\x0c\x00\x0d\x00\x07\x00\x14\x00\x1a\x00\x1b\x00\x1c\x00\x0c\x00\x0d\x00\x07\x00\x05\x00\x06\x00\x07\x00\x2b\x00\x1c\x00\x25\x00\x1c\x00\x1e\x00\x1f\x00\x16\x00\x17\x00\x19\x00\x12\x00\x03\x00\x2d\x00\x12\x00\x19\x00\x16\x00\x19\x00\x12\x00\x28\x00\x22\x00\x23\x00\x11\x00\x03\x00\x16\x00\x12\x00\x05\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 23) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23) - ] - -happy_n_terms = 14 :: Int -happy_n_nonterms = 9 :: Int - -happyReduce_1 = happySpecReduce_3 0# happyReduction_1 -happyReduction_1 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_3 of { happy_var_3 -> - happyIn4 - (UnitAssignment happy_var_3 happy_var_2 - )}} - -happyReduce_2 = happyReduce 5# 0# happyReduction_2 -happyReduction_2 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut7 happy_x_5 of { happy_var_5 -> - happyIn4 - (UnitAlias happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_3 = happySpecReduce_2 1# happyReduction_3 -happyReduction_3 happy_x_2 - happy_x_1 - = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn5 - (Just happy_var_2 - )} - -happyReduce_4 = happySpecReduce_0 1# happyReduction_4 -happyReduction_4 = happyIn5 - (Nothing - ) - -happyReduce_5 = happySpecReduce_3 2# happyReduction_5 -happyReduction_5 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_6 = happySpecReduce_1 2# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6 - ([happy_var_1] - )} - -happyReduce_7 = happySpecReduce_1 3# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7 - (happy_var_1 - )} - -happyReduce_8 = happySpecReduce_1 3# happyReduction_8 -happyReduction_8 happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_9 = happySpecReduce_3 3# happyReduction_9 -happyReduction_9 happy_x_3 - happy_x_2 - happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_10 = happySpecReduce_2 3# happyReduction_10 -happyReduction_10 happy_x_2 - happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_11 = happySpecReduce_2 4# happyReduction_11 -happyReduction_11 happy_x_2 - happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn8 - (UnitProduct happy_var_1 happy_var_2 - )}} - -happyReduce_12 = happySpecReduce_3 4# happyReduction_12 -happyReduction_12 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_3 of { happy_var_3 -> - happyIn8 - (UnitQuotient happy_var_1 happy_var_3 - )}} - -happyReduce_13 = happySpecReduce_1 4# happyReduction_13 -happyReduction_13 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn8 - (happy_var_1 - )} - -happyReduce_14 = happySpecReduce_3 5# happyReduction_14 -happyReduction_14 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn9 - (UnitExponentiation happy_var_1 happy_var_3 - )}} - -happyReduce_15 = happySpecReduce_3 5# happyReduction_15 -happyReduction_15 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn9 - (happy_var_2 - )} - -happyReduce_16 = happySpecReduce_1 5# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn9 - (UnitBasic happy_var_1 - )} - -happyReduce_17 = happySpecReduce_1 6# happyReduction_17 -happyReduction_17 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10 - (UnitPowerInteger happy_var_1 - )} - -happyReduce_18 = happySpecReduce_3 6# happyReduction_18 -happyReduction_18 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn10 - (UnitPowerInteger happy_var_2 - )} - -happyReduce_19 = happyReduce 5# 6# happyReduction_19 -happyReduction_19 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut11 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_4 of { happy_var_4 -> - happyIn10 - (UnitPowerRational happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_20 = happySpecReduce_1 7# happyReduction_20 -happyReduction_20 happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - happyIn11 - (read happy_var_1 - )} - -happyReduce_21 = happySpecReduce_2 7# happyReduction_21 -happyReduction_21 happy_x_2 - happy_x_1 - = case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn11 - (read $ '-' : happy_var_2 - )} - -happyReduce_22 = happySpecReduce_1 8# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOutTok happy_x_1 of { (TNum happy_var_1) -> - happyIn12 - (happy_var_1 - )} - -happyReduce_23 = happySpecReduce_1 8# happyReduction_23 -happyReduction_23 happy_x_1 - = happyIn12 - ("1" - ) - -happyNewToken action sts stk [] = - happyDoAction 13# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - TId "unit" -> cont 1#; - TId happy_dollar_dollar -> cont 2#; - TNum "1" -> cont 3#; - TNum happy_dollar_dollar -> cont 4#; - TComma -> cont 5#; - TMinus -> cont 6#; - TExponentiation -> cont 7#; - TDivision -> cont 8#; - TDoubleColon -> cont 9#; - TEqual -> cont 10#; - TLeftPar -> cont 11#; - TRightPar -> cont 12#; - _ -> happyError' (tk:tks) - } - -happyError_ 13# tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseUnit tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) - -happySeq = happyDontSeq - - -data UnitStatement = - UnitAssignment (Maybe [String]) UnitOfMeasure - | UnitAlias String UnitOfMeasure - deriving Data - -instance Show UnitStatement where - show (UnitAssignment (Just ss) uom) = "= unit (" ++ show uom ++ ") :: " ++ (intercalate "," ss) - show (UnitAssignment Nothing uom) = "= unit (" ++ show uom ++ ")" - show (UnitAlias s uom) = "= unit :: " ++ s ++ " = " ++ show uom - -data UnitOfMeasure = - Unitless - | UnitBasic String - | UnitProduct UnitOfMeasure UnitOfMeasure - | UnitQuotient UnitOfMeasure UnitOfMeasure - | UnitExponentiation UnitOfMeasure UnitPower - deriving Data - -instance Show UnitOfMeasure where - show Unitless = "1" - show (UnitBasic s) = s - show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2 - show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2 - show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")" - -data UnitPower = - UnitPowerInteger Integer - | UnitPowerRational Integer Integer - deriving Data - -instance Show UnitPower where - show (UnitPowerInteger i) = show i - show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2 - -data Token = - TUnit - | TComma - | TDoubleColon - | TExponentiation - | TDivision - | TMinus - | TEqual - | TLeftPar - | TRightPar - | TId String - | TNum String - deriving (Show) - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer ('=':xs) = lexer' xs -lexer _ = Left NotAnnotation - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -lexer' :: String -> Either AnnotationParseError [ Token ] -lexer' [] = Right [] -lexer' ['\n'] = Right [] -lexer' ['\r', '\n'] = Right [] -lexer' ['\r'] = Right [] -- windows -lexer' (' ':xs) = lexer' xs -lexer' ('\t':xs) = lexer' xs -lexer' (':':':':xs) = addToTokens TDoubleColon xs -lexer' ('*':'*':xs) = addToTokens TExponentiation xs -lexer' (',':xs) = addToTokens TComma xs -lexer' ('/':xs) = addToTokens TDivision xs -lexer' ('-':xs) = addToTokens TMinus xs -lexer' ('=':xs) = addToTokens TEqual xs -lexer' ('(':xs) = addToTokens TLeftPar xs -lexer' (')':xs) = addToTokens TRightPar xs -lexer' (x:xs) - | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId - | isNumber x = aux isNumber TNum - | otherwise = Left NotAnnotation -- failWith $ "Not valid unit syntax at " ++ show (x:xs) - where - aux p cons = - let (target, rest) = span p xs - in lexer' rest >>= (\tokens -> return $ cons (x:target) : tokens) - -unitParser :: String -> Either AnnotationParseError UnitStatement -unitParser src = do - tokens <- lexer $ map toLower src - parseUnit tokens - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = Left NotAnnotation -- failWith $ "Could not parse specification at: " ++ show t -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 19 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 20 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - -{-# LINE 170 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs b/dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs deleted file mode 100644 --- a/dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs +++ /dev/null @@ -1,883 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*- Mode: Haskell -*- -{-# LANGUAGE DeriveDataTypeable, PatternGuards #-} -module Camfort.Specification.Stencils.Grammar -( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where - -import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace) -import Data.List (intersect, sort, isPrefixOf) -import Data.Data - -import Debug.Trace - -import Camfort.Analysis.CommentAnnotator -import Camfort.Specification.Stencils.Syntax (showL) -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn4 :: (Specification) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (Specification) -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: ((String, Region)) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> ((String, Region)) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: (Region) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> (Region) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (Bool) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (Bool) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (Spec) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (Spec) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (Mod) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (Mod) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: ([Mod]) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> ([Mod]) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Mod) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Mod) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: ([String]) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> ([String]) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyInTok :: (Token) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x36\x00\x61\x00\x00\x00\x5d\x00\x5a\x00\xfe\xff\x23\x00\x5c\x00\x18\x00\x4b\x00\x0b\x00\x00\x00\x59\x00\x00\x00\x00\x00\x58\x00\x57\x00\x56\x00\x55\x00\x00\x00\x18\x00\x54\x00\x53\x00\x07\x00\x52\x00\x50\x00\x4f\x00\x4e\x00\x4c\x00\x23\x00\x00\x00\x2d\x00\x18\x00\x1f\x00\x51\x00\x18\x00\x18\x00\x00\x00\x4d\x00\x00\x00\x47\x00\x1f\x00\x4a\x00\x49\x00\x48\x00\x46\x00\x45\x00\x00\x00\x18\x00\x1f\x00\x44\x00\x43\x00\x41\x00\x40\x00\x3b\x00\x00\x00\x2e\x00\x42\x00\x3f\x00\x3e\x00\x00\x00\x3a\x00\x35\x00\x34\x00\x00\x00\x33\x00\x32\x00\x30\x00\x3d\x00\x3d\x00\x3d\x00\x29\x00\x00\x00\x28\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x2f\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x39\x00\x37\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x2b\x00\x00\x00\x1e\x00\x20\x00\x13\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x0a\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xec\xff\x00\x00\x00\x00\x00\x00\xe9\xff\xeb\xff\x00\x00\xe8\xff\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\xea\xff\xe9\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf7\xff\xfd\xff\xe5\xff\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xfc\xff\xf1\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\x00\x00\x00\x00\xf2\xff\xf2\xff\xf2\xff\x00\x00\xf3\xff\x00\x00\x00\x00\xf9\xff\xfa\xff\xfb\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x03\x00\x04\x00\x02\x00\x06\x00\x07\x00\x03\x00\x06\x00\x07\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x03\x00\x10\x00\x04\x00\x03\x00\x06\x00\x07\x00\x02\x00\x16\x00\x02\x00\x0b\x00\x0c\x00\x0d\x00\x12\x00\x13\x00\x10\x00\x04\x00\x08\x00\x17\x00\x06\x00\x07\x00\x16\x00\x02\x00\x0b\x00\x0c\x00\x0d\x00\x08\x00\x02\x00\x10\x00\x04\x00\x05\x00\x06\x00\x07\x00\x02\x00\x16\x00\x00\x00\x01\x00\x12\x00\x13\x00\x06\x00\x07\x00\x12\x00\x13\x00\x01\x00\x02\x00\x08\x00\x02\x00\x02\x00\x05\x00\x01\x00\x17\x00\x17\x00\x17\x00\x11\x00\x05\x00\x11\x00\x11\x00\x17\x00\xff\xff\x09\x00\x09\x00\x15\x00\x15\x00\x09\x00\x11\x00\xff\xff\x03\x00\x15\x00\xff\xff\x11\x00\x11\x00\x0f\x00\x11\x00\x09\x00\xff\xff\x10\x00\x0a\x00\x0a\x00\x0a\x00\x15\x00\x17\x00\x15\x00\x15\x00\x15\x00\x13\x00\x10\x00\x10\x00\x02\x00\x10\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x14\x00\x14\x00\xff\xff\x19\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x0c\x00\x0d\x00\x1d\x00\x0e\x00\x0f\x00\x47\x00\x1e\x00\x1f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x49\x00\x14\x00\x0d\x00\x4a\x00\x0e\x00\x0f\x00\x31\x00\x15\x00\x25\x00\x10\x00\x11\x00\x12\x00\x24\x00\x25\x00\x14\x00\x0d\x00\x37\x00\x30\x00\x1e\x00\x1f\x00\x15\x00\x26\x00\x10\x00\x11\x00\x12\x00\x27\x00\x06\x00\x14\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x29\x00\x15\x00\x04\x00\x02\x00\x24\x00\x25\x00\x0e\x00\x0f\x00\x24\x00\x25\x00\x06\x00\x04\x00\x2e\x00\x17\x00\x21\x00\x20\x00\x02\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x49\x00\x46\x00\x47\x00\x41\x00\x00\x00\x3e\x00\x3f\x00\x42\x00\x43\x00\x40\x00\x39\x00\x00\x00\x0c\x00\x44\x00\x00\x00\x3a\x00\x3b\x00\x3d\x00\x3c\x00\x2b\x00\x00\x00\x29\x00\x2c\x00\x2d\x00\x2e\x00\x34\x00\x33\x00\x35\x00\x36\x00\x37\x00\x25\x00\x29\x00\x29\x00\x04\x00\x17\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x23\x00\x16\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 26) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26) - ] - -happy_n_terms = 26 :: Int -happy_n_nonterms = 9 :: Int - -happyReduce_1 = happySpecReduce_1 0# happyReduction_1 -happyReduction_1 happy_x_1 - = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4 - (RegionDec (fst happy_var_1) (snd happy_var_1) - )} - -happyReduce_2 = happyReduce 4# 0# happyReduction_2 -happyReduction_2 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut8 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn4 - (SpecDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_3 = happyReduce 5# 1# happyReduction_3 -happyReduction_3 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut6 happy_x_5 of { happy_var_5 -> - happyIn5 - ((happy_var_3, happy_var_5) - ) `HappyStk` happyRest}} - -happyReduce_4 = happyReduce 10# 2# happyReduction_4 -happyReduction_4 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6 - (Forward (read happy_var_5) (read happy_var_8) happy_var_9 - ) `HappyStk` happyRest}}} - -happyReduce_5 = happyReduce 10# 2# happyReduction_5 -happyReduction_5 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6 - (Backward (read happy_var_5) (read happy_var_8) happy_var_9 - ) `HappyStk` happyRest}}} - -happyReduce_6 = happyReduce 10# 2# happyReduction_6 -happyReduction_6 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6 - (Centered (read happy_var_5) (read happy_var_8) happy_var_9 - ) `HappyStk` happyRest}}} - -happyReduce_7 = happyReduce 6# 2# happyReduction_7 -happyReduction_7 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - happyIn6 - (Centered 0 (read happy_var_5) True - ) `HappyStk` happyRest} - -happyReduce_8 = happySpecReduce_3 2# happyReduction_8 -happyReduction_8 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (Or happy_var_1 happy_var_3 - )}} - -happyReduce_9 = happySpecReduce_3 2# happyReduction_9 -happyReduction_9 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (And happy_var_1 happy_var_3 - )}} - -happyReduce_10 = happySpecReduce_3 2# happyReduction_10 -happyReduction_10 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6 - (happy_var_2 - )} - -happyReduce_11 = happySpecReduce_1 2# happyReduction_11 -happyReduction_11 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6 - (Var happy_var_1 - )} - -happyReduce_12 = happySpecReduce_1 3# happyReduction_12 -happyReduction_12 happy_x_1 - = happyIn7 - (False - ) - -happyReduce_13 = happySpecReduce_0 3# happyReduction_13 -happyReduction_13 = happyIn7 - (True - ) - -happyReduce_14 = happyReduce 4# 4# happyReduction_14 -happyReduction_14 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn8 - (Temporal happy_var_3 False - ) `HappyStk` happyRest} - -happyReduce_15 = happyReduce 5# 4# happyReduction_15 -happyReduction_15 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn8 - (Temporal happy_var_3 True - ) `HappyStk` happyRest} - -happyReduce_16 = happySpecReduce_3 4# happyReduction_16 -happyReduction_16 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn8 - (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3 - )}}} - -happyReduce_17 = happySpecReduce_2 4# happyReduction_17 -happyReduction_17 happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn8 - (Spatial [happy_var_1] happy_var_2 - )}} - -happyReduce_18 = happySpecReduce_2 4# happyReduction_18 -happyReduction_18 happy_x_2 - happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn8 - (Spatial [happy_var_1] happy_var_2 - )}} - -happyReduce_19 = happySpecReduce_1 4# happyReduction_19 -happyReduction_19 happy_x_1 - = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn8 - (Spatial [] happy_var_1 - )} - -happyReduce_20 = happySpecReduce_1 5# happyReduction_20 -happyReduction_20 happy_x_1 - = happyIn9 - (ReadOnce - ) - -happyReduce_21 = happySpecReduce_2 6# happyReduction_21 -happyReduction_21 happy_x_2 - happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn10 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_22 = happySpecReduce_1 6# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10 - ([happy_var_1] - )} - -happyReduce_23 = happySpecReduce_1 7# happyReduction_23 -happyReduction_23 happy_x_1 - = happyIn11 - (AtMost - ) - -happyReduce_24 = happySpecReduce_1 7# happyReduction_24 -happyReduction_24 happy_x_1 - = happyIn11 - (AtLeast - ) - -happyReduce_25 = happySpecReduce_2 8# happyReduction_25 -happyReduction_25 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn12 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_26 = happySpecReduce_1 8# happyReduction_26 -happyReduction_26 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn12 - ([happy_var_1] - )} - -happyNewToken action sts stk [] = - happyDoAction 25# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - TId "stencil" -> cont 1#; - TId "region" -> cont 2#; - TId "readonce" -> cont 3#; - TId "reflexive" -> cont 4#; - TId "irreflexive" -> cont 5#; - TId "atmost" -> cont 6#; - TId "atleast" -> cont 7#; - TId "dims" -> cont 8#; - TId "dim" -> cont 9#; - TId "depth" -> cont 10#; - TId "forward" -> cont 11#; - TId "backward" -> cont 12#; - TId "centered" -> cont 13#; - TId "dependency" -> cont 14#; - TId "mutual" -> cont 15#; - TId happy_dollar_dollar -> cont 16#; - TNum happy_dollar_dollar -> cont 17#; - TPlus -> cont 18#; - TStar -> cont 19#; - TDoubleColon -> cont 20#; - TEqual -> cont 21#; - TLParen -> cont 22#; - TRParen -> cont 23#; - TComma -> cont 24#; - _ -> happyError' (tk:tks) - } - -happyError_ 25# tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseSpec tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) - -happySeq = happyDontSeq - - -data Specification - = RegionDec String Region - | SpecDec Spec [String] - deriving (Show, Eq, Ord, Typeable, Data) - -data Region - = Forward Int Int Bool - | Backward Int Int Bool - | Centered Int Int Bool - | Or Region Region - | And Region Region - | Var String - deriving (Show, Eq, Ord, Typeable, Data) - -data Spec - = Spatial [Mod] Region - | Temporal [String] Bool - deriving (Show, Eq, Ord, Typeable, Data) - -data Mod - = AtLeast - | AtMost - | ReadOnce - deriving (Show, Eq, Ord, Typeable, Data) - --------------------------------------------------- - -data Token - = TDoubleColon - | TStar - | TPlus - | TEqual - | TComma - | TLParen - | TRParen - | TId String - | TNum String - deriving (Show) - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -stripLeadingWhiteSpace (' ':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace ('\t':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace ('\n':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace xs = xs - - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer input | length (stripLeadingWhiteSpace input) >= 2 = - case stripLeadingWhiteSpace input of - -- Check the leading character is '=' for specification - '=':input' -> - -- First test to see if the input looks like an actual - -- specification of either a stencil or region - if (input' `hasPrefix` "stencil" || input' `hasPrefix` "region") - then lexer' input' - else Left NotAnnotation - _ -> Left NotAnnotation - where - hasPrefix [] str = False - hasPrefix (' ':xs) str = hasPrefix xs str - hasPrefix xs str = isPrefixOf str xs -lexer _ = Left NotAnnotation - - -lexer' :: String -> Either AnnotationParseError [ Token ] -lexer' [] = return [] -lexer' (' ':xs) = lexer' xs -lexer' ('\t':xs) = lexer' xs -lexer' (':':':':xs) = addToTokens TDoubleColon xs -lexer' ('*':xs) = addToTokens TStar xs -lexer' ('+':xs) = addToTokens TPlus xs -lexer' ('=':xs) = addToTokens TEqual xs --- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead. -lexer' (',':xs) - | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs') - | otherwise = addToTokens TComma xs -lexer' ('(':xs) = addToTokens TLParen xs -lexer' (')':xs) = addToTokens TRParen xs -lexer' (x:xs) - | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_' - | isNumber x = aux TNum isNumber - | otherwise - = failWith $ "Not an indentifier " ++ show x - where - aux f p = (f target :) `fmap` lexer' rest - where (target, rest) = span p (x:xs) -lexer' x - = failWith $ "Not a valid piece of stencil syntax " ++ show x - --------------------------------------------------- - --- specParser :: String -> Either AnnotationParseError Specification -specParser :: AnnotationParser Specification -specParser src = do - tokens <- lexer src - parseSpec tokens >>= modValidate - --- Check whether modifiers are used correctly -modValidate :: Specification -> Either AnnotationParseError Specification -modValidate (SpecDec (Spatial mods r) vars) = - do mods' <- modValidate' $ sort mods - return $ SpecDec (Spatial mods' r) vars - - where modValidate' [] = return $ [] - - modValidate' (AtLeast : AtLeast : xs) - = failWith "Duplicate 'atLeast' modifier; use at most one." - - modValidate' (AtMost : AtMost : xs) - = failWith "Duplicate 'atMost' modifier; use at most one." - - modValidate' (ReadOnce : ReadOnce : xs) - = failWith "Duplicate 'readOnce' modifier; use at most one." - - modValidate' (AtLeast : AtMost : xs) - = failWith $ "Conflicting modifiers: cannot use 'atLeast' and " - ++ "'atMost' together" - - modValidate' (x : xs) - = do xs' <- modValidate' xs - return $ x : xs' -modValidate x = return x - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = failWith $ "Could not parse specification at: " ++ show t -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 19 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 20 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - -{-# LINE 170 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs b/dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs deleted file mode 100644 --- a/dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs +++ /dev/null @@ -1,759 +0,0 @@ -{-# OPTIONS_GHC -w #-} -{-# OPTIONS -fglasgow-exts -cpp #-} --- -*- Mode: Haskell -*- - -{-# LANGUAGE DeriveDataTypeable #-} -module Camfort.Specification.Units.Parser ( unitParser - , UnitStatement(..) - , UnitOfMeasure(..) - , UnitPower(..) - ) where - -import Camfort.Analysis.CommentAnnotator -import Data.Data -import Data.List -import Data.Char (isLetter, isNumber, isAlphaNum, toLower) -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn4 :: (UnitStatement) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> (UnitStatement) -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -happyIn5 :: (Maybe [String]) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> (Maybe [String]) -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -happyIn6 :: ([String]) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> ([String]) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (UnitOfMeasure) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> (UnitOfMeasure) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: (UnitPower) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (UnitPower) -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: (Integer) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (Integer) -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: (String) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (String) -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyInTok :: (Token) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x44\x00\x41\x00\x0f\x00\x3c\x00\x05\x00\x2b\x00\x04\x00\x3d\x00\x00\x00\x00\x00\x3f\x00\xff\xff\x3b\x00\x01\x00\x34\x00\x00\x00\x35\x00\x10\x00\x36\x00\x0f\x00\x00\x00\x04\x00\x3a\x00\x00\x00\x39\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x19\x00\x0f\x00\x00\x00\x00\x00\x33\x00\xfd\xff\x00\x00\x38\x00\x00\x00\x19\x00\x00\x00\x2c\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x37\x00\x00\x00\x27\x00\x00\x00\x27\x00\x22\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1d\x00\x00\x00\x30\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x28\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xf8\xff\xf2\xff\xef\xff\xf7\xff\x00\x00\x00\x00\x00\x00\xf8\xff\xf7\xff\xf5\xff\x00\x00\x00\x00\xf4\xff\x00\x00\xfe\xff\x00\x00\x00\x00\xfc\xff\xf9\xff\xf3\xff\xf1\xff\xee\xff\xeb\xff\xe8\xff\xe9\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf0\xff\xfd\xff\x00\x00\xea\xff\x00\x00\xfa\xff\x00\x00\xed\xff\x00\x00\xec\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x02\x00\x02\x00\x08\x00\x02\x00\x02\x00\x03\x00\x0c\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x09\x00\x0b\x00\x0b\x00\x02\x00\x03\x00\x03\x00\x04\x00\x08\x00\x06\x00\x03\x00\x04\x00\x05\x00\x0b\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x06\x00\x03\x00\x04\x00\x05\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x07\x00\x08\x00\x07\x00\x08\x00\x03\x00\x04\x00\x08\x00\x09\x00\x05\x00\x05\x00\x00\x00\x0c\x00\x07\x00\x02\x00\x08\x00\x02\x00\x07\x00\x05\x00\x0a\x00\x0c\x00\x02\x00\x01\x00\x08\x00\x07\x00\x01\x00\xff\xff\xff\xff\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x09\x00\x0f\x00\x09\x00\x28\x00\x2a\x00\x09\x00\x09\x00\x0a\x00\x2b\x00\x0c\x00\x10\x00\x14\x00\x24\x00\x0b\x00\x14\x00\x0c\x00\x09\x00\x0a\x00\x1e\x00\x1f\x00\x26\x00\x20\x00\x24\x00\x06\x00\x07\x00\x0c\x00\x21\x00\x1e\x00\x1f\x00\x17\x00\x20\x00\x0c\x00\x0d\x00\x07\x00\x14\x00\x1a\x00\x1b\x00\x1c\x00\x0c\x00\x0d\x00\x07\x00\x05\x00\x06\x00\x07\x00\x2b\x00\x1c\x00\x25\x00\x1c\x00\x1e\x00\x1f\x00\x16\x00\x17\x00\x19\x00\x12\x00\x03\x00\x2d\x00\x12\x00\x19\x00\x16\x00\x19\x00\x12\x00\x28\x00\x22\x00\x23\x00\x11\x00\x03\x00\x16\x00\x12\x00\x05\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 23) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23) - ] - -happy_n_terms = 14 :: Int -happy_n_nonterms = 9 :: Int - -happyReduce_1 = happySpecReduce_3 0# happyReduction_1 -happyReduction_1 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut7 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_3 of { happy_var_3 -> - happyIn4 - (UnitAssignment happy_var_3 happy_var_2 - )}} - -happyReduce_2 = happyReduce 5# 0# happyReduction_2 -happyReduction_2 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut7 happy_x_5 of { happy_var_5 -> - happyIn4 - (UnitAlias happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_3 = happySpecReduce_2 1# happyReduction_3 -happyReduction_3 happy_x_2 - happy_x_1 - = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn5 - (Just happy_var_2 - )} - -happyReduce_4 = happySpecReduce_0 1# happyReduction_4 -happyReduction_4 = happyIn5 - (Nothing - ) - -happyReduce_5 = happySpecReduce_3 2# happyReduction_5 -happyReduction_5 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_6 = happySpecReduce_1 2# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6 - ([happy_var_1] - )} - -happyReduce_7 = happySpecReduce_1 3# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7 - (happy_var_1 - )} - -happyReduce_8 = happySpecReduce_1 3# happyReduction_8 -happyReduction_8 happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_9 = happySpecReduce_3 3# happyReduction_9 -happyReduction_9 happy_x_3 - happy_x_2 - happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_10 = happySpecReduce_2 3# happyReduction_10 -happyReduction_10 happy_x_2 - happy_x_1 - = happyIn7 - (Unitless - ) - -happyReduce_11 = happySpecReduce_2 4# happyReduction_11 -happyReduction_11 happy_x_2 - happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn8 - (UnitProduct happy_var_1 happy_var_2 - )}} - -happyReduce_12 = happySpecReduce_3 4# happyReduction_12 -happyReduction_12 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_3 of { happy_var_3 -> - happyIn8 - (UnitQuotient happy_var_1 happy_var_3 - )}} - -happyReduce_13 = happySpecReduce_1 4# happyReduction_13 -happyReduction_13 happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn8 - (happy_var_1 - )} - -happyReduce_14 = happySpecReduce_3 5# happyReduction_14 -happyReduction_14 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn9 - (UnitExponentiation happy_var_1 happy_var_3 - )}} - -happyReduce_15 = happySpecReduce_3 5# happyReduction_15 -happyReduction_15 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn9 - (happy_var_2 - )} - -happyReduce_16 = happySpecReduce_1 5# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn9 - (UnitBasic happy_var_1 - )} - -happyReduce_17 = happySpecReduce_1 6# happyReduction_17 -happyReduction_17 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10 - (UnitPowerInteger happy_var_1 - )} - -happyReduce_18 = happySpecReduce_3 6# happyReduction_18 -happyReduction_18 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn10 - (UnitPowerInteger happy_var_2 - )} - -happyReduce_19 = happyReduce 5# 6# happyReduction_19 -happyReduction_19 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut11 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_4 of { happy_var_4 -> - happyIn10 - (UnitPowerRational happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_20 = happySpecReduce_1 7# happyReduction_20 -happyReduction_20 happy_x_1 - = case happyOut12 happy_x_1 of { happy_var_1 -> - happyIn11 - (read happy_var_1 - )} - -happyReduce_21 = happySpecReduce_2 7# happyReduction_21 -happyReduction_21 happy_x_2 - happy_x_1 - = case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn11 - (read $ '-' : happy_var_2 - )} - -happyReduce_22 = happySpecReduce_1 8# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOutTok happy_x_1 of { (TNum happy_var_1) -> - happyIn12 - (happy_var_1 - )} - -happyReduce_23 = happySpecReduce_1 8# happyReduction_23 -happyReduction_23 happy_x_1 - = happyIn12 - ("1" - ) - -happyNewToken action sts stk [] = - happyDoAction 13# notHappyAtAll action sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = happyDoAction i tk action sts stk tks in - case tk of { - TId "unit" -> cont 1#; - TId happy_dollar_dollar -> cont 2#; - TNum "1" -> cont 3#; - TNum happy_dollar_dollar -> cont 4#; - TComma -> cont 5#; - TMinus -> cont 6#; - TExponentiation -> cont 7#; - TDivision -> cont 8#; - TDoubleColon -> cont 9#; - TEqual -> cont 10#; - TLeftPar -> cont 11#; - TRightPar -> cont 12#; - _ -> happyError' (tk:tks) - } - -happyError_ 13# tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseUnit tks = happySomeParser where - happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) - -happySeq = happyDontSeq - - -data UnitStatement = - UnitAssignment (Maybe [String]) UnitOfMeasure - | UnitAlias String UnitOfMeasure - deriving Data - -instance Show UnitStatement where - show (UnitAssignment (Just ss) uom) = "= unit (" ++ show uom ++ ") :: " ++ (intercalate "," ss) - show (UnitAssignment Nothing uom) = "= unit (" ++ show uom ++ ")" - show (UnitAlias s uom) = "= unit :: " ++ s ++ " = " ++ show uom - -data UnitOfMeasure = - Unitless - | UnitBasic String - | UnitProduct UnitOfMeasure UnitOfMeasure - | UnitQuotient UnitOfMeasure UnitOfMeasure - | UnitExponentiation UnitOfMeasure UnitPower - deriving Data - -instance Show UnitOfMeasure where - show Unitless = "1" - show (UnitBasic s) = s - show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2 - show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2 - show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")" - -data UnitPower = - UnitPowerInteger Integer - | UnitPowerRational Integer Integer - deriving Data - -instance Show UnitPower where - show (UnitPowerInteger i) = show i - show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2 - -data Token = - TUnit - | TComma - | TDoubleColon - | TExponentiation - | TDivision - | TMinus - | TEqual - | TLeftPar - | TRightPar - | TId String - | TNum String - deriving (Show) - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer ('=':xs) = lexer' xs -lexer _ = Left NotAnnotation - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -lexer' :: String -> Either AnnotationParseError [ Token ] -lexer' [] = Right [] -lexer' ['\n'] = Right [] -lexer' ['\r', '\n'] = Right [] -lexer' ['\r'] = Right [] -- windows -lexer' (' ':xs) = lexer' xs -lexer' ('\t':xs) = lexer' xs -lexer' (':':':':xs) = addToTokens TDoubleColon xs -lexer' ('*':'*':xs) = addToTokens TExponentiation xs -lexer' (',':xs) = addToTokens TComma xs -lexer' ('/':xs) = addToTokens TDivision xs -lexer' ('-':xs) = addToTokens TMinus xs -lexer' ('=':xs) = addToTokens TEqual xs -lexer' ('(':xs) = addToTokens TLeftPar xs -lexer' (')':xs) = addToTokens TRightPar xs -lexer' (x:xs) - | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId - | isNumber x = aux isNumber TNum - | otherwise = Left NotAnnotation -- failWith $ "Not valid unit syntax at " ++ show (x:xs) - where - aux p cons = - let (target, rest) = span p xs - in lexer' rest >>= (\tokens -> return $ cons (x:target) : tokens) - -unitParser :: String -> Either AnnotationParseError UnitStatement -unitParser src = do - tokens <- lexer $ map toLower src - parseUnit tokens - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = Left NotAnnotation -- failWith $ "Could not parse specification at: " ++ show t -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 19 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 20 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - - - - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) -#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) -#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) -#else -#define LT(n,m) (n Happy_GHC_Exts.<# m) -#define GTE(n,m) (n Happy_GHC_Exts.>=# m) -#define EQ(n,m) (n Happy_GHC_Exts.==# m) -#endif - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - -data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is 0#, it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - - -happyDoAction i tk st - = {- nothing -} - - - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} - - - happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) - then EQ(indexShortOffAddr happyCheck off_i, i) - else False - action - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st - - -indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i - where - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# - - - - - -data HappyAddr = HappyA# Happy_GHC_Exts.Addr# - - - - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - -{-# LINE 170 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "shifting the error token" $ - happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_0 nt fn j tk st@((action)) sts stk - = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) - -happyMonadReduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn 0# tk st sts stk - = happyFail 0# tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k (HappyCons (st) (sts)) of - sts1@((HappyCons (st1@(action)) (_))) -> - let drop_stk = happyDropStk k stk - - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop 0# l = l -happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t - -happyDropStk 0# l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - -happyGoto nt j tk st = - {- nothing -} - happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i - - - - ------------------------------------------------------------------------------ --- Error recovery (0# is the error token) - --- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (action) sts stk = --- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - -happyTcHack :: Happy_GHC_Exts.Int# -> a -> a -happyTcHack x y = y -{-# INLINE happyTcHack #-} - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - -{-# NOINLINE happyDoAction #-} -{-# NOINLINE happyTable #-} -{-# NOINLINE happyCheck #-} -{-# NOINLINE happyActOffsets #-} -{-# NOINLINE happyGotoOffsets #-} -{-# NOINLINE happyDefActions #-} - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/src/Camfort/Analysis/Annotations.hs b/src/Camfort/Analysis/Annotations.hs --- a/src/Camfort/Analysis/Annotations.hs +++ b/src/Camfort/Analysis/Annotations.hs @@ -27,11 +27,6 @@ import Data.Map.Lazy hiding (map) import Debug.Trace -import Language.Haskell.ParseMonad - -import Language.Fortran -import Camfort.Analysis.IntermediateReps - import Camfort.Specification.Units.Environment import qualified Camfort.Specification.Units.Parser as P import Camfort.Analysis.CommentAnnotator @@ -40,62 +35,44 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA +import qualified Language.Fortran.Util.Position as FU type Report = String --- Additional "helper" syntax (NOT GENERATED BY PARSER) - --- Loop classifications - -data ReduceType = Reduce | NoReduce -data AccessPatternType = Regular | RegularAndConstants | Irregular | Undecidable -data LoopType = Functor ReduceType - | Gather ReduceType ReduceType AccessPatternType - | Scatter ReduceType AccessPatternType - -{- classify :: Fortran Annotation -> Fortran Annotation - classify x = -} - type A = Annotation - -data Annotation = A { lives :: ([Access],[Access]), - unitVar :: Int, - number :: Int, - refactored :: Maybe SrcLoc, - successorStmts :: [Int], - -- used to indicate when a node is newly introduced - newNode :: Bool, - stencilSpec :: Maybe - -- If defined, either an unprocessed syntax tree - (Either StencilComment.Specification - -- Or a parser AST of a RegionEnv or SpecDecls - (Either StencilSpec.RegionEnv StencilSpec.SpecDecls)), - stencilBlock :: - Maybe (F.Block (FA.Analysis Annotation)) - } - deriving (Eq, Show, Typeable, Data) - -liveOut = snd . lives -liveIn = fst . lives - - -- Map Variable [[(Variable,Int)]], +data Annotation = + A { unitVar :: Int + , number :: Int + , refactored :: Maybe FU.Position + -- indicates when a node is newly introduced + , newNode :: Bool + -- indicates a node which is being deleted + , deleteNode :: Bool + -- Stencil specification annotations + -- TODO: move these into their own annotation + , stencilSpec :: Maybe + -- If defined, either an unprocessed syntax tree + (Either StencilComment.Specification + -- Or a parser AST of a RegionEnv or SpecDecls + (Either StencilSpec.RegionEnv StencilSpec.SpecDecls)) + , stencilBlock :: Maybe (F.Block (FA.Analysis Annotation)) + } deriving (Eq, Show, Typeable, Data) +-- Predicate on whether an AST has been refactored pRefactored :: Annotation -> Bool pRefactored = isJust . refactored unitAnnotation = A - { lives = ([], []) - , unitVar = 0 + { unitVar = 0 , number = 0 , refactored = Nothing - , successorStmts = [] , newNode = False + , deleteNode = False , stencilSpec = Nothing , stencilBlock = Nothing } -------------------------------------------------- - -- Convenience name for a common annotation type. type UA = FA.Analysis (UnitAnnotation A) @@ -106,7 +83,7 @@ -- Link annotation comments to declaration statements instance Linkable UA where - link ann (b@(F.BlStatement _ _ _ (F.StDeclaration {}))) = + link ann (b@(F.BlStatement _ _ _ F.StDeclaration {})) = onPrev (\ ann -> ann { unitBlock = Just b }) ann link ann b = ann diff --git a/src/Camfort/Analysis/CallGraph.hs b/src/Camfort/Analysis/CallGraph.hs deleted file mode 100644 --- a/src/Camfort/Analysis/CallGraph.hs +++ /dev/null @@ -1,36 +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.CallGraph where - -import Data.Data - -import Language.Fortran -import Language.Fortran.Pretty - -import Data.Generics.Uniplate.Operations -import Control.Monad.State.Lazy -import Debug.Trace - -import Camfort.Analysis.Annotations -import Camfort.Analysis.Syntax -import Camfort.Traverse - --- Calculates inter-procedural information - -type DefSites = [(String, String)] diff --git a/src/Camfort/Analysis/CommentAnnotator.hs b/src/Camfort/Analysis/CommentAnnotator.hs --- a/src/Camfort/Analysis/CommentAnnotator.hs +++ b/src/Camfort/Analysis/CommentAnnotator.hs @@ -30,7 +30,7 @@ import Control.Monad.Writer.Strict (Writer(..), tell) import Data.Generics.Uniplate.Operations import Data.Data (Data) - +import Debug.Trace import Language.Fortran.AST import Language.Fortran.Util.Position @@ -67,7 +67,7 @@ {-| Link all comment blocks to first non-comment block in the list. |-} linkBlocks :: (Data a, Linkable a) => [ Block a ] -> [ Block a ] linkBlocks [ ] = [ ] - linkBlocks [ x ] = [ x ] + --linkBlocks [ x ] = [ x ] linkBlocks blocks@(b:bs) | BlComment{} <- b = let (comments, rest) = span isComment blocks @@ -75,7 +75,7 @@ then comments else let (bs, bs') = linkMultiple comments rest in bs ++ linkBlocks bs' - | otherwise = b : linkBlocks bs + | otherwise = (descendBi linkBlocks b) : linkBlocks bs where isComment BlComment{} = True isComment _ = False diff --git a/src/Camfort/Analysis/IntermediateReps.hs b/src/Camfort/Analysis/IntermediateReps.hs deleted file mode 100644 --- a/src/Camfort/Analysis/IntermediateReps.hs +++ /dev/null @@ -1,40 +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 #-} -{-# LANGUAGE FlexibleInstances #-} - -module Camfort.Analysis.IntermediateReps where - -import Data.Data - -import Language.Fortran -import Language.Fortran.Pretty - -data AccessP p = VarA String | ArrayA String [Expr p] deriving (Eq, Typeable, Data) - -type Access = AccessP () - -accessToVarName :: AccessP a -> Variable -accessToVarName (VarA v) = v -accessToVarName (ArrayA v _) = v - -instance Show (AccessP ()) where - show (VarA s) = s - show (ArrayA v es) = v ++ "(" ++ (showList (map pprint es)) ++ ")" - where showList [] = "" - showList [x] = x - showList (x:xs) = x ++ ", " ++ showList xs diff --git a/src/Camfort/Analysis/LVA.hs b/src/Camfort/Analysis/LVA.hs deleted file mode 100644 --- a/src/Camfort/Analysis/LVA.hs +++ /dev/null @@ -1,113 +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 ScopedTypeVariables #-} - -{-| - -Provides live-variable analysis for Fortran code. One of the simpler analyses in the suite (a good -starting point for any new developers). This demonstrates the use of the "zipper" format, and -various helpers from 'Analysis.Syntax' and 'Traverse'. - -'lva' is the top-level definition here. - --} -module Camfort.Analysis.LVA where - -import Data.Data -import Data.List - -import Data.Generics.Zipper -import Data.Generics.Uniplate.Operations - -import Language.Fortran - -import Camfort.Analysis.Annotations -import Camfort.Analysis.Syntax -import Camfort.Transformation.Syntax -import Camfort.Analysis.IntermediateReps -import Camfort.Traverse - - -{-| live-variable analysis on a program -} --- Recall: type Program a = [ProgUnit a] -lva :: Program Annotation -> Program Annotation -lva x = map lvaOnUnit x - -{-| live-variable analysis at the level of a unit, not whole-program,iterates @lva1@ until a fixed-point is reached -} -lvaOnUnit :: ProgUnit Annotation -> ProgUnit Annotation -lvaOnUnit x = let y = fromZipper . (everywhere lva1) . toZipper $ numberStmts . (transformBi reassociate) $ x - in if (y == x) then y else lvaOnUnit y - -{-| Single iteration of live-variable analysis over the zipper for an AST -} -lva1 :: Zipper (ProgUnit Annotation) -> Zipper (ProgUnit Annotation) - -lva1 z = case (getHole z)::(Maybe (Fortran Annotation)) of - Just f -> let anns = map tag ((successors z)::[Fortran Annotation]) -- annotations of the successors - liveOut = nub $ concat $ map (fst . lives) anns - killV = kill f - genV = gen f - liveIn = nub $ union genV (liveOut \\ killV) - annotation = (tag f) { lives = (liveIn, liveOut), successorStmts = map number anns } - in setHole (refill f annotation) z - Nothing -> z - -{-| Variables killed by the current statement -} -kill :: Fortran Annotation -> [Access] -kill (Assg _ _ e1 _) = killForLhsVar e1 - where - {-| variable killed by expressions on the left-hand side -} - killForLhsVar :: Expr Annotation -> [Access] - killForLhsVar (Var a p xes) = map (\((VarName _ v), _) -> VarA v) xes - killForLhsVar _ = [] -kill t = concatMap accesses (lhsExpr t) - -{-| Variables generated (made live) by the current statement -} -gen :: Fortran Annotation -> [Access] -gen t@(Assg _ _ e1 e2) = (concatMap accesses (rhsExpr t)) ++ (genForLhsVar e1) - where - {-| variables generated on the left-hand side -} - genForLhsVar :: Expr Annotation -> [Access] - genForLhsVar t@ (Var _ _ xes) = concatMap (\(_, es) -> accesses es) xes - genForLhsVar _ = [] -gen t = concatMap accesses (rhsExpr t) - - - - - - - - - - - - -{- - successorAnnotations :: Zipper (ProgUnit Annotation) -> [Annotation] - successorAnnotations x = goRight x ++ (case (up x) of - Just ux -> case (getHole ux)::(Maybe (Fortran Annotation)) of - Just f -> map tag (successors f) ++ (goRight ux) - Nothing -> (goRight ux) - Nothing -> []) - where goRight :: Zipper (ProgUnit Annotation) -> [Annotation] - goRight z = (case (getHole z)::(Maybe (Fortran Annotation)) of - Just f -> [tag f] - Nothing -> []) ++ - (case (right z) of - Just rz -> goRight rz - Nothing -> []) - - -} diff --git a/src/Camfort/Analysis/Syntax.hs b/src/Camfort/Analysis/Syntax.hs deleted file mode 100644 --- a/src/Camfort/Analysis/Syntax.hs +++ /dev/null @@ -1,393 +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 ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, KindSignatures, - FlexibleContexts, GADTs, DeriveGeneric #-} - -{-| - -This module provides a number of helper functions for working with Fortran syntax that are useful -between different analyses and transformations. - --} -module Camfort.Analysis.Syntax where - --- Standard imports -import Data.Char -import Data.List -import Data.Monoid -import Control.Monad.State.Lazy -import Debug.Trace - --- Data-type generics imports -import Data.Data -import Data.Generics.Uniplate.Data -import Data.Generics.Uniplate.Operations -import Data.Generics.Zipper -import Data.Typeable - --- CamFort specific functionality -import Camfort.Analysis.Annotations -import Camfort.Analysis.IntermediateReps -import Camfort.Traverse -import Language.Fortran - --- * 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 -} -data AnnotationFree t = AnnotationFree { annotationBound :: t } deriving Show - -{-| short-hand constructor for 'AnnotationFree' -} -af = AnnotationFree -{-| short-hand deconstructor for 'AnnotationFree' -} -unaf = annotationBound - -{-| 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 } - -{-| 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 } - -lower = map toLower - --- Here begins varioous 'Eq' instances for instantiations of 'AnnotationFree' - -instance Eq (AnnotationFree a) => Eq (AnnotationFree [a]) where - (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 - -instance Eq (AnnotationFree Int) where - x == y = (unaf x) == (unaf y) - -instance Eq (AnnotationFree Char) where - x == y = (unaf x) == (unaf y) - -instance Eq (AnnotationFree (AccessP ())) where - x == y = (unaf x) == (unaf y) - -instance (Eq (AnnotationFree a), Eq (AnnotationFree b)) => Eq (AnnotationFree (a, b)) where - (AnnotationFree (x, y)) == (AnnotationFree (x', y')) = ((af x) == (af x')) && ((af y) == (af y')) - -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) - - 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) - - -instance Eq (AnnotationFree (Type a)) where - (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')) = - (af eps == af eps') && (af b == af b') && (af attrs == af attrs') && (af e1 == af e1') && (af e2 == af e2') - -instance Eq (AnnotationFree (Attr p)) where - (AnnotationFree (Dimension _ es)) == (AnnotationFree (Dimension _ es')) = af es == af es' - (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y) - -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 - _ == _ = False - -instance Eq (AnnotationFree (IntentAttr p)) where - (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y) - - -instance Eq (AnnotationFree (MeasureUnitSpec p)) where - (AnnotationFree (UnitProduct _ u)) == (AnnotationFree (UnitProduct _ u')) = (af u) == (af u') - (AnnotationFree (UnitQuotient _ u1 u2)) == (AnnotationFree (UnitQuotient _ u1' u2')) = - (af u1 == af u1') && (af u2 == af u2') - (AnnotationFree (UnitNone _)) == (AnnotationFree (UnitNone _)) = True - _ == _ = False - -instance Eq (AnnotationFree (Fraction p)) where - (AnnotationFree (IntegerConst _ n)) == (AnnotationFree (IntegerConst _ n')) = (af n) == (af n') - (AnnotationFree (FractionConst _ p q)) == (AnnotationFree (FractionConst _ p' q')) = - (af p == af p') && (af q == af q') - (AnnotationFree (NullFraction _)) == (AnnotationFree (NullFraction _)) = True - _ == _ = False - - -{-| 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 - (VarA s1) <= (ArrayA s2 e1) = True - _ <= _ = False - -{-| Partial-ordering for expressions (constructors only so far), ignores annotations -} -instance Eq p => Ord (Expr p) where - (Con _ _ c) <= (Con _ _ c') = c <= c' - e <= e' = error "Ordering on expressions only for constructors so far" - --- * Accessor functions for extracting various pieces of information out of syntax trees - -{-| Extracts the subprocedure name from a program unit -} -getSubName :: ProgUnit p -> Maybe String -getSubName (Main _ _ (SubName _ s) _ _ _) = Just s -getSubName (Sub _ _ _ (SubName _ s) _ _) = Just s -getSubName (Function _ _ _ (SubName _ s) _ _ _) = Just s -getSubName (Module _ _ (SubName _ s) _ _ _ _) = Just s -getSubName (BlockData _ _ (SubName _ s) _ _ _) = Just s -getSubName _ = Nothing - -{-| 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 -varExprToVariable (Var _ _ ((VarName _ v, es):_)) = Just v -varExprToVariable _ = Nothing - -{-| Extracts an 'accessor' form a variable from a variable expression -} -varExprToAccess :: Expr a -> Maybe Access -varExprToAccess v = varExprToVariable v >>= (Just . VarA) - -{-| 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] - where mkAccess v [] = VarA v - mkAccess v es = ArrayA v (map (fmap (const ())) es) -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] - -instance Successors Fortran where - successorsRoot (FSeq _ _ f1 f2) = [f1] - successorsRoot (For _ _ _ _ _ _ f) = [f] - successorsRoot (If _ _ _ f efs f') = [f] - successorsRoot (Forall _ _ _ f) = [f] - successorsRoot (Where _ _ _ f Nothing) = [f] - successorsRoot (Where _ _ _ f (Just f')) = [f, f'] - successorsRoot (Label _ _ _ f) = [f] - successorsRoot _ = [] - - successors = - successorsF - where - successorsF :: forall a . (Eq a, Typeable a) => Zipper (ProgUnit a) -> [Fortran a] - 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 -> - 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) - (Forall _ _ _ f') -> seekUp uf (z >>= up) - (Where _ _ _ f' _) -> seekUp uf (z >>= up) - (Label _ _ _ f') -> seekUp uf (z >>= up) - _ -> [] - Nothing -> [] - - -{-| 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] - -rhsExpr (For _ _ v e1 e2 e3 _) = ((universeBi e1)::[Expr Annotation]) ++ - ((universeBi e2)::[Expr Annotation]) ++ - ((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]) ++ - ((universeBi as)::[Expr Annotation]) - -rhsExpr (Deallocate _ _ es e) = (concatMap (\e -> (universeBi e)::[Expr Annotation]) es) ++ - ((universeBi e)::[Expr Annotation]) - -rhsExpr (Forall _ _ (es, e) f) = concatMap (\(_, e1, e2, e3) -> -- TODO: maybe different here - ((universeBi e1)::[Expr Annotation]) ++ - ((universeBi e2)::[Expr Annotation]) ++ - ((universeBi e3)::[Expr Annotation])) es ++ - ((universeBi e)::[Expr Annotation]) - -rhsExpr (Nullify _ _ es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es - -rhsExpr (Inquire _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es -rhsExpr (Stop _ _ e) = (universeBi e)::[Expr Annotation] -rhsExpr (Where _ _ e f _) = (universeBi e)::[Expr Annotation] - -rhsExpr (Write _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es - -rhsExpr (PointerAssg _ _ _ e2) = (universeBi e2)::[Expr Annotation] - -rhsExpr (Return _ _ e) = (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. - @rhsExpr (parse "x = e") = parse "x"@ -} -lhsExpr :: Fortran Annotation -> [Expr Annotation] -lhsExpr (Assg _ _ e1 e2) = ((universeBi e1)::[Expr Annotation]) -lhsExpr (For x sp v e1 e2 e3 fs) = [Var x sp [(v, [])]] -lhsExpr (PointerAssg _ _ e1 e2) = ((universeBi e1)::[Expr Annotation]) -lhsExpr t = concatMap lhsExpr ((children t)::[Fortran Annotation]) - - --- * Various simple analyses - -{-| Set a default monoid instances for Int -} -instance Monoid Int where - mempty = 0 - mappend = (+) - - -{-| Numbers all the statements in a program unit (successively) which is useful for analysis output -} -numberStmts :: ProgUnit Annotation -> ProgUnit Annotation -numberStmts x = let - numberF :: Fortran Annotation -> State Int (Fortran Annotation) - numberF = descendBiM number' - - numberD :: Decl Annotation -> State Int (Decl Annotation) - numberD = descendBiM number' - - number' :: Annotation -> State Int Annotation - -- actually numbers more than just statements, but this doesn't matter - number' x = do n <- get - put (n + 1) - return $ x { number = n } - - (x', n) = runState (descendBiM numberD x) 0 - (x'', _) = runState (descendBiM numberF x') n - - in x'' - -{-| 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]] - -{-| A predicate on whether an expression is actually a constant constructor -} -isConstant :: Expr p -> Bool -isConstant (Con _ _ _) = True -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) - -{-| 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 | (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) - 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) -affineMatch (Bin _ _ (Minus _) (Var _ _ [(VarName _ v, _)]) (Con _ _ n)) = Just (v, - read n) -affineMatch (Bin _ _ (Minus _) (Con _ _ n) (Var _ _ [(VarName _ v, _)])) = Just (v, - read n) -affineMatch (Var _ _ [(VarName _ v, _)]) = Just (v, 0) -affineMatch _ = Nothing - - --- * An embedded domain-specific language for describing syntax tree queries - -{-| 'QueryCmd' provides 'commands' of which pieces of syntax to find -} - -data QueryCmd t where - Exprs :: QueryCmd (Expr Annotation) - Blocks :: QueryCmd (Block Annotation) - Decls :: QueryCmd (Decl Annotation) - Locs :: QueryCmd Access - Vars :: QueryCmd (Expr Annotation) - -{-| '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]@ - 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. --} -from :: forall t synTyp . (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp] -from Locs x = accesses x -from Vars x = [v | v@(Var _ _ _) <- (universeBi x)::[Expr Annotation]] -from _ x = (universeBi x)::[synTyp] - -{-| 'topFrom' takes a command as first parameter, a piece of syntax as its second, and - returns all pieces of syntax matching the query request that are *children* of the current - piece of syntax. This means that it will not return itself. -} - -topFrom :: forall t synTyp . (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp] -topFrom Locs x = accesses x -topFrom _ x = (childrenBi x)::[synTyp] diff --git a/src/Camfort/Analysis/Types.hs b/src/Camfort/Analysis/Types.hs deleted file mode 100644 --- a/src/Camfort/Analysis/Types.hs +++ /dev/null @@ -1,109 +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 TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Camfort.Analysis.Types where - -import Data.List -import Data.Char -import Data.Data -import Control.Monad.State.Lazy - -import Data.Generics.Uniplate.Operations - -import Camfort.Analysis.Syntax -import Language.Fortran - -import Debug.Trace - -type TypeEnv t = [(Variable, Type t)] -type TypeEnvStack t = [TypeEnv t] -- stack of environments - -typeAnnotations :: (Show a, Typeable a, Data a) => Program a -> State (TypeEnv a) (Program a) -typeAnnotations = mapM (descendBiM buildTypeEnv) - -typeEnv :: (Show a, Typeable a, Data a) => Block a -> TypeEnv a -typeEnv x = snd $ runState (buildTypeEnv x) [] - -tenvLookup :: Variable -> TypeEnv t -> Maybe (Type t) -tenvLookup v = lookup (lowercase v) - - -buildTypeEnv :: (Show a, Typeable a, Data a) => Block a -> State (TypeEnv a) (Block a) -buildTypeEnv x = do tenv <- get - tenv' <- return $ gtypes x - put (tenv ++ tenv') - return x - -eqType :: Variable -> Variable -> TypeEnv t -> Bool -eqType v1 v2 vs = case lookup v1 vs of - Nothing -> False - Just t1 -> case lookup v2 vs of - Nothing -> False - Just t2 -> (AnnotationFree t1 == AnnotationFree t2) - - -gtypes :: forall a t . (Show a, Data (t a), Typeable (t a), Data a, Typeable a) => t a -> TypeEnv a -gtypes x = let decAndTypes :: [([(Expr a, Expr a, Maybe Int)], Type a)] - decAndTypes = [(d, t) | (Decl _ _ d t) <- (universeBi x)::[Decl a]] - in concatMap (\(d, t) -> - [(lowercase v, toArrayType t es) - | (Var _ _ vs, _, _) <- d, (VarName _ v, es) <- vs]) decAndTypes - -lowercase = map toLower - -quicktest t = case t of - (ArrayT _ _ _ _ _ _) -> True - _ -> False - -isArrayType :: (TypeEnv t) -> Variable -> Bool -isArrayType env v = case (lookup v env) of - Nothing -> False -- probably a primitive - Just t -> case t of - (ArrayT _ _ _ _ _ _) -> True - (BaseType _ _ attrs _ _) -> any (\x -> case x of Dimension _ _ -> True - _ -> False) attrs - -- _ -> False -- overlap - -toArrayType (BaseType x b as e1 e2) es - | boundsP es = ArrayT x (bounds es) b as e1 e2 - | otherwise = BaseType x b as e1 e2 -toArrayType t es = t - -arrayElementType :: Type p -> Type p -arrayElementType (ArrayT a dims t attrs kind len) = BaseType a t attrs kind len -arrayElementType t = t - -boundsP [] = False -boundsP ((Bound _ _ _ _):es) = True || (boundsP es) -boundsP _ = False - -bounds [] = [] -bounds ((Bound _ _ e1 e2):es) = (e1, e2) : (bounds es) -bounds _ = error "Bound expression is of the wrong form" - - -{- OLD - predBounds [] = False - predBounds [(Bound _ _ _)] = True - predBounds ((Bound _ _ _):bs) = True || predBounds bs - predBounds _ = False - - declsWithBounds :: forall a . (Data a, Typeable a) => [Program a] -> [String] - declsWithBounds x = [v | (VarName _ v, b) <- (universeBi ((universeBi x)::[Decl a]))::[(VarName a, [Expr a])], predBounds b] - --} diff --git a/src/Camfort/Functionality.hs b/src/Camfort/Functionality.hs --- a/src/Camfort/Functionality.hs +++ b/src/Camfort/Functionality.hs @@ -27,39 +27,30 @@ import System.Console.GetOpt import System.Directory import System.Environment +import System.FilePath import System.IO import Data.Monoid import Data.Generics.Uniplate.Operations +import Data.Data +import Data.List (foldl', intercalate) +import qualified Debug.Trace as D import Camfort.Analysis.Annotations -import Camfort.Analysis.Types -import Camfort.Analysis.LVA import Camfort.Analysis.Simple -import Camfort.Analysis.Syntax - import Camfort.Transformation.DeadCode import Camfort.Transformation.CommonBlockElim -import Camfort.Transformation.CommonBlockElimToCalls import Camfort.Transformation.EquivalenceElim -import Camfort.Transformation.DerivedTypeIntro import qualified Camfort.Specification.Units as LU import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad +import Camfort.Helpers.Syntax import Camfort.Helpers import Camfort.Output import Camfort.Input -import Data.Data -import Data.List (foldl', nub, (\\), elemIndices, intersperse, intercalate) - -import qualified Data.ByteString.Char8 as B -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) -import Data.Text.Encoding.Error (replace) - --- FORPAR related imports import qualified Language.Fortran.Parser.Any as FP import qualified Language.Fortran.AST as F import Language.Fortran.Analysis.Renaming @@ -67,8 +58,6 @@ 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 @@ -76,7 +65,9 @@ | Excludes String | Literals LiteralsOpt | StencilInferMode Stencils.InferMode - | Debug deriving (Data, Show) + | Doxygen + | Ford + | Debug deriving (Data, Show, Eq) type Options = [Flag] @@ -84,174 +75,85 @@ instance Default String where defaultValue = "" getExcludes :: Options -> String -getExcludes xs = getOption xs +getExcludes = getOption -- * Wrappers on all of the features -typeStructuring inSrc excludes outSrc _ = do - putStrLn $ "Introducing derived data types in " ++ show inSrc ++ "\n" - report <- doRefactor typeStruct inSrc excludes outSrc - putStrLn report - 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 " - ++ "with AST information for " ++ show inSrc ++ "\n" - let astAnalysis = (map numberStmts) . map (fmap (const unitAnnotation)) - doAnalysis astAnalysis inSrc excludes + xs <- readParseSrcDir (d ++ "/" ++ f) excludes + print (map (\(_, _, p) -> p) xs) countVarDecls inSrc excludes _ _ = do - putStrLn $ "Counting variable declarations in " ++ show inSrc ++ "\n" - doAnalysisSummaryForpar countVariableDeclarations inSrc excludes Nothing - -lvaA inSrc excludes _ _ = do - putStrLn $ "Analysing loops for " ++ show inSrc ++ "\n" - doAnalysis lva inSrc excludes + putStrLn $ "Counting variable declarations in '" ++ inSrc ++ "'" + doAnalysisSummary countVariableDeclarations inSrc excludes Nothing dead inSrc excludes outSrc _ = do - putStrLn $ "Eliminating dead code in " ++ show inSrc ++ "\n" - report <- doRefactor ((mapM (deadCode False))) inSrc excludes outSrc - putStrLn report - -commonToArgs inSrc excludes outSrc _ = do - putStrLn $ "Refactoring common blocks in " ++ show inSrc ++ "\n" - report <- doRefactor (commonElimToCalls inSrc) inSrc excludes outSrc + putStrLn $ "Eliminating dead code in '" ++ inSrc ++ "'" + report <- doRefactor (mapM (deadCode False)) inSrc excludes outSrc putStrLn report common inSrc excludes outSrc _ = do - putStrLn $ "Refactoring common blocks in " ++ show inSrc ++ "\n" - report <- doRefactor (commonElimToModules inSrc) inSrc excludes outSrc + putStrLn $ "Refactoring common blocks in '" ++ inSrc ++ "'" + isDir <- isDirectory inSrc + let dir = if isDir then inSrc ++ "/" else "" + let rfun = commonElimToModules (takeDirectory outSrc ++ "/") + report <- doRefactorAndCreate rfun inSrc excludes outSrc putStrLn report equivalences inSrc excludes outSrc _ = do - putStrLn $ "Refactoring equivalences blocks in " ++ show inSrc ++ "\n" + putStrLn $ "Refactoring equivalences blocks in '" ++ inSrc ++ "'" 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 +optsToUnitOpts = foldl' (\ o f -> case f of Literals m -> o { uoLiterals = m } + Debug -> o { uoDebug = True } + _ -> o) unitOpts0 unitsCheck inSrc excludes outSrc opt = do - putStrLn $ "Checking units for " ++ show inSrc ++ "\n" - doAnalysisReportForpar (mapM (LU.checkUnits (optsToUnitOpts opt))) inSrc excludes outSrc + putStrLn $ "Checking units for '" ++ inSrc ++ "'" + let rfun = concatMap (LU.checkUnits (optsToUnitOpts opt)) + doAnalysisReport rfun putStrLn inSrc excludes unitsInfer inSrc excludes outSrc opt = do - putStrLn $ "Inferring units for " ++ show inSrc ++ "\n" - doAnalysisReportForpar (mapM (LU.inferUnits (optsToUnitOpts opt))) inSrc excludes outSrc + putStrLn $ "Inferring units for '" ++ inSrc ++ "'" + let rfun = concatMap (LU.inferUnits (optsToUnitOpts opt)) + doAnalysisReport rfun putStrLn inSrc excludes unitsSynth inSrc excludes outSrc opt = do - putStrLn $ "Synthesising units for " ++ show inSrc ++ "\n" - doRefactorForpar (mapM (LU.synthesiseUnits (optsToUnitOpts opt))) inSrc excludes outSrc + putStrLn $ "Synthesising units for '" ++ inSrc ++ "'" + let marker + | Doxygen `elem` opt = '<' + | Ford `elem` opt = '!' + | otherwise = '=' + let rfun = + mapM (LU.synthesiseUnits (optsToUnitOpts opt) marker) + report <- doRefactor rfun inSrc excludes outSrc + putStrLn report unitsCriticals inSrc excludes outSrc opt = do - putStrLn $ "Infering critical variables for units inference in directory " - ++ show inSrc ++ "\n" - doAnalysisReportForpar (mapM (LU.inferCriticalVariables (optsToUnitOpts opt))) inSrc excludes outSrc + putStrLn $ "Suggesting variables to annotate with unit specifications in '" + ++ inSrc ++ "'" + let rfun = mapM (LU.inferCriticalVariables (optsToUnitOpts opt)) + doAnalysisReport rfun (putStrLn . fst) inSrc excludes {- Stencils feature -} stencilsCheck inSrc excludes _ _ = do - putStrLn $ "Checking stencil specs for " ++ show inSrc ++ "\n" - doAnalysisSummaryForpar (\f p -> (Stencils.check f p, p)) inSrc excludes Nothing + putStrLn $ "Checking stencil specs for '" ++ inSrc ++ "'" + let rfun = \f p -> (Stencils.check f p, p) + doAnalysisSummary rfun inSrc excludes Nothing stencilsInfer inSrc excludes outSrc opt = do - putStrLn $ "Infering stencil specs for " ++ show inSrc ++ "\n" - doAnalysisSummaryForpar (Stencils.infer (getOption opt)) inSrc excludes (Just outSrc) + putStrLn $ "Infering stencil specs for '" ++ inSrc ++ "'" + let rfun = Stencils.infer (getOption opt) '=' + doAnalysisSummary rfun inSrc excludes (Just outSrc) stencilsSynth inSrc excludes outSrc opt = do - putStrLn $ "Synthesising stencil specs for " ++ show inSrc ++ "\n" - doRefactorForpar (Stencils.synth (getOption opt)) inSrc excludes outSrc - -stencilsVarFlowCycles inSrc excludes _ _ = do - putStrLn $ "Inferring var flow cycles for " ++ show inSrc ++ "\n" - let flowAnalysis = intercalate ", " . map show . Stencils.findVarFlowCycles - doAnalysisSummaryForpar (\_ p -> (flowAnalysis p , p)) inSrc excludes Nothing - --------------------------------------------------- --- Forpar wrappers - -doRefactorForpar :: ([(Filename, F.ProgramFile A)] - -> (String, [(Filename, F.ProgramFile Annotation)])) - -> FileOrDir -> [Filename] -> FileOrDir -> IO () -doRefactorForpar rFun inSrc excludes outSrc = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) - ++ " from " ++ inSrc ++ "/" - else return () - ps <- readForparseSrcDir 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') - --let outFiles = map fst ps' - putStrLn report - let outputs = mkOutputFileForpar ps ps' - outputFiles inSrc outSrc outputs - where snd3 (a, b, c) = b - -mkOutputFileForpar :: [(Filename, SourceText, a)] - -> [(Filename, F.ProgramFile Annotation)] - -> [(Filename, SourceText, F.ProgramFile Annotation)] -mkOutputFileForpar ps ps' = zip3 (map fst ps') (map snd3 ps) (map snd ps') - where - snd3 (a, b, c) = b - - - - -{-| Performs an analysis which reports to the user, - but does not output any files -} -doAnalysisReportForpar :: ([(Filename, F.ProgramFile A)] -> (String, t1)) - -> FileOrDir -> [Filename] -> t -> IO () -doAnalysisReportForpar rFun inSrc excludes outSrc = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) - ++ " from " ++ inSrc ++ "/" - else return () - ps <- readForparseSrcDir inSrc excludes ----- - let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps) - putStrLn report ----- - --- * Source directory and file handling -readForparseSrcDir :: FileOrDir -> [Filename] - -> IO [(Filename, SourceText, F.ProgramFile A)] -readForparseSrcDir inp excludes = do - isdir <- isDirectory inp - files <- if isdir - then do files <- rGetDirContents inp - return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes - else return [inp] - mapM readForparseSrcFile files ----- - -{-| Read a specific file, and parse it -} -readForparseSrcFile :: Filename -> IO (Filename, SourceText, F.ProgramFile A) -readForparseSrcFile f = do - inp <- flexReadFile f - let ast = FP.fortranParser inp f - return $ (f, inp, fmap (const unitAnnotation) ast) ----- - -doAnalysisSummaryForpar :: (Monoid s, Show' s) => (Filename -> F.ProgramFile A -> (s, F.ProgramFile A)) - -> FileOrDir -> [Filename] -> Maybe FileOrDir -> IO () -doAnalysisSummaryForpar aFun inSrc excludes outSrc = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) - ++ " from " ++ inSrc ++ "/" - else return () - ps <- readForparseSrcDir inSrc excludes - let (out, ps') = callAndSummarise aFun ps - putStrLn "Output of the analysis:" - putStrLn . show' $ out - -callAndSummarise aFun ps = do - foldl' (\(n, pss) (f, _, ps) -> let (n', ps') = aFun f ps - in (n `mappend` n', ps' : pss)) (mempty, []) ps - ----- - --- | Read file using ByteString library and deal with any weird characters. -flexReadFile :: String -> IO B.ByteString -flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile + putStrLn $ "Synthesising stencil specs for '" ++ inSrc ++ "'" + let marker + | Doxygen `elem` opt = '<' + | Ford `elem` opt = '!' + | otherwise = '=' + let rfun = Stencils.synth (getOption opt) marker + report <- doRefactor rfun inSrc excludes outSrc + putStrLn report diff --git a/src/Camfort/Helpers.hs b/src/Camfort/Helpers.hs --- a/src/Camfort/Helpers.hs +++ b/src/Camfort/Helpers.hs @@ -13,27 +13,33 @@ See the License for the specific language governing permissions and limitations under the License. -} -{-# LANGUAGE TypeOperators, PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} module Camfort.Helpers where +import GHC.Generics +import Data.Generics.Zipper +import Data.Generics.Aliases +import Data.Generics.Str +import Data.Generics.Uniplate.Operations +import Data.Data +import Data.Maybe +import Data.Monoid import Data.List (elemIndices, group, sort, nub) 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, (\\)) +import Control.Monad.Writer.Strict -- 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) - -spanLineCol :: SrcSpan -> ((Int, Int), (Int, Int)) -spanLineCol (l, u) = (lineCol l, lineCol u) - type Filename = String type Directory = String type SourceText = B.ByteString @@ -57,9 +63,7 @@ isDirectory :: FileOrDir -> IO Bool isDirectory s = doesDirectoryExist s - -- Helpers - fanout :: (a -> b) -> (a -> c) -> a -> (b, c) fanout f g x = (f x, g x) @@ -136,3 +140,42 @@ normaliseBy :: Ord t => (t -> t -> Maybe t) -> [t] -> [t] normaliseBy plus = nub . (foldPair plus) . sort +#if __GLASGOW_HASKELL__ < 800 +instance Monoid x => Monad ((,) x) where + return a = (mempty, a) + (x, a) >>= k = let (x', b) = k a + in (mappend x x', b) +#endif + +-- Data-type generic reduce traversal +reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a] +reduceCollect k x = execWriter (transformBiM (\y -> do case k y of + Just x -> tell [x] + Nothing -> return () + return y) x) + +-- Data-type generic comonad-style traversal with zipper (contextual traversal) +everywhere :: (Zipper a -> Zipper a) -> Zipper a -> Zipper a +everywhere k z = everywhere' z + where + everywhere' = enterRight . enterDown . k + + enterDown z = + case (down' z) of + Just dz -> let dz' = everywhere' dz + in case (up $ dz') of + Just uz -> uz + Nothing -> dz' + Nothing -> z + + enterRight z = + case (right z) of + Just rz -> let rz' = everywhere' rz + in case (left $ rz') of + Just lz -> lz + Nothing -> rz' + Nothing -> z + + +zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a) +zfmap f x = zeverywhere (mkT f) x diff --git a/src/Camfort/Helpers/Syntax.hs b/src/Camfort/Helpers/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Helpers/Syntax.hs @@ -0,0 +1,127 @@ +{- + 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 FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} + +{-| + +This module provides a number of helper functions for working with Fortran +syntax that are useful between different analyses and transformations. + +-} +module Camfort.Helpers.Syntax where + +-- Standard imports +import Data.Char +import Data.List +import Data.Monoid +import Control.Monad.State.Lazy +import Debug.Trace + +-- Data-type generics imports +import Data.Data +import Data.Generics.Uniplate.Data +import Data.Generics.Uniplate.Operations +import Data.Generics.Zipper +import Data.Typeable + +-- CamFort specific functionality +import Camfort.Analysis.Annotations + +import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Util.Position as FU +import Language.Fortran.Util.FirstParameter +import Language.Fortran.Util.SecondParameter + +-- * Comparison and ordering + +{-| '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' -} +af = AnnotationFree +{-| short-hand deconstructor for 'AnnotationFree' -} +unaf = annotationBound + +-- variable renaming helpers +caml (x:xs) = toUpper x : xs +lower = map toLower + +-- Here begins varioous 'Eq' instances for instantiations of 'AnnotationFree' + +instance Eq (AnnotationFree a) => Eq (AnnotationFree [a]) where + (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 + +instance (Eq (AnnotationFree a), Eq (AnnotationFree b)) + => Eq (AnnotationFree (a, b)) where + + (AnnotationFree (x, y)) == (AnnotationFree (x', y')) = + (af x == af x') && (af y == af y') + +instance Eq a => Eq (AnnotationFree (F.Expression a)) where + (AnnotationFree x) == (AnnotationFree y) = x'' == y'' + where x' = fmap (const ()) x + y' = fmap (const ()) y + y'' = transformBi setSpanConst y' + x'' = transformBi setSpanConst x' + setSpanConst :: FU.SrcSpan -> FU.SrcSpan + setSpanConst (FU.SrcSpan _ _) = FU.SrcSpan pos0 pos0 + where pos0 = FU.Position 0 0 0 + +instance Eq (AnnotationFree F.BaseType) where + (AnnotationFree x) == (AnnotationFree y) = x == y + +-- * Accessor functions for extracting various pieces of information +-- out of syntax trees +{-| Extracts a string of the (root) variable name from an expression, + e.g., extractVariable "v" = Just v + extractVariable "v(i)" = Just v -} +extractVariable :: F.Expression a -> Maybe F.Name +extractVariable (F.ExpValue _ _ (F.ValVariable v)) = Just v +extractVariable (F.ExpSubscript _ _ e _) = extractVariable e +extractVariable _ = Nothing + +{-| Set a default monoid instances for Int -} +instance Monoid Int where + mempty = 0 + mappend = (+) + +-- SrcSpan helpers + +dropLine :: FU.SrcSpan -> FU.SrcSpan +dropLine (FU.SrcSpan s1 (FU.Position o c l)) = + FU.SrcSpan s1 (FU.Position o 0 (l+1)) + +deleteLine :: FU.SrcSpan -> FU.SrcSpan +deleteLine (FU.SrcSpan (FU.Position ol cl ll) (FU.Position ou cu lu)) = + FU.SrcSpan (FU.Position ol (cl-1) ll) (FU.Position ou 0 (lu+1)) + +linesCovered :: FU.Position -> FU.Position -> Int +linesCovered (FU.Position _ _ l1) (FU.Position _ _ l2) = l2 - l1 + 1 + +toCol0 (FU.Position o c l) = FU.Position o 0 l + +afterAligned :: FU.SrcSpan -> FU.Position +afterAligned (FU.SrcSpan (FU.Position o cA lA) (FU.Position _ cB lB)) = + FU.Position o cA (lB+1) diff --git a/src/Camfort/Input.hs b/src/Camfort/Input.hs --- a/src/Camfort/Input.hs +++ b/src/Camfort/Input.hs @@ -26,28 +26,23 @@ module Camfort.Input where --- FIXME: Did enough to get this module to compile, it's not optimised to use ByteString. -import qualified Data.ByteString.Char8 as B -import qualified Language.Fortran.Parser as Fortran -import Language.Fortran.PreProcess -import Language.Fortran - -import Data.Monoid -import Data.Generics.Uniplate.Operations import Camfort.Analysis.Annotations - -import Language.Haskell.ParseMonad -import qualified Language.Haskell.Syntax as LHS - -import System.Directory - import Camfort.Helpers import Camfort.Output -import Camfort.Traverse +import qualified Language.Fortran.Parser.Any as FP +import qualified Language.Fortran.AST as F + +import qualified Data.ByteString.Char8 as B import Data.Data -import Data.List (nub, (\\), elemIndices, intersperse) +import Data.Generics.Uniplate.Operations +import Data.List (foldl', nub, (\\), elemIndices, intercalate) +import Data.Monoid +import Data.Text.Encoding.Error (replace) +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import System.Directory + -- Class for default values of some type 't' class Default t where defaultValue :: t @@ -63,147 +58,137 @@ -- * Builders for analysers and refactorings -{-| Performs an analysis provided by its first parameter on the directory of its - second, excluding files listed by its third -} -doAnalysis :: (Program A -> Program Annotation) - -> FileOrDir -> [Filename] -> IO () -doAnalysis aFun src excludes = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) - ++ " from " ++ src ++ "/" - else return () - - ps <- readParseSrcDir src excludes - - let inFiles = map Fortran.fst3 ps - let outFiles = filter (\f -> not ((take (length $ src ++ "out") f) == (src ++ "out"))) inFiles - let asts' = map (\(f, _, ps) -> aFun ps) ps - outputAnalysisFiles src asts' outFiles - {-| Performs an analysis provided by its first parameter which generates information 's', which is then combined together (via a monoid) -} -doAnalysisSummary :: (Monoid s, Show s) - => (Program A -> s) -> FileOrDir -> [Filename] -> IO () -doAnalysisSummary aFun d excludes = do +doAnalysisSummary :: (Monoid s, Show' s) => (Filename -> F.ProgramFile A -> (s, F.ProgramFile A)) + -> FileOrDir -> [Filename] -> Maybe FileOrDir -> IO () +doAnalysisSummary aFun inSrc excludes outSrc = do if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) - ++ " from " ++ d ++ "/" - else return () + then putStrLn $ "Excluding " ++ intercalate "," excludes + ++ " from " ++ inSrc ++ "/" + else return () + ps <- readParseSrcDir inSrc excludes + let (out, ps') = callAndSummarise aFun ps + putStrLn . show' $ out - ps <- readParseSrcDir d excludes +callAndSummarise aFun = + foldl' (\(n, pss) (f, _, ps) -> let (n', ps') = aFun f ps + in (n `mappend` n', ps' : pss)) (mempty, []) - let inFiles = map Fortran.fst3 ps - putStrLn "Output of the analysis:" - putStrLn $ show $ Prelude.foldl (\n (f, _, ps) -> n `mappend` (aFun ps)) mempty ps {-| Performs an analysis which reports to the user, but does not output any files -} -doAnalysisReport :: ([(Filename, Program A)] -> (String, t1)) - -> FileOrDir -> [Filename] -> t -> IO () -doAnalysisReport rFun inSrc excludes outSrc = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) - ++ " from " ++ inSrc ++ "/" - else return () - ps <- readParseSrcDir inSrc excludes - putStr "\n" - let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps) - putStrLn report - --- Temporary doAnalysisReport version to make it work with Units-Of-Measure --- glue code. -doAnalysisReport' :: ([(Filename, Program A)] -> (String, t1)) - -> FileOrDir -> [Filename] -> t -> IO () -doAnalysisReport' rFun inSrc excludes outSrc = do +doAnalysisReport :: ([(Filename, F.ProgramFile A)] -> r) + -> (r -> IO out) + -> FileOrDir -> [Filename] -> IO out +doAnalysisReport rFun sFun inSrc excludes = do if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) - ++ " from " ++ inSrc ++ "/" - else return () + then putStrLn $ "Excluding " ++ intercalate "," excludes + ++ " from " ++ inSrc ++ "/" + else return () ps <- readParseSrcDir inSrc excludes - putStr "\n" - let (report, ps') = rFun (map (\(a, b, c) -> (a, c)) ps) - putStrLn report +---- + let report = rFun (map (\(f, inp, ast) -> (f, ast)) ps) + sFun report +---- {-| Performs a refactoring provided by its first parameter, on the directory of the second, excluding files listed by third, output to the directory specified by the fourth parameter -} -doRefactor :: ([(Filename, Program A)] - -> (String, [(Filename, Program Annotation)])) - -> FileOrDir -> [Filename] -> FileOrDir -> IO String + +-- Refactoring where just a single list of filename/program file +-- pairs is returned (the case when no files are being added) +doRefactor :: + ([(Filename, F.ProgramFile A)] -> (String, [(Filename, F.ProgramFile A)])) + -> FileOrDir -> [Filename] -> FileOrDir -> IO String doRefactor rFun inSrc excludes outSrc = do - if excludes /= [] && excludes /= [""] - then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes) - ++ " from " ++ inSrc ++ "/" - else return () + if excludes /= [] && excludes /= [""] + then putStrLn $ "Excluding " ++ intercalate "," excludes + ++ " from " ++ inSrc ++ "/" + else return () + ps <- readParseSrcDir inSrc excludes + let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps) + let outputs = reassociateSourceText ps ps' + outputFiles inSrc outSrc outputs + return report - 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') - let outFiles = map fst ps' - let outData = zip3 outFiles (map (B.pack . Fortran.snd3) ps) (map snd ps') - outputFiles inSrc outSrc outData - return report +-- For refactorings which create some files too +-- i.e., for refactoring functions that return a +-- pair of lists of filename/program file pairs is +doRefactorAndCreate :: + ([(Filename, F.ProgramFile A)] + -> (String, [(Filename, F.ProgramFile A)], [(Filename, F.ProgramFile A)])) + -> FileOrDir -> [Filename] -> FileOrDir -> IO String +doRefactorAndCreate rFun inSrc excludes outSrc = do + if excludes /= [] && excludes /= [""] + then putStrLn $ "Excluding " ++ intercalate "," excludes + ++ " from " ++ inSrc ++ "/" + else return () + ps <- readParseSrcDir inSrc excludes + let (report, ps', ps'') = rFun (map (\(f, inp, ast) -> (f, ast)) ps) + let outputs = reassociateSourceText ps ps' + let outputs' = map (\(f, pf) -> (f, B.empty, pf)) ps'' + outputFiles inSrc outSrc outputs + outputFiles inSrc outSrc outputs' + return report +reassociateSourceText :: [(Filename, SourceText, a)] + -> [(Filename, F.ProgramFile Annotation)] + -> [(Filename, SourceText, F.ProgramFile Annotation)] +reassociateSourceText ps ps' = zip3 (map fst ps') (map snd3 ps) (map snd ps') + where snd3 (a, b, c) = b + -- * Source directory and file handling {-| Read files from a direcotry, excluding those listed by the second parameter -} -readParseSrcDir :: FileOrDir -> [Filename] -> IO [(Filename, String, Program A)] +-- * Source directory and file handling +readParseSrcDir :: FileOrDir -> [Filename] + -> IO [(Filename, SourceText, F.ProgramFile A)] readParseSrcDir inp excludes = do isdir <- isDirectory inp - files <- if isdir then do + files <- if isdir + then do files <- rGetDirContents inp - return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes + -- Compute alternate list of excludes with the + -- the directory appended + let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes + return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes' else return [inp] mapM readParseSrcFile files +{-| Read a specific file, and parse it -} +readParseSrcFile :: Filename -> IO (Filename, SourceText, F.ProgramFile A) +readParseSrcFile f = do + inp <- flexReadFile f + let ast = FP.fortranParser inp f + return (f, inp, fmap (const unitAnnotation) ast) +---- + rGetDirContents :: FileOrDir -> IO [String] rGetDirContents d = do ds <- getDirectoryContents d - ds' <- return $ ds \\ [".", ".."] -- remove '.' and '..' entries + let ds' = ds \\ [".", ".."] -- remove '.' and '..' entries rec ds' where - rec [] = return $ [] + rec [] = return [] rec (x:xs) = do xs' <- rec xs g <- doesDirectoryExist (d ++ "/" ++ x) if g then do x' <- rGetDirContents (d ++ "/" ++ x) return $ (map (\y -> x ++ "/" ++ y) x') ++ xs' else if isFortran x - then return $ x : xs' - else return $ xs' + then return (x : xs') + else return xs' {-| predicate on which fileextensions are Fortran files -} -isFortran x = elem (fileExt x) [".f", ".f90", ".f77", ".cmn", ".inc"] - -{-| Read a specific file, and parse it -} -readParseSrcFile :: Filename -> IO (Filename, String, Program A) -readParseSrcFile f = do - putStrLn f - inp <- readFile f - ast <- parse f - return $ (f, inp, map (fmap (const unitAnnotation)) ast) - - - -{-| parse file into an un-annotated Fortran AST -} -parse :: Filename -> IO (Program ()) -parse f = - let mode = ParseMode { parseFilename = f } - selectedParser = case (fileExt f) of - ".cmn" -> Fortran.include_parser - ".inc" -> Fortran.include_parser - _ -> Fortran.parser - - in do inp <- readFile f - -- There is a temporary fix here of adding a space at the start, - -- this is to deal with an alignment issue in the parser, - -- but will be removed when we move to the new parser. - case runParserWithMode mode selectedParser (' ' : pre_process inp) of - (ParseOk p) -> return $ p - (ParseFailed l e) -> error e +isFortran x = fileExt x `elem` [".f", ".f90", ".f77", ".cmn", ".inc"] {-| extract a filename's extension -} fileExt x = let ix = elemIndices '.' x - in if (length ix == 0) then "" + in if null ix then "" else Prelude.drop (Prelude.last ix) x + +-- | Read file using ByteString library and deal with any weird characters. +flexReadFile :: String -> IO B.ByteString +flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile diff --git a/src/Camfort/Output.hs b/src/Camfort/Output.hs --- a/src/Camfort/Output.hs +++ b/src/Camfort/Output.hs @@ -14,60 +14,40 @@ limitations under the License. -} -{-# LANGUAGE FlexibleInstances, UndecidableInstances, ImplicitParams, DoAndIfThenElse, - MultiParamTypeClasses, FlexibleContexts, KindSignatures, ScopedTypeVariables, - DeriveGeneric, DeriveDataTypeable #-} - -{- - - Provides support for outputting source files and analysis information +{-# LANGUAGE FlexibleInstances, UndecidableInstances, + DoAndIfThenElse, MultiParamTypeClasses, FlexibleContexts, + ScopedTypeVariables #-} --} +{- Provides support for outputting source files and analysis information -} module Camfort.Output where -import Camfort.Helpers -import Camfort.Traverse - import qualified Language.Fortran.AST as F -import qualified Language.Fortran.Util.Position as FU import qualified Language.Fortran.Analysis as FA - -import qualified Language.Fortran.Parser as Fortran -import Language.Fortran -import Language.Fortran.Pretty -import Language.Fortran.PreProcess +import qualified Language.Fortran.PrettyPrint as PP +import qualified Language.Fortran.Util.Position as FU +import qualified Language.Fortran.ParserMonad as FPM import Camfort.Analysis.Annotations -import Camfort.Analysis.Syntax -import Camfort.PrettyPrint import Camfort.Reprint -import Camfort.Transformation.Syntax - -import Camfort.Specification.Units.Environment +import Camfort.Helpers +import Camfort.Helpers.Syntax import System.FilePath import System.Directory --- FIXME: Did enough to get this module to compile, it's not optimised to use ByteString. import qualified Data.ByteString.Char8 as B -import Data.Map.Lazy hiding (map, foldl) -import Data.Functor.Identity import Data.Generics -import GHC.Generics +import Data.Functor.Identity import Data.List hiding (zip) import Data.Generics.Uniplate.Data -import Generics.Deriving.Copoint -import Data.Char import Data.Generics.Zipper -import Data.Maybe import Debug.Trace -import Text.Printf +import Control.Monad 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 @@ -83,6 +63,7 @@ text (if it exists) and their AST, write these to the directory -} mkOutputText :: FileOrDir -> t -> SourceText outputFile :: t -> Filename + isNewFile :: t -> Bool outputFiles :: FileOrDir -> FileOrDir -> [t] -> IO () outputFiles inp outp pdata = do @@ -90,174 +71,144 @@ inIsDir <- isDirectory inp inIsFile <- doesFileExist inp if outIsDir then do + -- Output to a directory, create if missing createDirectoryIfMissing True outp + -- Report which directory the files are going to putStrLn $ "Writing refactored files to directory: " ++ outp ++ "/" + -- If the input was a directory then work out the path prefix + -- which needs to be replaced with the new directory path isdir <- isDirectory inp let inSrc = if isdir then inp else getDir inp - mapM_ (\x -> let f' = changeDir outp inSrc (outputFile x) - in do checkDir f' - putStrLn $ "Writing " ++ f' - B.writeFile f' (mkOutputText outp x)) pdata + forM_ pdata (\x -> let f' = changeDir outp inSrc (outputFile x) + in do checkDir f' + putStrLn $ "Writing " ++ f' + B.writeFile f' (mkOutputText outp x)) else - if inIsDir || length pdata > 1 - then error $ "Error: attempting to output multiple files, but the \ - \given output destination is a single file. \n\ - \Please specify an output directory" - else - if inIsFile -- Input was just a file, then output just a file - then do - putStrLn $ "Writing refactored file to: " ++ outp - putStrLn $ "Writing " ++ outp - B.writeFile outp (mkOutputText outp (head pdata)) + forM_ pdata (\x -> do + let out = if isNewFile x then outputFile x else outp + putStrLn $ "Writing " ++ out + B.writeFile out (mkOutputText outp x)) - else let outSrc = getDir outp - in do createDirectoryIfMissing True outSrc - putStrLn $ "Writing refactored file to: " ++ outp - putStrLn $ "Writing " ++ outp - B.writeFile outp (mkOutputText outp (head pdata)) +{-| changeDir is used to change the directory of a filename string. + If the filename string has no directory then this is an identity -} +changeDir newDir oldDir oldFilename = + newDir ++ listDiffL oldDir oldFilename + where + listDiffL [] ys = ys + listDiffL xs [] = [] + listDiffL (x:xs) (y:ys) + | x==y = listDiffL xs ys + | otherwise = ys + -- When the new source text is already provided instance OutputFiles (Filename, SourceText) where mkOutputText _ (_, output) = output outputFile (f, _) = f - -data PR a = PR (Program a) deriving Data - -instance PrettyPrint (PR Annotation) where - prettyPrint (PR x) = prettyPrint x - --- When there is a file to be reprinted (for refactoring) -instance OutputFiles (Filename, SourceText, Program Annotation) where - mkOutputText f' (f, input, ast') = evalState (reprint refactoringLF (PR ast') input) 0 - where - outputFile (f, _, _) = f + isNewFile (_, inp) = B.null inp -- When there is a file to be reprinted (for refactoring) instance OutputFiles (Filename, SourceText, F.ProgramFile Annotation) where - mkOutputText f' (f, input, ast') = runIdentity $ reprint refactoringForPar ast' input - outputFile (f, _, _) = f - -srcSpanToSrcLocs :: FU.SrcSpan -> (SrcLoc, SrcLoc) -srcSpanToSrcLocs (FU.SrcSpan lpos upos) = (toSrcLoc lpos, toSrcLoc upos) - where - toSrcLoc pos = SrcLoc { srcFilename = "" - , srcLine = FU.posLine pos - , srcColumn = FU.posColumn pos } - -instance (PrettyPrint (F.ProgramFile Annotation)) where - -- STUB - prettyPrint _ = B.empty - -refactoringForPar :: (Typeable a) => a -> SourceText -> StateT SrcLoc Identity (SourceText, Bool) -refactoringForPar z inp = - ((\_ -> return (B.empty, False)) `extQ` (flip outputComments inp)) $ z - where - 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 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 (B.empty, False) - - -{-| changeDir is used to change the directory of a filename string. - If the filename string has no directory then this is an identity -} -changeDir newDir oldDir oldFilename = newDir ++ (listDiffL oldDir oldFilename) - where listDiffL [] ys = ys - listDiffL xs [] = [] - listDiffL (x:xs) (y:ys) | x==y = listDiffL xs ys - | otherwise = ys - -{-| output pre-analysis ASTs into the directory with the given file names (the list of ASTs should match the - list of filenames) -} -outputAnalysisFiles :: FileOrDir -> [Program Annotation] -> [Filename] -> IO () -outputAnalysisFiles src asts files = do - isdir <- isDirectory src - let src' = if isdir then src else dropFileName src - putStrLn $ "Writing analysis files to directory: " ++ src' - mapM (\(ast', f) -> writeFile (f ++ ".html") ((concatMap outputHTML) ast')) (zip asts files) - return () + mkOutputText f' (f, input, ast@(F.ProgramFile (F.MetaInfo version) _ _)) = + -- If we are create a file, call the pretty printer directly + if B.null input + then B.pack $ PP.pprintAndRender version ast (Just 0) + -- Otherwise, applying the refactoring system with reprint + else runIdentity $ reprint (refactoring version) ast input + outputFile (f, _, _) = f + isNewFile (_, inp, _) = B.null inp {- Specifies how to do specific refactorings - (uses generic query extension - remember extQ is non-symmetric) --} - -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) + (uses generic query extension - remember extQ is non-symmetric) -} +refactoring :: Typeable a + => FPM.FortranVersion + -> a -> SourceText -> StateT FU.Position Identity (SourceText, Bool) +refactoring v z inp = catchAll inp `extQ` refactorings inp $ z + where + catchAll :: SourceText -> a -> StateT FU.Position Identity (SourceText, Bool) + catchAll _ _ = return (B.empty, False) + refactorings inp z = + mapStateT (\n -> Identity $ n `evalState` 0) (refactorBlocks v inp z) -refactorFortran :: Monad m => SourceText -> Fortran Annotation -> StateT SrcLoc m (SourceText, Bool) -refactorFortran inp e = do +refactorBlocks :: FPM.FortranVersion + -> SourceText + -> F.Block Annotation + -> StateT FU.Position (State Int) (SourceText, Bool) +-- Output comments +refactorBlocks v inp e@(F.BlComment ann span comment) = do cursor <- get - if (pRefactored $ tag e) then - let (lb, ub) = srcSpan e - (p0, _) = takeBounds (cursor, lb) inp - 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) - + if pRefactored ann + then let (FU.SrcSpan lb ub) = span + lb' = leftOne lb + (p0, _) = takeBounds (cursor, lb') inp + nl = if null comment then B.empty else B.pack "\n" + in put ub >> return (B.concat [p0, B.pack comment, nl], True) + else return (B.empty, False) + where leftOne (FU.Position f c l) = FU.Position f (c-1) (l-1) -refactorDecl :: SourceText -> Decl Annotation -> StateT SrcLoc (State Int) (SourceText, Bool) -refactorDecl inp d = do +-- Refactor use statements +refactorBlocks v inp b@(F.BlStatement _ _ _ u@F.StUse{}) = do cursor <- get - if (pRefactored $ tag d) then - let (lb, ub) = srcSpan d - (p0, _) = takeBounds (cursor, lb) inp - 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 <- 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 - lift $ put (added - removed) - return text - otherwise -> return textOut - put ub - return (textOut', True) - else return (B.empty, False) + case refactored $ F.getAnnotation u of + Just (FU.Position _ rCol rLine) -> do + let (FU.SrcSpan lb _) = FU.getSpan u + let (p0, _) = takeBounds (cursor, lb) inp + let out = B.pack $ PP.pprintAndRender v b (Just (rCol -1)) + added <- lift get + when (newNode $ F.getAnnotation u) + (lift $ put $ added + countLines out) + put $ toCol0 lb + return (p0 `B.append` out, True) + Nothing -> return (B.empty, 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) +-- Common blocks, equivalence statements, and declarations can all +-- be refactored by the default refactoring +refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StEquivalence{}) = + refactorStatements v inp s +refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StCommon{}) = + refactorStatements v inp s +refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StDeclaration{}) = + refactorStatements v inp s +-- Arbitrary statements can be refactored *as blocks* (in order to +-- get good indenting) +refactorBlocks v inp b@F.BlStatement {} = refactorSyntax v inp b +refactorBlocks _ _ _ = return (B.empty, False) -refactorUses :: SourceText -> Uses Annotation -> StateT SrcLoc (State Int) (SourceText, Bool) -refactorUses inp u = do +-- Wrapper to fix the type of refactorSyntax to deal with statements +refactorStatements :: FPM.FortranVersion -> SourceText + -> F.Statement A -> StateT FU.Position (State Int) (SourceText, Bool) +refactorStatements = refactorSyntax + +refactorSyntax :: + (Typeable s, F.Annotated s, FU.Spanned (s A), PP.IndentablePretty (s A)) + => FPM.FortranVersion -> SourceText + -> s A -> StateT FU.Position (State Int) (SourceText, Bool) +refactorSyntax v inp e = do cursor <- get - let ?variant = HTMLPP in - case (refactored $ tag u) of - Just lb -> let (p0, _) = takeBounds (cursor, lb) inp - syntax = B.pack $ printSlave u - in do added <- lift get - if (newNode $ tag u) then lift $ put (added + (countLines syntax)) - else return () - put $ toCol0 lb - return (p0 `B.append` syntax, True) - Nothing -> return (B.empty, False) + let a = F.getAnnotation e + case refactored a of + Nothing -> return (B.empty, False) + Just (FU.Position _ rCol rLine) -> do + let (FU.SrcSpan lb ub) = FU.getSpan e + let (pre, _) = takeBounds (cursor, lb) inp + let indent = if newNode a then Just (rCol - 1) else Nothing + let output = if deleteNode a then B.empty + else B.pack $ PP.pprintAndRender v e indent + out <- if newNode a then do + -- If a new node is begin created then + numAdded <- lift get + let diff = linesCovered ub lb + -- remove empty newlines here if extra lines were added + let (out, numRemoved) = if numAdded <= diff + then removeNewLines output numAdded + else removeNewLines output diff + lift $ put (numAdded - numRemoved) + return out + else return output + put ub + return (B.concat [pre, out], True) countLines xs = case B.uncons xs of @@ -265,27 +216,26 @@ 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 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 xs 0 = (xs, 0) -- Deal with CR LF in the same way as just LF 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 + ("\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) diff --git a/src/Camfort/PrettyPrint.hs b/src/Camfort/PrettyPrint.hs deleted file mode 100644 --- a/src/Camfort/PrettyPrint.hs +++ /dev/null @@ -1,315 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} - -{-# LANGUAGE FlexibleInstances, UndecidableInstances, ImplicitParams, DoAndIfThenElse, - MultiParamTypeClasses, FlexibleContexts, KindSignatures, ScopedTypeVariables, - DeriveGeneric, DeriveDataTypeable #-} - -{- - - Provides pretty printing related code - --} - -module Camfort.PrettyPrint where - -import Camfort.Analysis.Syntax -import Camfort.Analysis.Annotations -import Camfort.Helpers -import Camfort.Traverse - -import qualified Language.Fortran as Fortran -import Language.Fortran.PreProcess -import Language.Fortran -import Language.Fortran.Pretty - -import Data.Map.Lazy hiding (map, foldl) -import qualified Data.ByteString.Char8 as B -import Data.Text hiding (zip,foldl,map,concatMap,take,drop,length,last,head,tail,replicate,concat) -import qualified Data.Text as Text -import Data.List -import Data.Generics.Uniplate.Data -import Data.Generics -import GHC.Generics -import Data.Char -import Data.Maybe -import Control.Monad.Trans.State.Lazy -import Text.Printf - -class PrettyPrint p where - prettyPrint :: p -> SourceText - -instance (PrintMaster (Program Annotation) DefaultPP) => PrettyPrint (Program Annotation) where - prettyPrint p = let ?variant = DefaultPP in B.pack $ printMaster p - --- Define new pretty printing version for HTML output -data HTMLPP = HTMLPP -instance PPVersion HTMLPP - -{-| Convert source code to a pretty-printed HTML format -} -outputHTMLA :: Fortran.ProgUnit Annotation -> String -outputHTMLA x = outputHTML x - -outputHTML :: forall p . (Data p, Typeable p, PrintSlave p HTMLPP, PrintSlave (Decl p) HTMLPP, PrintIndSlave (Fortran p) HTMLPP, Indentor (Decl p), Indentor (Fortran p)) => - Fortran.ProgUnit p -> String -outputHTML prog = unpack html - where - t :: SubName p -> SubName p - t (SubName p n) = SubName p (addColor blue n) - t x = x - - purple = "#800080" - green = "#008000" - blue = "#000080" - - toColor c t k = replace k (Text.concat [pack (""), k, pack ""]) t - addColor c k = "" ++ k ++ "" - pre l = Text.concat [pack "
", l, pack "
"] - types = map pack ["real", "integer", "character", "type", "logical"] - - html = let ?variant = HTMLPP - in - (Text.append (pack $ "" - ++ "")) - . (\t -> replace (pack "newline") (pack "\n") t) - . (Text.concat . (map pre) . Text.lines) - . (\t -> foldl (toColor green) t types) - . (\t -> foldl (toColor purple) t keyword) - . (pack . printMaster) - -- . (pack . output) - -- . (pack . paraBi (\p -> \ss -> (showPara p) ++ ss) "") - -- . (pack . (para (\p -> \ss -> showPara p ++ (Prelude.concat ss)))) - . (transformBi t) $ prog - -{- | Pretty printer for HTML, specialised to the analysis of CamFort, which mostly uses the default master - behaviour, but with a few special cases -} - -instance PrintSlave Bool HTMLPP where - printSlave = show - -instance PrintSlave SrcLoc HTMLPP where - printSlave _ = "" -- not sure if I want this to shown - -instance (PrintSlave (Decl p) HTMLPP, PrintIndSlave (Fortran p) HTMLPP, PrintSlave p HTMLPP, Indentor (Decl p), Indentor (Fortran p)) => PrintSlave (ProgUnit p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (DataForm p) HTMLPP where - printSlave = printMaster - -instance (PrintSlave (DataForm p) HTMLPP) => PrintSlave (SubName p) HTMLPP where - printSlave = printMaster - -instance (PrintSlave (Decl p) HTMLPP) => PrintSlave (Implicit p) HTMLPP where - printSlave = printMaster - -instance {-# OVERLAPPABLE #-} (Indentor (Decl p), PrintSlave (DataForm p) HTMLPP) => PrintSlave (Decl p) HTMLPP where - printSlave = printMaster - -instance {-# OVERLAPS #-} PrintSlave (Decl Annotation) HTMLPP where - printSlave t = let i = 0 - in "
" ++ (outputAnn (tag t) False i showt) ++ (annotationMark i t (printMaster t)) ++ "
" - where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t)) - - -instance PrintSlave (Type p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (VarName p) HTMLPP where - printSlave = printMaster - -instance (PrintSlave (DataForm p) HTMLPP) => PrintSlave (Expr p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (UnaryOp p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (BinOp p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (ArgList p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (BaseType p) HTMLPP where - printSlave = printMaster - -instance (PrintSlave (Decl p) HTMLPP, Indentor (Decl p)) => PrintSlave (InterfaceSpec p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Arg p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (ArgName p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (GSpec p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Attr p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Fraction p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (MeasureUnitSpec p) HTMLPP where - printSlave = printMaster - -instance (PrintSlave (Decl p) HTMLPP, PrintSlave (DataForm p) HTMLPP, PrintIndSlave (Fortran p) HTMLPP, PrintSlave p HTMLPP, Indentor (Fortran p), Indentor (Decl p)) => PrintSlave (Block p) HTMLPP where - printSlave = printMaster - -instance PrintSlave (Uses p) HTMLPP where - printSlave u = showUse' u - -showUse' :: Uses p -> String -showUse' (UseNil _) = "" -showUse' (Uses _ (Use n []) us _) = ("use "++n++"\n") ++ (showUse' us) -showUse' (Uses _ (Use n renames) us _) = ("use "++n++", " ++ (Prelude.concat $ Data.List.intersperse ", " (map (\(a, b) -> a ++ " => " ++ b) renames)) ++ "\n") ++ (showUse' us) - -instance (PrintIndSlave (Fortran p) HTMLPP, PrintSlave p HTMLPP, Indentor (Fortran p)) => PrintSlave (Fortran p) HTMLPP where - printSlave (For p _ v e e' e'' f) = "do"++" "++printSlave v++" = "++printSlave e++", "++ - printSlave e'++", "++printSlave e''++"\n"++ - ""++"{"++printSlave p++"}\n" ++ - (printIndSlave 1 f)++"\n"++(ind 1)++"end do" - printSlave t = printMaster t - -instance PrintSlave (Spec p) HTMLPP where - printSlave = printMaster - -instance Indentor (Fortran Bool) where - indR t i = if (tag t) then - let (s, SrcLoc f l c) = srcSpan t - in Prelude.take c (repeat ' ') - else ind i - -instance PrintIndSlave (Fortran A1) HTMLPP where - printIndSlave = printIndMaster - -instance PrintIndSlave (Fortran Annotation) HTMLPP where - - printIndSlave i t@(For p _ v e e' e'' f) = (outputAnn p False i (show t)) ++ - annotationMark i t - ((ind i) ++ "do"++" "++printSlave v++" = "++ - printSlave e++", "++ - printSlave e'++", "++printSlave e''++"\n"++ - (printIndSlave (i+1) f)++"\n"++(ind i)++"end do") - - - -- printIndSlave i t@(FSeq p f1 f2) = (outputAnn p False i) ++ printIndSlave i f1 ++ printIndSlave i f2 - printIndSlave i t = "
" ++ (outputAnn (rextract t) False i showt) ++ (annotationMark i t (printIndMaster i t)) ++ "
" - where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t)) - -{- -instance PrintIndSlave (Decl p) HTMLPP where - outputPrintSlave i t = "
" ++ (outputAnn (rextract t) False i showt) ++ (annotationMark i t (printIndMaster i t)) ++ "
" - where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t))x --} - -countToColor n = colors !! (n `mod` (length colors)) -- printf "#%06x" ((256*256*256 - (n * 40)) :: Int) - -colors = ["#ffeeee", "#eeffee", "#eeeeff", "#ffffee", - "#eeffff", "#eeffee", "#ffdddd", "#ddffdd", - "#ddddff", "#ffffdd", "#ffddff", "#ddffff", - "#eecccc", "#cceecc", "#eeeecc", "#ddeeee"] - -prettyp xs = prettyp' xs 0 [] -prettyp' [] n f = [] -prettyp' ('(':xs) n f = let k = "" - in if (nearbyClose xs 10) then - k ++ ('(':(prettyp' xs n (False:f))) - else - ("
" ++ (concat $ replicate (2 * (n+1)) " ")) ++ k ++ ('(' : (prettyp' xs (n+1) (True:f))) -prettyp' (')':xs) n (False:f) = ')' : ("" ++ prettyp' xs n f) -prettyp' (')':xs) n (True:f) = ')' : ("" ++ prettyp' xs (n - 1) f) -prettyp' (x:xs) n f = x : prettyp' xs n f - -nearbyClose [] n = False -nearbyClose _ 0 = False -nearbyClose ('(':(')':xs)) n = nearbyClose xs (n - 2) -nearbyClose (')':xs) n = True -nearbyClose (x:xs) n = nearbyClose xs (n - 1) - - -annotationMark i t x = "
" ++ - x ++ "
" - - -row xs = "" ++ (concatMap (\x -> "" ++ x ++ "") xs) ++ "" - -instance PrintSlave Annotation HTMLPP where - printSlave t = outputAnn t False 0 (show t) - -breakUp xs = breakup' xs 0 False - where breakup' [] _ _ = [] - breakup' (x:xs) c mode | x == '<' = x : (breakup' xs c True) - | x == '>' = x : (breakup' xs c False) - | c >= 80 && (not mode) = x : ("newline" ++ breakup' xs 0 False) - | mode = x : (breakup' xs c mode) - | otherwise = x : (breakup' xs (c+1) mode) - - -- (take 80 xs) ++ "newline" ++ (if (drop 80 xs) == [] then [] else breakUp (drop 80 xs)) - -outputAnn t visible i astString = - "
" ++ (indent 3 i) ++ "
" ++ - "
" ++ (show $ number t) ++ "
" ++ - "
" ++ - "show ast
" ++ (astString) ++ "
" ++ "

" ++ - row ["lives: (in) ", showList $ (map show) $ fst $ lives t, "(out)", showList $ (map show) $ snd $ lives t] ++ - row ["successors:", showList $ (map show) (successorStmts t)] ++ - "


\n\r\n" - where - listToPair x = "(" ++ listToPair' x ++ ")" - listToPair' [] = "" - listToPair' [x] = printMaster x - listToPair' (x:xs) = printMaster x ++ ", " ++ listToPair' xs - - showExps [] = "" - showExps [(v, es)] = "[" ++ v ++ ": " ++ (showList $ map listToPair es) ++ "]" - showExps ((v, es):ys) = (showExps [(v, es)]) ++ ", " ++ (showExps ys) - - - showList [] = "" - showList [x] = x - showList (x:xs) = x ++ ", " ++ showList xs - - -type A1 = Bool - - --- inBounds :: SrcLoc -> (SrcLoc, SrcLoc) -> Bool --- inBounds x (l,u) = (lineCol x) >= (lineCol l) && (lineCol x) < (lineCol u) - - -{- Indenting for refactored code -} - -instance Tagged p => Indentor (p Annotation) where - indR t i = case (refactored . tag $ t) of - Just (SrcLoc f _ c) -> Prelude.take c (repeat ' ') - Nothing -> ind i - -keyword = map pack - ["end","subroutine","function","program","module","data", "common", - "namelist", "external", "interface", "type", "include", "format", - "len", "kind", "dimension", "allocatable", "parameter", "external", - "intent", "intrinsic", "optional", "pointer", "save", "target", - "volatile", "public", "private", "sequence", "operator", "assignment", - "procedure", "do", "if", "else", "then", "allocate", "backspace", - "call", "open", "close", "continue", "cycle", "deallocate", "endfile", - "exit", "forall", "goto", "nullify", "inquire", "rewind", "stop", "where", - "write", "rerun", "print", "read", "write", "implicit", "use"] - diff --git a/src/Camfort/Reprint.hs b/src/Camfort/Reprint.hs --- a/src/Camfort/Reprint.hs +++ b/src/Camfort/Reprint.hs @@ -20,70 +20,69 @@ import Data.Generics.Zipper -import Camfort.PrettyPrint import Camfort.Analysis.Annotations -import Camfort.Traverse import Camfort.Helpers +import Camfort.Helpers.Syntax import qualified Data.ByteString.Char8 as B import Data.Functor.Identity import Data.Data import Control.Monad.Trans.State.Lazy - -import Language.Fortran -import Camfort.Analysis.Syntax +import qualified Language.Fortran.Util.Position as FU {- Reminder: -- type SourceText = B.ByteString - -- data SrcLoc - = SrcLoc {srcFilename :: String, srcLine :: Int, srcColumn :: Int} + -- data FU.Position = FU.Position { posAsbsoluteOffset :: Int, + posColumn :: Int, + posLine :: Int } -} -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" +-- performed. The state contains a FU.Position 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 Refactored = Bool type Refactoring m = - forall b . - Typeable b => b -> SourceText -> StateT SrcLoc m (SourceText, Refactored) + forall b . Typeable b + => b -> SourceText -> StateT FU.Position 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) +reprint :: (Monad m, Data p) => Refactoring m -> p -> SourceText -> m SourceText reprint refactoring tree input - -- If the inupt is null then switch into pretty printer - | B.null input = return $ prettyPrint tree + -- If the inupt is null then null is returned + | B.null input = return B.empty -- Otherwise go with the normal algorithm | 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 + -- Create an initial cursor at the start of the file + let cursor0 = FU.Position 0 0 1 + -- Enter the top-node of a zipper for 'tree' + -- setting the cursor at the start of the file + (out, cursorn) <- runStateT (enter refactoring (toZipper tree) input) cursor0 + -- Remove from the input the portion covered by the main algorithm + -- leaving the rest of the file not covered within the bounds of + -- the tree + let (_, remaining) = takeBounds (cursor0, cursorn) input + return $ out `B.append` remaining --- The enter, enterDown, enterRight each take a refactoring --- and a zipper producing a stateful SourceText transformer with SrcLoc state. +-- The enter, enterDown, enterRight each take a refactoring and a +-- zipper producing a stateful SourceText transformer with FU.Position +-- state. enter, enterDown, enterRight :: Monad m - => Refactoring m -> Zipper a -> SourceText -> StateT SrcLoc m SourceText + => Refactoring m -> Zipper a -> SourceText -> StateT FU.Position m SourceText -- `enter` applies the generic refactoring to the current context -- of the zipper @@ -92,7 +91,7 @@ -- Part 1. -- Apply a refactoring cursor <- get - (p1, refactored) <- query (flip refactoring inp) z + (p1, refactored) <- query (`refactoring` inp) z -- Part 2. -- Cut out the portion of source text consumed by the refactoring @@ -116,28 +115,30 @@ -- `enterDown` navigates to the children of the current context enterDown refactoring z inp = - case (down' z) of + case down' z of -- Go to children Just dz -> enter refactoring dz inp -- No children - Nothing -> return $ B.empty + Nothing -> return B.empty -- `enterRight` navigates to the right sibling of the current context enterRight refactoring z inp = - case (right z) of + case right z of -- Go to right sibling Just rz -> enter refactoring rz inp -- No right sibling - Nothing -> return $ B.empty + 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 +-- Given a lower-bound and upper-bound pair of FU.Positions, split the +-- incoming SourceText based on the distanceF between the FU.Position pairs +takeBounds :: (FU.Position, FU.Position) -> SourceText -> (SourceText, SourceText) +takeBounds (l, u) = takeBounds' ((ll, lc), (ul, uc)) B.empty + where (FU.Position _ lc ll) = l + (FU.Position _ uc ul) = u takeBounds' ((ll, lc), (ul, uc)) tk inp = if (ll == ul && lc == uc) || (ll > ul) then (B.reverse tk, inp) else case B.uncons inp of - Nothing -> (B.reverse tk, inp) - Just ('\n', ys) -> takeBounds' ((ll+1, 0), (ul, uc)) (B.cons '\n' tk) ys - Just (x, xs) -> takeBounds' ((ll, lc+1), (ul, uc)) (B.cons x tk) xs + 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 diff --git a/src/Camfort/Specification/Stencils.hs b/src/Camfort/Specification/Stencils.hs --- a/src/Camfort/Specification/Stencils.hs +++ b/src/Camfort/Specification/Stencils.hs @@ -15,7 +15,7 @@ -} module Camfort.Specification.Stencils - (InferMode, infer, check, synth, findVarFlowCycles) where + (InferMode, infer, check, synth) where import Control.Monad.State.Lazy import Control.Monad.Writer hiding (Product) @@ -49,20 +49,21 @@ -------------------------------------------------- -- Top-level of specification inference -infer :: InferMode -> Filename +infer :: InferMode -> Char -> Filename -> F.ProgramFile Annotation -> (String, F.ProgramFile Annotation) -infer mode filename pf = +infer mode marker filename pf = -- Append filename to any outputs if null output then ("", fmap FA.prevAnnotation pf'') else ("\n" ++ filename ++ "\n" ++ output, fmap FA.prevAnnotation pf'') where - output = (intercalate "\n") - . (filter (not . white)) + output = intercalate "\n" + . filter (not . white) . map (formatSpec Nothing nameMap) $ results white = all (\x -> (x == ' ') || (x == '\t')) - (pf'', results) = (stencilInference nameMap mode) . FAB.analyseBBlocks $ pf' + (pf'', results) = stencilInference nameMap mode marker + . FAB.analyseBBlocks $ pf' nameMap = FAR.extractNameMap pf' pf' = FAR.analyseRenames . FA.initAnalysis $ pf @@ -72,21 +73,23 @@ -- Top-level of specification synthesis synth :: InferMode + -> Char -> [(Filename, F.ProgramFile A)] -> (String, [(Filename, F.ProgramFile Annotation)]) -synth mode ps = foldr buildOutput ("", []) ps +synth mode marker = foldr buildOutput ("", []) where buildOutput (f, pf) (r, pfs) = (r ++ r', (f, pf') : pfs) - where (r', pf') = synthPF mode f pf + where (r', pf') = synthPF mode marker f pf -synthPF :: InferMode -> Filename +synthPF :: InferMode -> Char -> Filename -> F.ProgramFile Annotation -> (String, F.ProgramFile Annotation) -synthPF mode filename pf = +synthPF mode marker filename pf = -- Append filename to any outputs ("", fmap FA.prevAnnotation pf'') where - (pf'', _) = (stencilInference nameMap Synth) . FAB.analyseBBlocks $ pf' + (pf'', _) = stencilInference nameMap Synth marker + . FAB.analyseBBlocks $ pf' nameMap = FAR.extractNameMap pf' pf' = FAR.analyseRenames . FA.initAnalysis $ pf @@ -101,7 +104,7 @@ where output = intercalate "\n" results -- Applying checking mechanism - results = (stencilChecking nameMap) . FAB.analyseBBlocks $ pf' + results = stencilChecking nameMap . FAB.analyseBBlocks $ pf' nameMap = FAR.extractNameMap pf' pf' = FAR.analyseRenames . FA.initAnalysis $ pf diff --git a/src/Camfort/Specification/Stencils/Annotation.hs b/src/Camfort/Specification/Stencils/Annotation.hs --- a/src/Camfort/Specification/Stencils/Annotation.hs +++ b/src/Camfort/Specification/Stencils/Annotation.hs @@ -26,7 +26,7 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA - +import Debug.Trace {- *** Routines for associating annotations to ASTs -} diff --git a/src/Camfort/Specification/Stencils/CheckBackend.hs b/src/Camfort/Specification/Stencils/CheckBackend.hs --- a/src/Camfort/Specification/Stencils/CheckBackend.hs +++ b/src/Camfort/Specification/Stencils/CheckBackend.hs @@ -14,8 +14,11 @@ limitations under the License. -} -{-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances, - TupleSections, FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} module Camfort.Specification.Stencils.CheckBackend where @@ -60,10 +63,10 @@ instance SynToAst SYN.Specification (Either RegionEnv SpecDecls) where synToAst (SYN.SpecDec spec vars) = do spec' <- synToAst spec - return $ Right $ [(vars, spec')] + return $ Right [(vars, spec')] synToAst (SYN.RegionDec rvar region) = do - spec' <- synToAst $ region + spec' <- synToAst region return $ Left [(rvar, spec')] -- Convert temporal or spatial specifications @@ -71,18 +74,18 @@ synToAst (SYN.Spatial mods r) = do (modLinear, approx) <- synToAst mods r' <- synToAst r - let s' = Spatial modLinear r' - return $ Specification $ Left $ + let s' = Spatial r' + return $ Specification $ addLinearity modLinear $ case approx of Just SYN.AtMost -> Bound Nothing (Just s') Just SYN.AtLeast -> Bound (Just s') Nothing Nothing -> Exact s' - - synToAst (SYN.Temporal vars mutual) = - return $ Specification $ Right $ Dependency vars mutual + where + addLinearity Linear appr = Single appr + addLinearity NonLinear appr = Multiple appr -- Convert region definitions into the DNF-form used internally -instance SynToAst (SYN.Region) RegionSum where +instance SynToAst SYN.Region RegionSum where synToAst = dnf -- Convert a grammar syntax to Disjunctive Normal Form AST @@ -107,7 +110,7 @@ dnf (SYN.Var v) = case lookup v ?renv of Nothing -> Left $ "Error: region " ++ v ++ " is not in scope." - Just rs -> return $ rs + Just rs -> return rs -- Convert modifier list to modifier info instance SynToAst [SYN.Mod] diff --git a/src/Camfort/Specification/Stencils/CheckFrontend.hs b/src/Camfort/Specification/Stencils/CheckFrontend.hs --- a/src/Camfort/Specification/Stencils/CheckFrontend.hs +++ b/src/Camfort/Specification/Stencils/CheckFrontend.hs @@ -20,11 +20,9 @@ module Camfort.Specification.Stencils.CheckFrontend where -import Data.Data import Data.Generics.Uniplate.Operations import Control.Arrow import Control.Monad.State.Strict -import Control.Monad.Reader import Control.Monad.Writer.Strict hiding (Product) import Camfort.Specification.Stencils.CheckBackend @@ -41,19 +39,14 @@ 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 Data.Graph.Inductive.Graph hiding (isEmpty) import qualified Data.Map as M -import qualified Data.IntMap as IM -import qualified Data.Set as S import Data.Maybe import Data.List -import Debug.Trace -- Entry point stencilChecking :: FAR.NameMap -> F.ProgramFile (FA.Analysis A) -> [String] @@ -83,7 +76,7 @@ let ?nameMap = nameMap in descendBiM perProgramUnitCheck pf' -- Format output - let a@(_, output) = evalState (runWriterT $ results) (([], Nothing), ivmap) + let a@(_, output) = evalState (runWriterT results) (([], Nothing), ivmap) tell $ pprint output type LogLine = (FU.SrcSpan, String) @@ -110,26 +103,28 @@ updateRegionEnv :: FA.Analysis A -> Checker () updateRegionEnv ann = case stencilSpec (FA.prevAnnotation ann) of - Just (Right (Left regionEnv)) -> modify $ (((++) regionEnv) *** id) *** id + Just (Right (Left regionEnv)) -> modify $ first (first (regionEnv ++)) _ -> return () --- Given a mapping from variables to inferred specifications --- an environment of specification delcarations, for each declared --- specification check if there is a inferred specification that --- agrees with it, *up-to the model* -compareInferredToDeclared :: [([F.Name], Specification)] -> SpecDecls -> Bool -compareInferredToDeclared inferreds declareds = - all (\(names, dec) -> - all (\name -> - any (\inf -> eqByModel inf dec) (lookupAggregate inferreds name) - ) names) declareds +checkOffsetsAgainstSpec :: [(Variable, Multiplicity [[Int]])] + -> [(Variable, Specification)] + -> Bool +checkOffsetsAgainstSpec offsetMaps = + all (\(var1, Specification mult)-> + all (\(var2, offsets) -> + var1 /= var2 || noAllInfinity offsets `consistent` mult) offsetMaps) + where + noAllInfinity (Single a) = + Single $ filter (not . all (== absoluteRep)) a + noAllInfinity (Multiple a) = + Multiple $ filter (not . all (== absoluteRep)) a -- Go into the program units first and record the module name when -- entering into a module perProgramUnitCheck :: (?nameMap :: FAR.NameMap, ?flowsGraph :: FAD.FlowsGraph A) => F.ProgramUnit (FA.Analysis A) -> Checker (F.ProgramUnit (FA.Analysis A)) -perProgramUnitCheck p@(F.PUModule {}) = do - modify $ (id *** (const (Just $ FA.puName p))) *** id +perProgramUnitCheck p@F.PUModule{} = do + modify $ first (second (const (Just $ FA.puName p))) descendBiM perBlockCheck p perProgramUnitCheck p = descendBiM perBlockCheck p @@ -141,36 +136,47 @@ updateRegionEnv ann' let b' = F.setAnnotation ann' b case (stencilSpec $ FA.prevAnnotation ann', stencilBlock $ FA.prevAnnotation ann') of - -- Comment contains a specification and an associated block + -- Comment contains a specification and an Associated block (Just (Right (Right specDecls)), Just block) -> case block of - s@(F.BlStatement ann span _ (F.StExpressionAssign _ _ lhs rhs)) -> + s@(F.BlStatement ann span' _ (F.StExpressionAssign _ _ lhs rhs)) -> case isArraySubscript lhs of Just subs -> do -- Create list of relative indices - (_, ivmap) <- get + ivmap <- snd <$> get -- Do inference let realName v = v `fromMaybe` (v `M.lookup` ?nameMap) - let lhsN = maybe [] id (neighbourIndex ivmap subs) - let correctNames = map (\(names, spec) -> (map realName names, spec)) - let inferred = correctNames . fst . runWriter $ genSpecifications ivmap lhsN [s] + let lhsN = fromMaybe [] (neighbourIndex ivmap subs) + let correctNames = map (first realName) + let relOffsets = correctNames . fst . runWriter $ genOffsets ivmap lhsN [s] + let multOffsets = map (\relOffset -> + case relOffset of + (var, (True, offsets)) -> (var, Multiple offsets) + (var, (False, offsets)) -> (var, Single offsets)) relOffsets + let expandedDecls = + concatMap (\(vars,spec) -> map (flip (,) spec) vars) specDecls -- Model and compare the current and specified stencil specs - if compareInferredToDeclared inferred specDecls + if checkOffsetsAgainstSpec multOffsets expandedDecls then tell [ (span, "Correct.") ] - else tell [ (span, "Not well specified:\n\t\t expecting: " + else do + let correctNames2 = map (first (map realName)) + let inferred = correctNames2 . fst . runWriter $ genSpecifications ivmap lhsN [s] + tell [ (span, "Not well specified.\n" + ++ "\tSpecification is:\t " ++ pprintSpecDecls specDecls - ++ "\t\t inferred: " ++ pprintSpecDecls inferred) ] - return $ b' - Nothing -> return $ b' - _ -> return $ b' + ++ "\tbut at " ++ show span' ++ " the code behaves as" + ++ "\n\t \t " + ++ pprintSpecDecls inferred) ] + return b' + Nothing -> return b' - (F.BlDo ann span _ mDoSpec body) -> do + (F.BlDo ann span _ _ _ mDoSpec body _) -> -- Stub, maybe collect stencils inside 'do' block - return $ b' - _ -> return $ b' + return b' + _ -> return b' _ -> return b' -perBlockCheck b@(F.BlDo ann span _ mDoSpec body) = do +perBlockCheck b@(F.BlDo ann span _ _ _ mDoSpec body _) = do -- descend into the body of the do-statement mapM_ (descendBiM perBlockCheck) body -- Remove any induction variable from the state diff --git a/src/Camfort/Specification/Stencils/Grammar.hs b/src/Camfort/Specification/Stencils/Grammar.hs deleted file mode 100644 --- a/src/Camfort/Specification/Stencils/Grammar.hs +++ /dev/null @@ -1,1131 +0,0 @@ -{-# OPTIONS_GHC -w #-} --- -*- Mode: Haskell -*- -{-# LANGUAGE DeriveDataTypeable, PatternGuards #-} -module Camfort.Specification.Stencils.Grammar -( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where - -import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace) -import Data.List (intersect, sort, isPrefixOf) -import Data.Data - -import Debug.Trace - -import Camfort.Analysis.CommentAnnotator -import Camfort.Specification.Stencils.Syntax (showL) -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.19.5 - -data HappyAbsSyn - = HappyTerminal (Token) - | HappyErrorToken Int - | HappyAbsSyn4 (Specification) - | HappyAbsSyn5 ((String, Region)) - | HappyAbsSyn6 (Region) - | HappyAbsSyn7 (Bool) - | HappyAbsSyn8 (Spec) - | HappyAbsSyn9 (Mod) - | HappyAbsSyn10 ([Mod]) - | HappyAbsSyn12 ([String]) - -{- to allow type-synonyms as our monads (likely - - with explicitly-specified bind and return) - - in Haskell98, it seems that with - - /type M a = .../, then /(HappyReduction M)/ - - is not allowed. But Happy is a - - code-generator that can just substitute it. -type HappyReduction m = - Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> m HappyAbsSyn --} - -action_0, - action_1, - action_2, - action_3, - action_4, - action_5, - action_6, - action_7, - action_8, - action_9, - action_10, - action_11, - action_12, - action_13, - action_14, - action_15, - action_16, - action_17, - action_18, - action_19, - action_20, - action_21, - action_22, - action_23, - action_24, - action_25, - action_26, - action_27, - action_28, - action_29, - action_30, - action_31, - action_32, - action_33, - action_34, - action_35, - action_36, - action_37, - action_38, - action_39, - action_40, - action_41, - action_42, - action_43, - action_44, - action_45, - action_46, - action_47, - action_48, - action_49, - action_50, - action_51, - action_52, - action_53, - action_54, - action_55, - action_56, - action_57, - action_58, - action_59, - action_60, - action_61, - action_62, - action_63, - action_64, - action_65, - action_66, - action_67, - action_68, - action_69, - action_70, - action_71, - action_72, - action_73, - action_74, - action_75, - action_76 :: () => Int -> ({-HappyReduction (Either AnnotationParseError) = -} - Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn) - -happyReduce_1, - happyReduce_2, - happyReduce_3, - happyReduce_4, - happyReduce_5, - happyReduce_6, - happyReduce_7, - happyReduce_8, - happyReduce_9, - happyReduce_10, - happyReduce_11, - happyReduce_12, - happyReduce_13, - happyReduce_14, - happyReduce_15, - happyReduce_16, - happyReduce_17, - happyReduce_18, - happyReduce_19, - happyReduce_20, - happyReduce_21, - happyReduce_22, - happyReduce_23, - happyReduce_24, - happyReduce_25, - happyReduce_26 :: () => ({-HappyReduction (Either AnnotationParseError) = -} - Int - -> (Token) - -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn) - -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn) - -action_0 (13) = happyShift action_5 -action_0 (14) = happyShift action_3 -action_0 (4) = happyGoto action_4 -action_0 (5) = happyGoto action_2 -action_0 _ = happyFail - -action_1 (14) = happyShift action_3 -action_1 (5) = happyGoto action_2 -action_1 _ = happyFail - -action_2 _ = happyReduce_1 - -action_3 (28) = happyShift action_21 -action_3 _ = happyFail - -action_4 (37) = happyAccept -action_4 _ = happyFail - -action_5 (15) = happyShift action_11 -action_5 (16) = happyShift action_12 -action_5 (18) = happyShift action_13 -action_5 (19) = happyShift action_14 -action_5 (23) = happyShift action_15 -action_5 (24) = happyShift action_16 -action_5 (25) = happyShift action_17 -action_5 (26) = happyShift action_18 -action_5 (28) = happyShift action_19 -action_5 (34) = happyShift action_20 -action_5 (6) = happyGoto action_6 -action_5 (8) = happyGoto action_7 -action_5 (9) = happyGoto action_8 -action_5 (10) = happyGoto action_9 -action_5 (11) = happyGoto action_10 -action_5 _ = happyFail - -action_6 (30) = happyShift action_35 -action_6 (31) = happyShift action_36 -action_6 _ = happyReduce_19 - -action_7 (32) = happyShift action_34 -action_7 _ = happyFail - -action_8 (16) = happyShift action_12 -action_8 (23) = happyShift action_15 -action_8 (24) = happyShift action_16 -action_8 (25) = happyShift action_17 -action_8 (28) = happyShift action_19 -action_8 (34) = happyShift action_20 -action_8 (6) = happyGoto action_33 -action_8 _ = happyFail - -action_9 (15) = happyShift action_11 -action_9 (9) = happyGoto action_32 -action_9 _ = happyFail - -action_10 (16) = happyShift action_12 -action_10 (18) = happyShift action_13 -action_10 (19) = happyShift action_14 -action_10 (23) = happyShift action_15 -action_10 (24) = happyShift action_16 -action_10 (25) = happyShift action_17 -action_10 (28) = happyShift action_19 -action_10 (34) = happyShift action_20 -action_10 (6) = happyGoto action_29 -action_10 (10) = happyGoto action_30 -action_10 (11) = happyGoto action_31 -action_10 _ = happyReduce_22 - -action_11 _ = happyReduce_20 - -action_12 (34) = happyShift action_28 -action_12 _ = happyFail - -action_13 _ = happyReduce_23 - -action_14 _ = happyReduce_24 - -action_15 (34) = happyShift action_27 -action_15 _ = happyFail - -action_16 (34) = happyShift action_26 -action_16 _ = happyFail - -action_17 (34) = happyShift action_25 -action_17 _ = happyFail - -action_18 (34) = happyShift action_24 -action_18 _ = happyFail - -action_19 _ = happyReduce_11 - -action_20 (16) = happyShift action_12 -action_20 (23) = happyShift action_15 -action_20 (24) = happyShift action_16 -action_20 (25) = happyShift action_17 -action_20 (28) = happyShift action_19 -action_20 (34) = happyShift action_20 -action_20 (6) = happyGoto action_23 -action_20 _ = happyFail - -action_21 (33) = happyShift action_22 -action_21 _ = happyFail - -action_22 (16) = happyShift action_12 -action_22 (23) = happyShift action_15 -action_22 (24) = happyShift action_16 -action_22 (25) = happyShift action_17 -action_22 (28) = happyShift action_19 -action_22 (34) = happyShift action_20 -action_22 (6) = happyGoto action_48 -action_22 _ = happyFail - -action_23 (30) = happyShift action_35 -action_23 (31) = happyShift action_36 -action_23 (35) = happyShift action_47 -action_23 _ = happyFail - -action_24 (28) = happyShift action_40 -action_24 (12) = happyGoto action_46 -action_24 _ = happyFail - -action_25 (22) = happyShift action_45 -action_25 _ = happyFail - -action_26 (22) = happyShift action_44 -action_26 _ = happyFail - -action_27 (22) = happyShift action_43 -action_27 _ = happyFail - -action_28 (21) = happyShift action_42 -action_28 _ = happyFail - -action_29 (30) = happyShift action_35 -action_29 (31) = happyShift action_36 -action_29 _ = happyReduce_18 - -action_30 _ = happyReduce_21 - -action_31 (18) = happyShift action_13 -action_31 (19) = happyShift action_14 -action_31 (10) = happyGoto action_30 -action_31 (11) = happyGoto action_31 -action_31 _ = happyReduce_22 - -action_32 (16) = happyShift action_12 -action_32 (23) = happyShift action_15 -action_32 (24) = happyShift action_16 -action_32 (25) = happyShift action_17 -action_32 (28) = happyShift action_19 -action_32 (34) = happyShift action_20 -action_32 (6) = happyGoto action_41 -action_32 _ = happyFail - -action_33 (30) = happyShift action_35 -action_33 (31) = happyShift action_36 -action_33 _ = happyReduce_17 - -action_34 (28) = happyShift action_40 -action_34 (12) = happyGoto action_39 -action_34 _ = happyFail - -action_35 (16) = happyShift action_12 -action_35 (23) = happyShift action_15 -action_35 (24) = happyShift action_16 -action_35 (25) = happyShift action_17 -action_35 (28) = happyShift action_19 -action_35 (34) = happyShift action_20 -action_35 (6) = happyGoto action_38 -action_35 _ = happyFail - -action_36 (16) = happyShift action_12 -action_36 (23) = happyShift action_15 -action_36 (24) = happyShift action_16 -action_36 (25) = happyShift action_17 -action_36 (28) = happyShift action_19 -action_36 (34) = happyShift action_20 -action_36 (6) = happyGoto action_37 -action_36 _ = happyFail - -action_37 _ = happyReduce_9 - -action_38 (31) = happyShift action_36 -action_38 _ = happyReduce_8 - -action_39 _ = happyReduce_2 - -action_40 (28) = happyShift action_40 -action_40 (12) = happyGoto action_54 -action_40 _ = happyReduce_26 - -action_41 (30) = happyShift action_35 -action_41 (31) = happyShift action_36 -action_41 _ = happyReduce_16 - -action_42 (33) = happyShift action_53 -action_42 _ = happyFail - -action_43 (33) = happyShift action_52 -action_43 _ = happyFail - -action_44 (33) = happyShift action_51 -action_44 _ = happyFail - -action_45 (33) = happyShift action_50 -action_45 _ = happyFail - -action_46 (35) = happyShift action_49 -action_46 _ = happyFail - -action_47 _ = happyReduce_10 - -action_48 (30) = happyShift action_35 -action_48 (31) = happyShift action_36 -action_48 _ = happyReduce_3 - -action_49 (27) = happyShift action_59 -action_49 _ = happyReduce_14 - -action_50 (29) = happyShift action_58 -action_50 _ = happyFail - -action_51 (29) = happyShift action_57 -action_51 _ = happyFail - -action_52 (29) = happyShift action_56 -action_52 _ = happyFail - -action_53 (29) = happyShift action_55 -action_53 _ = happyFail - -action_54 _ = happyReduce_25 - -action_55 (35) = happyShift action_63 -action_55 _ = happyFail - -action_56 (21) = happyShift action_62 -action_56 _ = happyFail - -action_57 (21) = happyShift action_61 -action_57 _ = happyFail - -action_58 (21) = happyShift action_60 -action_58 _ = happyFail - -action_59 _ = happyReduce_15 - -action_60 (33) = happyShift action_66 -action_60 _ = happyFail - -action_61 (33) = happyShift action_65 -action_61 _ = happyFail - -action_62 (33) = happyShift action_64 -action_62 _ = happyFail - -action_63 _ = happyReduce_7 - -action_64 (29) = happyShift action_69 -action_64 _ = happyFail - -action_65 (29) = happyShift action_68 -action_65 _ = happyFail - -action_66 (29) = happyShift action_67 -action_66 _ = happyFail - -action_67 (17) = happyShift action_71 -action_67 (7) = happyGoto action_73 -action_67 _ = happyReduce_13 - -action_68 (17) = happyShift action_71 -action_68 (7) = happyGoto action_72 -action_68 _ = happyReduce_13 - -action_69 (17) = happyShift action_71 -action_69 (7) = happyGoto action_70 -action_69 _ = happyReduce_13 - -action_70 (35) = happyShift action_76 -action_70 _ = happyFail - -action_71 _ = happyReduce_12 - -action_72 (35) = happyShift action_75 -action_72 _ = happyFail - -action_73 (35) = happyShift action_74 -action_73 _ = happyFail - -action_74 _ = happyReduce_6 - -action_75 _ = happyReduce_5 - -action_76 _ = happyReduce_4 - -happyReduce_1 = happySpecReduce_1 4 happyReduction_1 -happyReduction_1 (HappyAbsSyn5 happy_var_1) - = HappyAbsSyn4 - (RegionDec (fst happy_var_1) (snd happy_var_1) - ) -happyReduction_1 _ = notHappyAtAll - -happyReduce_2 = happyReduce 4 4 happyReduction_2 -happyReduction_2 ((HappyAbsSyn12 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyAbsSyn8 happy_var_2) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn4 - (SpecDec happy_var_2 happy_var_4 - ) `HappyStk` happyRest - -happyReduce_3 = happyReduce 4 5 happyReduction_3 -happyReduction_3 ((HappyAbsSyn6 happy_var_4) `HappyStk` - _ `HappyStk` - (HappyTerminal (TId happy_var_2)) `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn5 - ((happy_var_2, happy_var_4) - ) `HappyStk` happyRest - -happyReduce_4 = happyReduce 10 6 happyReduction_4 -happyReduction_4 (_ `HappyStk` - (HappyAbsSyn7 happy_var_9) `HappyStk` - (HappyTerminal (TNum happy_var_8)) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyTerminal (TNum happy_var_5)) `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn6 - (Forward (read happy_var_5) (read happy_var_8) happy_var_9 - ) `HappyStk` happyRest - -happyReduce_5 = happyReduce 10 6 happyReduction_5 -happyReduction_5 (_ `HappyStk` - (HappyAbsSyn7 happy_var_9) `HappyStk` - (HappyTerminal (TNum happy_var_8)) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyTerminal (TNum happy_var_5)) `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn6 - (Backward (read happy_var_5) (read happy_var_8) happy_var_9 - ) `HappyStk` happyRest - -happyReduce_6 = happyReduce 10 6 happyReduction_6 -happyReduction_6 (_ `HappyStk` - (HappyAbsSyn7 happy_var_9) `HappyStk` - (HappyTerminal (TNum happy_var_8)) `HappyStk` - _ `HappyStk` - _ `HappyStk` - (HappyTerminal (TNum happy_var_5)) `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn6 - (Centered (read happy_var_5) (read happy_var_8) happy_var_9 - ) `HappyStk` happyRest - -happyReduce_7 = happyReduce 6 6 happyReduction_7 -happyReduction_7 (_ `HappyStk` - (HappyTerminal (TNum happy_var_5)) `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn6 - (Centered 0 (read happy_var_5) True - ) `HappyStk` happyRest - -happyReduce_8 = happySpecReduce_3 6 happyReduction_8 -happyReduction_8 (HappyAbsSyn6 happy_var_3) - _ - (HappyAbsSyn6 happy_var_1) - = HappyAbsSyn6 - (Or happy_var_1 happy_var_3 - ) -happyReduction_8 _ _ _ = notHappyAtAll - -happyReduce_9 = happySpecReduce_3 6 happyReduction_9 -happyReduction_9 (HappyAbsSyn6 happy_var_3) - _ - (HappyAbsSyn6 happy_var_1) - = HappyAbsSyn6 - (And happy_var_1 happy_var_3 - ) -happyReduction_9 _ _ _ = notHappyAtAll - -happyReduce_10 = happySpecReduce_3 6 happyReduction_10 -happyReduction_10 _ - (HappyAbsSyn6 happy_var_2) - _ - = HappyAbsSyn6 - (happy_var_2 - ) -happyReduction_10 _ _ _ = notHappyAtAll - -happyReduce_11 = happySpecReduce_1 6 happyReduction_11 -happyReduction_11 (HappyTerminal (TId happy_var_1)) - = HappyAbsSyn6 - (Var happy_var_1 - ) -happyReduction_11 _ = notHappyAtAll - -happyReduce_12 = happySpecReduce_1 7 happyReduction_12 -happyReduction_12 _ - = HappyAbsSyn7 - (False - ) - -happyReduce_13 = happySpecReduce_0 7 happyReduction_13 -happyReduction_13 = HappyAbsSyn7 - (True - ) - -happyReduce_14 = happyReduce 4 8 happyReduction_14 -happyReduction_14 (_ `HappyStk` - (HappyAbsSyn12 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn8 - (Temporal happy_var_3 False - ) `HappyStk` happyRest - -happyReduce_15 = happyReduce 5 8 happyReduction_15 -happyReduction_15 (_ `HappyStk` - _ `HappyStk` - (HappyAbsSyn12 happy_var_3) `HappyStk` - _ `HappyStk` - _ `HappyStk` - happyRest) - = HappyAbsSyn8 - (Temporal happy_var_3 True - ) `HappyStk` happyRest - -happyReduce_16 = happySpecReduce_3 8 happyReduction_16 -happyReduction_16 (HappyAbsSyn6 happy_var_3) - (HappyAbsSyn9 happy_var_2) - (HappyAbsSyn10 happy_var_1) - = HappyAbsSyn8 - (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3 - ) -happyReduction_16 _ _ _ = notHappyAtAll - -happyReduce_17 = happySpecReduce_2 8 happyReduction_17 -happyReduction_17 (HappyAbsSyn6 happy_var_2) - (HappyAbsSyn9 happy_var_1) - = HappyAbsSyn8 - (Spatial [happy_var_1] happy_var_2 - ) -happyReduction_17 _ _ = notHappyAtAll - -happyReduce_18 = happySpecReduce_2 8 happyReduction_18 -happyReduction_18 (HappyAbsSyn6 happy_var_2) - (HappyAbsSyn9 happy_var_1) - = HappyAbsSyn8 - (Spatial [happy_var_1] happy_var_2 - ) -happyReduction_18 _ _ = notHappyAtAll - -happyReduce_19 = happySpecReduce_1 8 happyReduction_19 -happyReduction_19 (HappyAbsSyn6 happy_var_1) - = HappyAbsSyn8 - (Spatial [] happy_var_1 - ) -happyReduction_19 _ = notHappyAtAll - -happyReduce_20 = happySpecReduce_1 9 happyReduction_20 -happyReduction_20 _ - = HappyAbsSyn9 - (ReadOnce - ) - -happyReduce_21 = happySpecReduce_2 10 happyReduction_21 -happyReduction_21 (HappyAbsSyn10 happy_var_2) - (HappyAbsSyn9 happy_var_1) - = HappyAbsSyn10 - (happy_var_1 : happy_var_2 - ) -happyReduction_21 _ _ = notHappyAtAll - -happyReduce_22 = happySpecReduce_1 10 happyReduction_22 -happyReduction_22 (HappyAbsSyn9 happy_var_1) - = HappyAbsSyn10 - ([happy_var_1] - ) -happyReduction_22 _ = notHappyAtAll - -happyReduce_23 = happySpecReduce_1 11 happyReduction_23 -happyReduction_23 _ - = HappyAbsSyn9 - (AtMost - ) - -happyReduce_24 = happySpecReduce_1 11 happyReduction_24 -happyReduction_24 _ - = HappyAbsSyn9 - (AtLeast - ) - -happyReduce_25 = happySpecReduce_2 12 happyReduction_25 -happyReduction_25 (HappyAbsSyn12 happy_var_2) - (HappyTerminal (TId happy_var_1)) - = HappyAbsSyn12 - (happy_var_1 : happy_var_2 - ) -happyReduction_25 _ _ = notHappyAtAll - -happyReduce_26 = happySpecReduce_1 12 happyReduction_26 -happyReduction_26 (HappyTerminal (TId happy_var_1)) - = HappyAbsSyn12 - ([happy_var_1] - ) -happyReduction_26 _ = notHappyAtAll - -happyNewToken action sts stk [] = - action 37 37 notHappyAtAll (HappyState action) sts stk [] - -happyNewToken action sts stk (tk:tks) = - let cont i = action i i tk (HappyState action) sts stk tks in - case tk of { - TId "stencil" -> cont 13; - TId "region" -> cont 14; - TId "readonce" -> cont 15; - TId "reflexive" -> cont 16; - TId "irreflexive" -> cont 17; - TId "atmost" -> cont 18; - TId "atleast" -> cont 19; - TId "dims" -> cont 20; - TId "dim" -> cont 21; - TId "depth" -> cont 22; - TId "forward" -> cont 23; - TId "backward" -> cont 24; - TId "centered" -> cont 25; - TId "dependency" -> cont 26; - TId "mutual" -> cont 27; - TId happy_dollar_dollar -> cont 28; - TNum happy_dollar_dollar -> cont 29; - TPlus -> cont 30; - TStar -> cont 31; - TDoubleColon -> cont 32; - TEqual -> cont 33; - TLParen -> cont 34; - TRParen -> cont 35; - TComma -> cont 36; - _ -> happyError' (tk:tks) - } - -happyError_ 37 tk tks = happyError' tks -happyError_ _ tk tks = happyError' (tk:tks) - -happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b -happyThen = (>>=) -happyReturn :: () => a -> Either AnnotationParseError a -happyReturn = (return) -happyThen1 m k tks = (>>=) m (\a -> k a tks) -happyReturn1 :: () => a -> b -> Either AnnotationParseError a -happyReturn1 = \a tks -> (return) a -happyError' :: () => [(Token)] -> Either AnnotationParseError a -happyError' = happyError - -parseSpec tks = happySomeParser where - happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll }) - -happySeq = happyDontSeq - - -data Specification - = RegionDec String Region - | SpecDec Spec [String] - deriving (Show, Eq, Ord, Typeable, Data) - -data Region - = Forward Int Int Bool - | Backward Int Int Bool - | Centered Int Int Bool - | Or Region Region - | And Region Region - | Var String - deriving (Show, Eq, Ord, Typeable, Data) - -data Spec - = Spatial [Mod] Region - | Temporal [String] Bool - deriving (Show, Eq, Ord, Typeable, Data) - -data Mod - = AtLeast - | AtMost - | ReadOnce - deriving (Show, Eq, Ord, Typeable, Data) - --------------------------------------------------- - -data Token - = TDoubleColon - | TStar - | TPlus - | TEqual - | TComma - | TLParen - | TRParen - | TId String - | TNum String - deriving (Show) - -addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] -addToTokens tok rest = do - tokens <- lexer' rest - return $ tok : tokens - -stripLeadingWhiteSpace (' ':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace ('\t':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace ('\n':xs) = stripLeadingWhiteSpace xs -stripLeadingWhiteSpace xs = xs - - -lexer :: String -> Either AnnotationParseError [ Token ] -lexer input | length (stripLeadingWhiteSpace input) >= 2 = - case stripLeadingWhiteSpace input of - -- Check the leading character is '=' for specification - '=':input' -> - -- First test to see if the input looks like an actual - -- specification of either a stencil or region - if (input' `hasPrefix` "stencil" || input' `hasPrefix` "region") - then lexer' input' - else Left NotAnnotation - _ -> Left NotAnnotation - where - hasPrefix [] str = False - hasPrefix (' ':xs) str = hasPrefix xs str - hasPrefix xs str = isPrefixOf str xs -lexer _ = Left NotAnnotation - - -lexer' :: String -> Either AnnotationParseError [ Token ] -lexer' [] = return [] -lexer' (' ':xs) = lexer' xs -lexer' ('\t':xs) = lexer' xs -lexer' (':':':':xs) = addToTokens TDoubleColon xs -lexer' ('*':xs) = addToTokens TStar xs -lexer' ('+':xs) = addToTokens TPlus xs -lexer' ('=':xs) = addToTokens TEqual xs --- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead. -lexer' (',':xs) - | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs') - | otherwise = addToTokens TComma xs -lexer' ('(':xs) = addToTokens TLParen xs -lexer' (')':xs) = addToTokens TRParen xs -lexer' (x:xs) - | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_' - | isNumber x = aux TNum isNumber - | otherwise - = failWith $ "Not an indentifier " ++ show x - where - aux f p = (f target :) `fmap` lexer' rest - where (target, rest) = span p (x:xs) -lexer' x - = failWith $ "Not a valid piece of stencil syntax " ++ show x - --------------------------------------------------- - --- specParser :: String -> Either AnnotationParseError Specification -specParser :: AnnotationParser Specification -specParser src = do - tokens <- lexer src - parseSpec tokens >>= modValidate - --- Check whether modifiers are used correctly -modValidate :: Specification -> Either AnnotationParseError Specification -modValidate (SpecDec (Spatial mods r) vars) = - do mods' <- modValidate' $ sort mods - return $ SpecDec (Spatial mods' r) vars - - where modValidate' [] = return $ [] - - modValidate' (AtLeast : AtLeast : xs) - = failWith "Duplicate 'atLeast' modifier; use at most one." - - modValidate' (AtMost : AtMost : xs) - = failWith "Duplicate 'atMost' modifier; use at most one." - - modValidate' (ReadOnce : ReadOnce : xs) - = failWith "Duplicate 'readOnce' modifier; use at most one." - - modValidate' (AtLeast : AtMost : xs) - = failWith $ "Conflicting modifiers: cannot use 'atLeast' and " - ++ "'atMost' together" - - modValidate' (x : xs) - = do xs' <- modValidate' xs - return $ x : xs' -modValidate x = return x - -happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = failWith $ "Could not parse specification at: " ++ show t -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} -{-# LINE 1 "" #-} -{-# LINE 16 "" #-} -{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-} - - - - - - - - - - - - - - - - - - -{-# LINE 17 "" #-} -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp - - -{-# LINE 13 "templates/GenericTemplate.hs" #-} - - -{-# LINE 46 "templates/GenericTemplate.hs" #-} - - - - - - - - - -{-# LINE 67 "templates/GenericTemplate.hs" #-} - - -{-# LINE 77 "templates/GenericTemplate.hs" #-} - - - - - - - - - - -infixr 9 `HappyStk` -data HappyStk a = HappyStk a (HappyStk a) - ------------------------------------------------------------------------------ --- starting the parse - -happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll - ------------------------------------------------------------------------------ --- Accepting the parse - --- If the current token is (1), it means we've just accepted a partial --- parse (a %partial parser). We must ignore the saved token on the top of --- the stack in this case. -happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = - (happyReturn1 ans) - ------------------------------------------------------------------------------ --- Arrays only: do the next action - - -{-# LINE 155 "templates/GenericTemplate.hs" #-} - ------------------------------------------------------------------------------ --- HappyState data type (not arrays) - - - -newtype HappyState b c = HappyState - (Int -> -- token number - Int -> -- token number (yes, again) - b -> -- token semantic value - HappyState b c -> -- current state - [HappyState b c] -> -- state stack - c) - - - ------------------------------------------------------------------------------ --- Shifting a token - -happyShift new_state (1) tk st sts stk@(x `HappyStk` _) = - let i = (case x of { HappyErrorToken (i) -> i }) in --- trace "shifting the error token" $ - new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk) - -happyShift new_state i tk st sts stk = - happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk) - --- happyReduce is specialised for the common cases. - -happySpecReduce_0 i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk - = action nt j tk st ((st):(sts)) (fn `HappyStk` stk) - -happySpecReduce_1 i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk') - = let r = fn v1 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_2 i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk') - = let r = fn v1 v2 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happySpecReduce_3 i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') - = let r = fn v1 v2 v3 in - happySeq r (action nt j tk st sts (r `HappyStk` stk')) - -happyReduce k i fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happyReduce k nt fn j tk st sts stk - = case happyDrop (k - ((1) :: Int)) sts of - sts1@(((st1@(HappyState (action))):(_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (action nt j tk st1 sts1 r) - -happyMonadReduce k nt fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happyMonadReduce k nt fn j tk st sts stk = - case happyDrop k ((st):(sts)) of - sts1@(((st1@(HappyState (action))):(_))) -> - let drop_stk = happyDropStk k stk in - happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk)) - -happyMonad2Reduce k nt fn (1) tk st sts stk - = happyFail (1) tk st sts stk -happyMonad2Reduce k nt fn j tk st sts stk = - case happyDrop k ((st):(sts)) of - sts1@(((st1@(HappyState (action))):(_))) -> - let drop_stk = happyDropStk k stk - - - - - - new_state = action - - in - happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - -happyDrop (0) l = l -happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t - -happyDropStk (0) l = l -happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs - ------------------------------------------------------------------------------ --- Moving to a new state after a reduction - - - - - - - - - -happyGoto action j tk st = action j j tk (HappyState action) - - ------------------------------------------------------------------------------ --- Error recovery ((1) is the error token) - --- parse error if we are in recovery and we fail again -happyFail (1) tk old_st _ stk@(x `HappyStk` _) = - let i = (case x of { HappyErrorToken (i) -> i }) in --- trace "failing" $ - happyError_ i tk - -{- We don't need state discarding for our restricted implementation of - "error". In fact, it can cause some bogus parses, so I've disabled it - for now --SDM - --- discard a state -happyFail (1) tk old_st (((HappyState (action))):(sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - action (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk)) --} - --- Enter error recovery: generate an error token, --- save the old token and carry on. -happyFail i tk (HappyState (action)) sts stk = --- trace "entering error recovery" $ - action (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk) - --- Internal happy errors: - -notHappyAtAll :: a -notHappyAtAll = error "Internal Happy error\n" - ------------------------------------------------------------------------------ --- Hack to get the typechecker to accept our action functions - - - - - - - ------------------------------------------------------------------------------ --- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq --- otherwise it emits --- happySeq = happyDontSeq - -happyDoSeq, happyDontSeq :: a -> b -> b -happyDoSeq a b = a `seq` b -happyDontSeq a b = b - ------------------------------------------------------------------------------ --- Don't inline any functions from the template. GHC has a nasty habit --- of deciding to inline happyGoto everywhere, which increases the size of --- the generated parser quite a bit. - - - - - - - - - -{-# NOINLINE happyShift #-} -{-# NOINLINE happySpecReduce_0 #-} -{-# NOINLINE happySpecReduce_1 #-} -{-# NOINLINE happySpecReduce_2 #-} -{-# NOINLINE happySpecReduce_3 #-} -{-# NOINLINE happyReduce #-} -{-# NOINLINE happyMonadReduce #-} -{-# NOINLINE happyGoto #-} -{-# NOINLINE happyFail #-} - --- end of Happy Template. - diff --git a/src/Camfort/Specification/Stencils/Grammar.y b/src/Camfort/Specification/Stencils/Grammar.y --- a/src/Camfort/Specification/Stencils/Grammar.y +++ b/src/Camfort/Specification/Stencils/Grammar.y @@ -25,14 +25,11 @@ irreflexive { TId "irreflexive" } atMost { TId "atmost" } atLeast { TId "atleast" } - dims { TId "dims" } dim { TId "dim" } depth { TId "depth" } forward { TId "forward" } backward { TId "backward" } centered { TId "centered" } - dependency { TId "dependency" } - mutual { TId "mutual" } id { TId $$ } num { TNum $$ } '+' { TPlus } @@ -41,7 +38,6 @@ '=' { TEqual } '(' { TLParen } ')' { TRParen } - ',' { TComma } %left '+' %left '*' @@ -55,24 +51,45 @@ REGIONDEC :: { (String, Region) } : region '::' id '=' REGION { ($3, $5) } -REGION :: { Region } -: forward '(' depth '=' num dim '=' num REFL ')' { Forward (read $5) (read $8) $9} -| backward '(' depth '=' num dim '=' num REFL ')' { Backward (read $5) (read $8) $9} -| centered '(' depth '=' num dim '=' num REFL ')' { Centered (read $5) (read $8) $9} -| reflexive '(' dim '=' num ')' { Centered 0 (read $5) True } -| REGION '+' REGION { Or $1 $3 } -| REGION '*' REGION { And $1 $3 } -| '(' REGION ')' { $2 } -| id { Var $1 } +REGION :: { Region } +: forward '(' REGION_ATTRS ')' { applyAttr Forward $3 } +| backward '(' REGION_ATTRS ')' { applyAttr Backward $3 } +| centered '(' REGION_ATTRS ')' { applyAttr Centered $3 } +| reflexive '(' dim '=' num ')' { Centered 0 (read $5) True } +| REGION '+' REGION { Or $1 $3 } +| REGION '*' REGION { And $1 $3 } +| '(' REGION ')' { $2 } +| id { Var $1 } +REGION_ATTRS :: { (Depth Int, Dim Int, Bool) } + : DEPTH DIM_REFL { ($1, fst $2, snd $2) } + | DIM DEPTH_REFL { (fst $2, $1, snd $2) } + | REFL DEPTH DIM { ($2, $3, $1) } + | REFL DIM DEPTH { ($3, $2, $1) } + +DIM_REFL :: { (Dim Int, Bool) } +DIM_REFL + : REFL DIM { ($2, $1) } + | DIM REFL { ($1, $2) } + | DIM { ($1, True) } + +DEPTH_REFL :: { (Depth Int, Bool) } +DEPTH_REFL + : DEPTH REFL { ($1, $2) } + | REFL DEPTH { ($2, $1) } + | DEPTH { ($1, True) } + +DEPTH :: { Depth Int } +DEPTH : depth '=' num { Depth $ read $3 } + +DIM :: { Dim Int } +DIM : dim '=' num { Dim $ read $3 } + REFL :: { Bool } : irreflexive { False } - | {- empty -} { True } SPECDEC :: { Spec } -: dependency '(' VARS ')' { Temporal $3 False } -| dependency '(' VARS ')' mutual { Temporal $3 True } -| APPROXMODS MOD REGION { Spatial ($1 ++ [$2]) $3 } +: APPROXMODS MOD REGION { Spatial ($1 ++ [$2]) $3 } | MOD REGION { Spatial [$1] $2 } | APPROXMOD REGION { Spatial [$1] $2 } | REGION { Spatial [] $1 } @@ -96,7 +113,14 @@ | id { [$1] } { +newtype Depth a = Depth a +newtype Dim a = Dim a +applyAttr :: (Int -> Int -> Bool -> Region) + -> (Depth Int, Dim Int, Bool) + -> Region +applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl + data Specification = RegionDec String Region | SpecDec Spec [String] @@ -111,9 +135,7 @@ | Var String deriving (Show, Eq, Ord, Typeable, Data) -data Spec - = Spatial [Mod] Region - | Temporal [String] Bool +data Spec = Spatial [Mod] Region deriving (Show, Eq, Ord, Typeable, Data) data Mod @@ -151,14 +173,18 @@ lexer input | length (stripLeadingWhiteSpace input) >= 2 = case stripLeadingWhiteSpace input of -- Check the leading character is '=' for specification - '=':input' -> - -- First test to see if the input looks like an actual - -- specification of either a stencil or region - if (input' `hasPrefix` "stencil" || input' `hasPrefix` "region") - then lexer' input' - else Left NotAnnotation + '=':input' -> testAnnotation input' + '!':input' -> testAnnotation input' + '>':input' -> testAnnotation input' + '<':input' -> testAnnotation input' _ -> Left NotAnnotation - where + where + testAnnotation inp = + -- First test to see if the input looks like an actual + -- specification of either a stencil or region + if (inp `hasPrefix` "stencil" || inp `hasPrefix` "region") + then lexer' inp + else Left NotAnnotation hasPrefix [] str = False hasPrefix (' ':xs) str = hasPrefix xs str hasPrefix xs str = isPrefixOf str xs diff --git a/src/Camfort/Specification/Stencils/InferenceBackend.hs b/src/Camfort/Specification/Stencils/InferenceBackend.hs --- a/src/Camfort/Specification/Stencils/InferenceBackend.hs +++ b/src/Camfort/Specification/Stencils/InferenceBackend.hs @@ -47,28 +47,28 @@ mkTrivialSpan a = (a, a) inferFromIndices :: VecList Int -> Specification -inferFromIndices (VL ixs) = - setLinearity (fromBool mult) (Specification . Left . infer $ ixs') - where - (ixs', mult) = hasDuplicates ixs - infer :: (IsNatural n, Permutable n) => [Vec n Int] -> Result Spatial - infer = simplify . fromRegionsToSpec . inferMinimalVectorRegions +inferFromIndices (VL ixs) = Specification $ + case fromBool mult of + Linear -> Single $ inferCore ixs' + NonLinear -> Multiple $ inferCore ixs' + where + (ixs', mult) = hasDuplicates ixs -- Same as inferFromIndices but don't do any linearity checking -- (defaults to NonLinear). This is used when the front-end does -- the linearity check first as an optimimsation. inferFromIndicesWithoutLinearity :: VecList Int -> Specification inferFromIndicesWithoutLinearity (VL ixs) = - Specification . Left . infer $ ixs - where - infer :: (IsNatural n, Permutable n) => [Vec n Int] -> Result Spatial - infer = simplify . fromRegionsToSpec . inferMinimalVectorRegions + Specification . Multiple . inferCore $ ixs -simplify :: Result Spatial -> Result Spatial +inferCore :: (IsNatural n, Permutable n) => [Vec n Int] -> Approximation Spatial +inferCore = simplify . fromRegionsToSpec . inferMinimalVectorRegions + +simplify :: Approximation Spatial -> Approximation Spatial simplify = fmap simplifySpatial simplifySpatial :: Spatial -> Spatial -simplifySpatial (Spatial lin (Sum ps)) = Spatial lin (Sum ps') +simplifySpatial (Spatial (Sum ps)) = Spatial (Sum ps') where ps' = order (reducor ps normaliseNoSort size) order = sort . (map (Product . sort . unProd)) size :: [RegionProd] -> Int @@ -88,51 +88,51 @@ else reducor' ys where y' = f y -fromRegionsToSpec :: IsNatural n => [Span (Vec n Int)] -> Result Spatial -fromRegionsToSpec sps = foldr (\x y -> sum (toSpecND x) y) zero sps +fromRegionsToSpec :: IsNatural n => [Span (Vec n Int)] -> Approximation Spatial +fromRegionsToSpec = foldr (\x y -> sum (toSpecND x) y) zero -- toSpecND converts an n-dimensional region into an exact -- spatial specification or a bound of spatial specifications -toSpecND :: Span (Vec n Int) -> Result Spatial +toSpecND :: Span (Vec n Int) -> Approximation Spatial toSpecND = toSpecPerDim 1 where -- convert the region one dimension at a time. - toSpecPerDim :: Int -> Span (Vec n Int) -> Result Spatial + toSpecPerDim :: Int -> Span (Vec n Int) -> Approximation Spatial toSpecPerDim d (Nil, Nil) = one toSpecPerDim d (Cons l ls, Cons u us) = prod (toSpec1D d l u) (toSpecPerDim (d + 1) (ls, us)) -- toSpec1D takes a dimension identifier, a lower and upper bound of a region in -- that dimension, and builds the simple directional spec. -toSpec1D :: Dimension -> Int -> Int -> Result Spatial +toSpec1D :: Dimension -> Int -> Int -> Approximation Spatial toSpec1D dim l u | l == absoluteRep || u == absoluteRep = - Exact $ Spatial NonLinear (Sum [Product []]) + Exact $ Spatial (Sum [Product []]) | l == 0 && u == 0 = - Exact $ Spatial NonLinear (Sum [Product [Centered 0 dim True]]) + Exact $ Spatial (Sum [Product [Centered 0 dim True]]) | l < 0 && u == 0 = - Exact $ Spatial NonLinear (Sum [Product [Backward (abs l) dim True]]) + Exact $ Spatial (Sum [Product [Backward (abs l) dim True]]) | l < 0 && u == (-1) = - Exact $ Spatial NonLinear (Sum [Product [Backward (abs l) dim False]]) + Exact $ Spatial (Sum [Product [Backward (abs l) dim False]]) | l == 0 && u > 0 = - Exact $ Spatial NonLinear (Sum [Product [Forward u dim True]]) + Exact $ Spatial (Sum [Product [Forward u dim True]]) | l == 1 && u > 0 = - Exact $ Spatial NonLinear (Sum [Product [Forward u dim False]]) + Exact $ Spatial (Sum [Product [Forward u dim False]]) | l < 0 && u > 0 && (abs l == u) = - Exact $ Spatial NonLinear (Sum [Product [Centered u dim True]]) + Exact $ Spatial (Sum [Product [Centered u dim True]]) | l < 0 && u > 0 && (abs l /= u) = - Exact $ Spatial NonLinear (Sum [Product [Backward (abs l) dim True], - Product [Forward u dim True]]) + Exact $ Spatial (Sum [Product [Backward (abs l) dim True], + Product [Forward u dim True]]) -- Represents a non-contiguous region | otherwise = - upperBound $ Spatial NonLinear (Sum [Product + upperBound $ Spatial (Sum [Product [if l > 0 then Forward u dim True else Backward (abs l) dim True]]) {- Normalise a span into the form (lower, upper) based on the first index -} diff --git a/src/Camfort/Specification/Stencils/InferenceFrontend.hs b/src/Camfort/Specification/Stencils/InferenceFrontend.hs --- a/src/Camfort/Specification/Stencils/InferenceFrontend.hs +++ b/src/Camfort/Specification/Stencils/InferenceFrontend.hs @@ -79,28 +79,26 @@ 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) + (ReaderT (FAD.FlowsGraph A) (State InferState)) -type Cycles = [(F.Name, F.Name)] - type Params = (?flowsGraph :: FAD.FlowsGraph A, ?nameMap :: FAR.NameMap) runInferer :: FAD.InductionVarMapByASTBlock - -> Cycles - -> F.ProgramUnitName + -> FAD.FlowsGraph A -> Inferer a -> (a, [LogLine]) -runInferer ivmap cycles puName = +runInferer ivmap flTo = flip evalState (IS ivmap []) - . flip runReaderT (cycles, puName) + . flip runReaderT flTo . runWriterT stencilInference :: FAR.NameMap -> InferMode + -> Char -> F.ProgramFile (FA.Analysis A) -> (F.ProgramFile (FA.Analysis A), [LogLine]) -stencilInference nameMap mode pf = +stencilInference nameMap mode marker pf = (F.ProgramFile mi cm_pus' blocks', log1 ++ log2) where -- Parse specification annotations and include them into the syntax tree @@ -114,10 +112,10 @@ else (pf, []) (cm_pus', log1) = runWriter (transformBiM perPU cm_pus) - (blocks', log2) = runInferer ivMap [] F.NamelessBlockData blocksInf + (blocks', log2) = runInferer ivMap flTo blocksInf blocksInf = let ?flowsGraph = flTo ?nameMap = nameMap - in descendBiM (perBlockInfer mode) blocks + in descendBiM (perBlockInfer mode marker) blocks -- Run inference per program unit, placing the flowsmap in scope perPU :: F.ProgramUnit (FA.Analysis A) @@ -127,8 +125,8 @@ let ?flowsGraph = flTo ?nameMap = nameMap in do - let pum = descendBiM (perBlockInfer mode) pu - let (pu', log) = runInferer ivMap [] (FA.puName pu) pum + let pum = descendBiM (perBlockInfer mode marker) pu + let (pu', log) = runInferer ivMap flTo pum tell log return pu' perPU pu = return pu @@ -155,26 +153,6 @@ -- get map of variable name ==> { defining AST-Block-IDs } dm = FAD.genDefMap bm --- | Return list of variable names that flow into themselves via a 2-cycle -findVarFlowCycles :: Data a => F.ProgramFile a -> [(F.Name, F.Name)] -findVarFlowCycles = FAR.underRenaming (findVarFlowCycles' . FAB.analyseBBlocks) -findVarFlowCycles' pf = cycs2 - where - bm = FAD.genBlockMap pf -- get map of AST-Block-ID ==> corresponding AST-Block - bbm = FAB.genBBlockMap pf -- get map of program unit ==> basic block graph - sgr = FAB.genSuperBBGr bbm -- stitch all of the graphs together into a 'supergraph' - gr = FAB.superBBGrGraph sgr -- extract the supergraph itself - dm = FAD.genDefMap bm -- get map of variable name ==> { defining AST-Block-IDs } - rd = FAD.reachingDefinitions dm gr -- perform reaching definitions analysis - flTo = FAD.genFlowsToGraph bm dm gr rd -- create graph of definition "flows" - -- VarFlowsToMap: A -> { B, C } indicates that A contributes to B, C. - flMap = FAD.genVarFlowsToMap dm flTo -- create VarFlowsToMap - -- find 2-cycles: A -> B -> A - cycs2 = [ (n, m) | (n, ns) <- M.toList flMap - , m <- S.toList ns - , ms <- maybeToList $ M.lookup m flMap - , n `S.member` ms && n /= m ] - {- *** 1 . Core inference over blocks -} genSpecsAndReport :: Params @@ -211,9 +189,10 @@ -- Traverse Blocks in the AST and infer stencil specifications perBlockInfer :: Params - => InferMode -> F.Block (FA.Analysis A) -> Inferer (F.Block (FA.Analysis A)) + => InferMode -> Char -> F.Block (FA.Analysis A) + -> Inferer (F.Block (FA.Analysis A)) -perBlockInfer Synth b@(F.BlComment ann span _) = do +perBlockInfer Synth _ b@(F.BlComment ann span _) = do -- If we have a comment that is actually a specification then record that -- this has been assigned so that we don't generate extra specifications -- that overlap with user-given oones @@ -231,7 +210,7 @@ _ -> return () return b -perBlockInfer mode b@(F.BlStatement ann span@(FU.SrcSpan lp up) _ stmnt) +perBlockInfer mode marker b@(F.BlStatement ann span@(FU.SrcSpan lp up) _ stmnt) | mode == AssignMode || mode == CombinedMode || mode == EvalMode || mode == Synth = do -- On all StExpressionAssigns that occur in stmt.... let lhses = [lhs | (F.StExpressionAssign _ _ lhs _) @@ -256,7 +235,7 @@ _ -> return []) if mode == Synth && not (null specs) then - let specComment = Synth.formatSpec (Just (tabs ++ "!= ")) ?nameMap (span, Left (concat specs')) + let specComment = Synth.formatSpec (Just (tabs ++ '!':marker:" ")) ?nameMap (span, Left (concat specs')) specs' = map (mapMaybe noSpecAlready) specs noSpecAlready (vars, spec) = if null vars' @@ -265,13 +244,13 @@ where vars' = filter (\v -> not ((span, realName v) `elem` hasSpec)) vars realName v = v `fromMaybe` (v `M.lookup` ?nameMap) tabs = take (FU.posColumn lp - 1) (repeat ' ') - loc = fst $ O.srcSpanToSrcLocs span + (FU.SrcSpan loc _) = span span' = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) ann' = ann { FA.prevAnnotation = (FA.prevAnnotation ann) { refactored = Just loc } } in return $ F.BlComment ann' span' specComment else return b -perBlockInfer mode b@(F.BlDo ann span x mDoSpec body) = do +perBlockInfer mode marker b@(F.BlDo ann span lab cname lab' mDoSpec body tlab) = do -- introduce any induction variables into the induction variable state if (mode == DoMode || mode == CombinedMode) && isStencilDo b @@ -279,13 +258,13 @@ else return [] -- descend into the body of the do-statement - body' <- mapM (descendBiM (perBlockInfer mode)) body + body' <- mapM (descendBiM (perBlockInfer mode marker)) body -- Remove any induction variable from the state - return $ F.BlDo ann span x mDoSpec body' + return $ F.BlDo ann span lab cname lab' mDoSpec body' tlab -perBlockInfer mode b = do +perBlockInfer mode marker b = do -- Go inside child blocks - mapM_ (descendBiM (perBlockInfer mode)) $ children b + mapM_ (descendBiM (perBlockInfer mode marker)) $ children b return b genSpecifications :: Params @@ -309,15 +288,32 @@ . M.mapWithKey (\v -> indicesToSpec ivs v lhs) . M.unionsWith (++) - strength :: Monad m => (a, m b) -> m (a, b) - strength (a, mb) = mb >>= (\b -> return (a, b)) - splitUpperAndLower = concatMap splitUpperAndLower' - splitUpperAndLower' (vs, Specification (Left (Bound (Just l) (Just u)))) = - [(vs, Specification (Left (Bound (Just l) Nothing))), - (vs, Specification (Left (Bound Nothing (Just u))))] + splitUpperAndLower' (vs, Specification (Multiple (Bound (Just l) (Just u)))) = + [(vs, Specification (Multiple (Bound (Just l) Nothing))), + (vs, Specification (Multiple (Bound Nothing (Just u))))] + splitUpperAndLower' (vs, Specification (Single (Bound (Just l) (Just u)))) = + [(vs, Specification (Single (Bound (Just l) Nothing))), + (vs, Specification (Single (Bound Nothing (Just u))))] splitUpperAndLower' x = [x] +genOffsets :: Params + => FAD.InductionVarMapByASTBlock + -> [Neighbour] + -> [F.Block (FA.Analysis A)] + -> Writer EvalLog [(Variable, (Bool, [[Int]]))] +genOffsets ivs lhs blocks = do + let subscripts = evalState (mapM (genSubscripts True) blocks) [] + varToMaybeSpecs <- sequence . map strength . mkOffsets $ subscripts + return $ catMaybes . map strength $ varToMaybeSpecs + where + mkOffsets = M.toList + . M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs) + . M.unionsWith (++) + +strength :: Monad m => (a, m b) -> m (a, b) +strength (a, mb) = mb >>= (\b -> return (a, b)) + -- Generate all subscripting expressions (that are translations on -- induction variables) that flow to this block -- The State monad provides a list of the visited nodes so far @@ -366,7 +362,7 @@ getInductionVar _ = [] isStencilDo :: F.Block (FA.Analysis A) -> Bool -isStencilDo b@(F.BlDo _ span _ mDoSpec body) = +isStencilDo b@(F.BlDo _ span _ _ _ mDoSpec body _) = -- Check to see if the body contains any affine use of the induction variable -- as a subscript case getInductionVar mDoSpec of @@ -396,6 +392,18 @@ -> [[F.Index (FA.Analysis Annotation)]] -> Writer EvalLog (Maybe Specification) indicesToSpec ivs a lhs ixs = do + mMultOffsets <- indicesToRelativisedOffsets ivs a lhs ixs + return $ do + (mult, offsets) <- mMultOffsets + let spec = relativeIxsToSpec offsets + fmap (setLinearity (fromBool mult)) spec + +indicesToRelativisedOffsets :: FAD.InductionVarMapByASTBlock + -> Variable + -> [Neighbour] + -> [[F.Index (FA.Analysis Annotation)]] + -> Writer EvalLog (Maybe (Bool, [[Int]])) +indicesToRelativisedOffsets ivs a lhs ixs = do -- Convert indices to neighbourhood representation let rhses = map (map (ixToNeighbour ivs)) ixs @@ -423,14 +431,11 @@ let offsets = padZeros $ map (fromJust . mapM neighbourToOffset) rhses'' tell [("EVALMODE: dimensionality=" ++ - show (case offsets of [] -> 0 - _ -> length (head offsets)), a)] - - - let spec = relativeIxsToSpec offsets - return $ fmap (setLinearity (fromBool mult)) spec + show (if null offsets then 0 else length . head $ offsets), a)] + return (Just $ (mult, offsets)) where hasNonNeighbourhoodRelatives xs = or (map (any ((==) NonNeighbour)) xs) + -- Given a list of the neighbourhood representation for the LHS, of size n -- and a list of size-n lists of offsets, relativise the offsets relativise :: [Neighbour] -> [[Neighbour]] -> [[Neighbour]] @@ -575,8 +580,6 @@ <- universeBi e :: [F.Expression (FA.Analysis a)] , let i = FA.varName e , i `elem` ivs] - -expToNeighbour ivs e = Constant (F.ValInteger "0") -------------------------------------------------- diff --git a/src/Camfort/Specification/Stencils/Model.hs b/src/Camfort/Specification/Stencils/Model.hs --- a/src/Camfort/Specification/Stencils/Model.hs +++ b/src/Camfort/Specification/Stencils/Model.hs @@ -37,50 +37,46 @@ import qualified Data.List as DL import qualified Data.Map as DM -import Debug.Trace - --- Relative multi-dimensional indices are represented by [Int] --- e.g. [0, 1, -1] corresponds to a subscript expression a(i, j+1, k-1) --- Specifications are mapped to (multi)sets of [Int] where --- the multiset representation is a Map to Bool giving --- False = multiplicity 1, True = multiplicity > 1 - -model :: Result Spatial -> Result (Multiset [Int]) -model s = let ?globalDimensionality = dimensionality s - in mkModel s +{-| This function maps inner representation to a set of vectors of length +- given by `dim`. This is the mathematical representation of the +- specification. |-} +model :: Multiplicity (Approximation Spatial) + -> Int + -> Multiplicity (Approximation (Set [Int])) +model s dims = + let ?globalDimensionality = dims + in mkModel s --- Is an inferred specification equal to a declared specification, --- up to the mode? The first parameter must come from the inference and --- the second from a user-given declaration -eqByModel :: Specification -> Specification -> Bool -eqByModel infered declared = - let d1 = dimensionality infered - d2 = dimensionality declared - in let ?globalDimensionality = d1 `max` d2 - in let modelInf = mkModel infered - modelDec = mkModel declared - in case (modelInf, modelDec) of - -- Test approximations first +consistent :: Multiplicity [[Int]] + -> Multiplicity (Approximation Spatial) + -> Bool +-- If the specification says "readOnce" but there are duplicates among +-- offsets, then there is no consistency. +-- +-- Note that if the spec omits "readOnce" and the offsets happen to be +-- unique that is allowed as "readOnce" is an extra qualifier. +consistent (Multiple _) (Single _) = False +consistent mult1 spec = + consistent' (model spec dimensionality) + where + dimensionality = length . head $ accesses + consistent' m2 = + case fromMult m2 of + Exact unifiers -> + consistent' (Multiple (Bound Nothing (Just unifiers))) && + consistent' (Multiple (Bound (Just unifiers) Nothing)) + Bound lus@Just{} uus@Just{} -> + consistent' (Multiple (Bound lus Nothing)) && + consistent' (Multiple (Bound Nothing uus)) + Bound Nothing (Just unifiers) -> + all (\access -> any (access `accepts`) unifiers) accesses + Bound (Just unifiers) Nothing -> + all (\unifier -> any (`accepts` unifier) accesses) unifiers - -- If only one bound is present in one model, but both are in the - -- other, then compare only the bounds present in both - (Bound (Just mdlLI) Nothing, Bound (Just mdlLD) _) - -> mdlLD <= mdlLI - (Bound Nothing (Just mdlUI), Bound _ (Just mdlUD)) - -> mdlUI <= mdlUD - (Bound (Just mdlLI) (Just _), Bound (Just mdlLD) Nothing) - -> mdlLD <= mdlLI - (Bound (Just _ ) (Just mdlUI), Bound Nothing (Just mdlUD)) - -> mdlUI <= mdlUD - (Exact s, Bound Nothing (Just mdlUD)) - -> s <= mdlUD - (Exact s, Bound (Just mdlLD) Nothing) - -> mdlLD <= s - (Exact s, Bound (Just mdlLD) (Just mdlUD)) - -> (mdlLD <= s) && (s <= mdlUD) - -- Otherwise do the normal comparison - (x, y) -> x == y + accesses = fromMult mult1 + access `accepts` unifier = + all (\(u,v) -> v == absoluteRep || u == v) (zip access unifier) -- Recursive `Model` class implemented for all parts of the spec. class Model spec where @@ -98,38 +94,37 @@ -- Return all the dimensions specified for in this spec dimensions :: spec -> [Int] --- Multiset representation where multiplicities are (-1) modulo 2 +-- Set representation where multiplicities are (-1) modulo 2 -- that is, False = multiplicity 1, True = multiplicity > 1 -type Multiset a = DM.Map a Bool +instance Model Specification where + type Domain Specification = Multiplicity (Approximation (Set [Int])) --- Build a multiset representation from a list (of possibly repeated) elements -mkMultiset :: Ord a => [a] -> DM.Map a Bool -mkMultiset = - Prelude.foldr (\a map -> DM.insertWithKey multi a True map) DM.empty - where multi k x y = x || y + mkModel (Specification s) = mkModel s -instance Model Specification where - type Domain Specification = Result (Multiset [Int]) + dimensionality (Specification s) = dimensionality s - mkModel (Specification (Left s)) = mkModel s - mkModel _ = error "Only spatial specs are modelled" + dimensions (Specification s) = dimensions s - dimensionality (Specification (Left s)) = dimensionality s - dimensionality _ = 0 +instance Model (Multiplicity (Approximation Spatial)) where + type Domain (Multiplicity (Approximation Spatial)) = + Multiplicity (Approximation (Set [Int])) - dimensions (Specification (Left s)) = dimensions s - dimensions _ = [0] + mkModel (Multiple s) = Multiple (mkModel s) + mkModel (Single s) = Single (mkModel s) --- Model a 'Result' of 'Spatial' -instance Model (Result Spatial) where - type Domain (Result Spatial) = Result (Multiset [Int]) + dimensionality mult = dimensionality $ fromMult mult + dimensions mult = dimensions $ fromMult mult + +instance Model (Approximation Spatial) where + type Domain (Approximation Spatial) = Approximation (Set [Int]) + mkModel = fmap mkModel dimensionality (Exact s) = dimensionality s - dimensionality (Bound l u) = (dimensionality l) `max` (dimensionality u) + dimensionality (Bound l u) = dimensionality l `max` dimensionality u dimensions (Exact s) = dimensions s - dimensions (Bound l u) = (dimensions l) ++ (dimensions u) + dimensions (Bound l u) = dimensions l ++ dimensions u -- Lifting of model to Maybe type instance Model a => Model (Maybe a) where @@ -143,18 +138,13 @@ -- Core part of the model instance Model Spatial where - type Domain Spatial = Multiset [Int] + type Domain Spatial = Set [Int] - mkModel spec@(Spatial lin s) = - case lin of - Linear -> DM.fromList . map (,False) . toList $ indices - NonLinear -> DM.fromList . map (,True) . toList $ indices - where - indices = mkModel s + mkModel (Spatial s) = mkModel s - dimensionality (Spatial _ s) = dimensionality s + dimensionality (Spatial s) = dimensionality s - dimensions (Spatial _ s) = dimensions s + dimensions (Spatial s) = dimensions s instance Model RegionSum where diff --git a/src/Camfort/Specification/Stencils/Syntax.hs b/src/Camfort/Specification/Stencils/Syntax.hs --- a/src/Camfort/Specification/Stencils/Syntax.hs +++ b/src/Camfort/Specification/Stencils/Syntax.hs @@ -19,7 +19,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DeriveFunctor #-} module Camfort.Specification.Stencils.Syntax where @@ -42,21 +42,21 @@ {- *** 0. Representations -} -- Representation of an inference result, either exact or with some bound -data Result a = +data Approximation a = Exact a | Bound (Maybe a) (Maybe a) deriving (Eq, Data, Typeable, Show) -fromExact :: Result a -> a +fromExact :: Approximation a -> a fromExact (Exact a) = a fromExact _ = error "Exception: fromExact on a non-exact result" -upperBound :: a -> Result a +upperBound :: a -> Approximation a upperBound x = Bound Nothing (Just x) -lowerBound :: a -> Result a +lowerBound :: a -> Approximation a lowerBound x = Bound (Just x) Nothing -instance Functor Result where +instance Functor Approximation where fmap f (Exact x) = Exact (f x) fmap f (Bound x y) = Bound (fmap f x) (fmap f y) @@ -81,7 +81,7 @@ pprintSpecDecls :: SpecDecls -> String pprintSpecDecls = concatMap (\(names, spec) -> - show spec ++ " :: " ++ (intercalate "," names) ++ "\n") + show spec ++ " :: " ++ intercalate "," names ++ "\n") lookupAggregate :: Eq a => [([a], b)] -> a -> [b] lookupAggregate [] _ = [] @@ -92,29 +92,20 @@ -- Top-level of specifications: may be either spatial or temporal data Specification = - Specification (Either (Result Spatial) Temporal) + Specification (Multiplicity (Approximation Spatial)) deriving (Eq, Data, Typeable) --- *********************** --- Temporal specifications: --- Defines a list of variables which the subject --- of the specification depends upon -data Temporal = Dependency [String] Bool - deriving (Eq, Data, Typeable) +isEmpty :: Specification -> Bool +isEmpty (Specification mult) = isUnit . fromMult $ mult -- ********************** -- Spatial specifications: --- Comprises some modifiers on spatial specifications: --- * linearity --- * irreflexivity --- with the region, which is a regionSum +-- is a regionSum -- -- Regions are in disjunctive normal form (with respect to -- products on dimensions and sums): -- i.e., (A * B) U (C * D)... -data Spatial = - Spatial { modLinearity :: Linearity, - region :: RegionSum } +data Spatial = Spatial RegionSum deriving (Eq, Data, Typeable) -- Helpers for dealing with linearity information @@ -128,25 +119,20 @@ hasDuplicates :: Eq a => [a] -> ([a], Bool) hasDuplicates xs = (nub xs, nub xs /= xs) -setLinearity :: Linearity -> Specification -> Specification -setLinearity l (Specification (Left (Exact s))) = - Specification (Left (Exact (s { modLinearity = l }))) -setLinearity l (Specification (Left (Bound sl su))) = - Specification (Left (Bound (sl >>= \s -> return $ s { modLinearity = l }) - (su >>= \s -> return $ s { modLinearity = l }))) -setLinearity l s = s - -emptySpec = Specification . Left $ (one :: Result Spatial) -emptySpatialSpec = one :: Spatial +fromMult :: Multiplicity a -> a +fromMult (Multiple a) = a +fromMult (Single a) = a --- `isEmpty` predicate on which specifications are vacuous or --- functional empty (i.e., show not be displayed in an inference setting). -isEmpty :: Specification -> Bool -isEmpty (Specification (Right (Dependency [] _))) = True -isEmpty (Specification (Left s)) = isUnit s +setLinearity :: Linearity -> Specification -> Specification +setLinearity l (Specification mult) + | l == Linear = Specification $ Single $ fromMult mult + | l == NonLinear = Specification $ Multiple $ fromMult mult data Linearity = Linear | NonLinear deriving (Eq, Data, Typeable) +data Multiplicity a = Multiple a | Single a + deriving (Eq, Data, Typeable, Functor, Show) + type Dimension = Int -- spatial dimensions are 1 indexed type Depth = Int type IsRefl = Bool @@ -178,9 +164,9 @@ | otherwise = dep <= dep' -- Order in the way defined above: Forward <: Backward <: Centered - (Forward _ _ _) <= _ = True - (Backward _ _ _) <= (Centered _ _ _) = True - _ <= _ = False + Forward{} <= _ = True + Backward{} <= Centered{} = True + _ <= _ = False -- Product of specifications newtype RegionProd = Product {unProd :: [Region]} @@ -196,33 +182,6 @@ -- Operations on specifications -specPlus :: Specification -> Specification -> Maybe Specification - -specPlus (Specification (Left (Bound (Just l) Nothing))) - (Specification (Left (Bound Nothing (Just u)))) = - Just $ Specification (Left (Bound (Just l) (Just u))) - -specPlus (Specification (Left (Bound Nothing (Just u)))) - (Specification (Left (Bound (Just l) Nothing))) = - Just $ Specification (Left (Bound (Just l) (Just u))) - -specPlus (Specification (Left (Bound (Just l1) Nothing))) - (Specification (Left (Bound (Just l2) Nothing))) = - Just $ Specification (Left (Bound (Just $ l1 `sum` l2) Nothing)) - -specPlus (Specification (Left (Bound Nothing (Just l1)))) - (Specification (Left (Bound Nothing (Just l2)))) = - Just $ Specification (Left (Bound Nothing (Just $ l1 `sum` l2))) - -specPlus (Specification (Left (Exact s1))) (Specification (Left (Exact s2))) = - Just $ Specification (Left (Exact $ s1 `sum` s2)) - -specPlus (Specification (Right (Dependency vs1 m1))) - (Specification (Right (Dependency vs2 m2))) | m1 == m2= - Just $ Specification (Right (Dependency (vs1 ++ vs2) m1)) - -specPlus _ _ = Nothing - regionPlus :: Region -> Region -> Maybe Region regionPlus (Forward dep dim reflx) (Backward dep' dim' reflx') | dep == dep' && dim == dim' = Just $ Centered dep dim (reflx || reflx') @@ -264,13 +223,13 @@ absorbReflexive' [] [] = Just ([], []) absorbReflexive' (Forward d dim reflx : rs) [Centered 0 dim' _] - | dim == dim' = Just ((Forward d dim True):rs, []) + | dim == dim' = Just (Forward d dim True:rs, []) absorbReflexive' (Backward d dim reflx : rs) [Centered 0 dim' _] - | dim == dim' = Just ((Backward d dim True):rs, []) + | dim == dim' = Just (Backward d dim True:rs, []) absorbReflexive' (Centered d dim reflx : rs) [Centered 0 dim' _] - | dim == dim' && d /= 0 = Just ((Centered d dim True):rs, []) + | dim == dim' && d /= 0 = Just (Centered d dim True:rs, []) absorbReflexive' _ _ = Nothing @@ -398,29 +357,17 @@ isUnit Nothing = True isUnit (Just x) = isUnit x -instance RegionRig Linearity where - sum Linear Linear = Linear - sum _ _ = NonLinear - prod = sum - one = Linear - zero = Linear - - isUnit Linear = True - isUnit _ = False - instance RegionRig Spatial where - sum (Spatial lin s) (Spatial lin' s') = - Spatial (sum lin lin') (sum s s') + sum (Spatial s) (Spatial s') = Spatial (sum s s') - prod (Spatial lin s) (Spatial lin' s') = - Spatial (prod lin lin') (prod s s') + prod (Spatial s) (Spatial s') = Spatial (prod s s') - one = Spatial one one - zero = Spatial zero zero + one = Spatial one + zero = Spatial zero - isUnit (Spatial _ ss) = isUnit ss + isUnit (Spatial ss) = isUnit ss -instance RegionRig (Result Spatial) where +instance RegionRig (Approximation Spatial) where sum (Exact s) (Exact s') = Exact (sum s s') sum (Exact s) (Bound l u) = Bound (sum (Just s) l) (sum (Just s) u) sum (Bound l u) (Bound l' u') = Bound (sum l l') (sum u u') @@ -446,7 +393,7 @@ sum (Sum ss) (Sum ss') = Sum $ normalise $ ss ++ ss' zero = Sum [] one = Sum [Product []] - isUnit s@(Sum ss) = s == zero || s == one || all ((==) (Product [])) ss + isUnit s@(Sum ss) = s == zero || s == one || all (== Product []) ss -- Show a list with ',' separator showL :: Show a => [a] -> String @@ -459,10 +406,24 @@ -- Pretty print top-level specifications instance Show Specification where - show (Specification (Left sp)) = "stencil " ++ show sp - show (Specification (Right sp)) = "stencil " ++ show sp + show (Specification sp) = "stencil " ++ show sp -instance {-# OVERLAPS #-} Show (Result Spatial) where +instance {-# OVERLAPS #-} Show (Multiplicity (Approximation Spatial)) where + show mult + | Multiple appr <- mult = apprStr empty appr + | Single appr <- mult = apprStr "readOnce, " appr + where + apprStr linearity appr = + case appr of + Exact s -> linearity ++ show s + Bound Nothing Nothing -> "empty" + Bound Nothing (Just s) -> "atMost, " ++ linearity ++ show s + Bound (Just s) Nothing -> "atLeast, " ++ linearity ++ show s + Bound (Just sL) (Just sU) -> + "atLeast, " ++ linearity ++ show sL ++ + "; atMost, " ++ linearity ++ show sU + +instance {-# OVERLAPS #-} Show (Approximation Spatial) where show (Exact s) = show s show (Bound Nothing Nothing) = "empty" show (Bound Nothing (Just s)) = "atMost, " ++ show s @@ -472,21 +433,11 @@ -- Pretty print spatial specs instance Show Spatial where - show (Spatial modLin region) = - intercalate ", " . catMaybes $ [lin, sregion] - where - -- Map "empty" spec to Nothing here - sregion = case show region of - "empty" -> Nothing - xs -> Just xs - lin = case modLin of - NonLinear -> Nothing - Linear -> Just "readOnce" - --- Pretty print temporal specs -instance Show Temporal where - show (Dependency vars mutual) = - "dependency (" ++ showL vars ++ ")" ++ if mutual then ", mutual" else "" + show (Spatial region) = + -- Map "empty" spec to Nothing here + case show region of + "empty" -> "" + xs -> xs -- Pretty print region sums instance Show RegionSum where @@ -497,12 +448,12 @@ show (Sum specs) = intercalate " + " ppspecs - where ppspecs = filter ((/=) "") $ map show specs + where ppspecs = filter (/= "") $ map show specs instance Show RegionProd where show (Product []) = "" show (Product ss) = - intercalate "*" . (map (\s -> "(" ++ show s ++ ")")) $ ss + intercalate "*" . map (\s -> "(" ++ show s ++ ")") $ ss instance Show Region where show (Forward dep dim reflx) = showRegion "forward" dep dim reflx diff --git a/src/Camfort/Specification/Stencils/Synthesis.hs b/src/Camfort/Specification/Stencils/Synthesis.hs --- a/src/Camfort/Specification/Stencils/Synthesis.hs +++ b/src/Camfort/Specification/Stencils/Synthesis.hs @@ -62,7 +62,7 @@ where realName v = v `fromMaybe` (v `M.lookup` nm) prefix' = case prefix of - Nothing -> show (spanLineCol span) ++ " \t" + Nothing -> show span ++ " \t" Just pr -> pr formatSpec prefix nm (span, Left []) = "" @@ -70,39 +70,18 @@ (intercalate "\n" $ map (\s -> prefix' ++ doSpec s) specs) where prefix' = case prefix of - Nothing -> show (spanLineCol span) ++ " \t" + Nothing -> show span ++ " \t" Just pr -> pr commaSep = intercalate ", " doSpec (arrayVar, spec) = show (fixSpec spec) ++ " :: " ++ commaSep (map realName arrayVar) realName v = v `fromMaybe` (v `M.lookup` nm) - fixSpec (Specification (Right (Dependency vs b))) = - Specification (Right (Dependency (map realName vs) b)) fixSpec s = s -lineCol :: FU.Position -> (Int, Int) -lineCol p = (fromIntegral $ FU.posLine p, fromIntegral $ FU.posColumn p) - -spanLineCol :: FU.SrcSpan -> ((Int, Int), (Int, Int)) -spanLineCol (FU.SrcSpan l u) = (lineCol l, lineCol u) - ------------------------ a = (head $ FA.initAnalysis [unitAnnotation]) { FA.insLabel = Just 0 } s = SrcSpan (Position 0 0 0) (Position 0 0 0) --- Given a spec, an array variable, and a list of inductive variables, generate --- a list of indexing expressions for the spec -synthesise :: Specification -> F.Name -> [F.Name] -> [F.Expression (FA.Analysis A)] -synthesise (Specification (Left (Exact spec))) v ixs = - map toSubscriptExpr . toList . fromExact . model $ (Exact spec) - where toSubscriptExpr (offs,_) = ixExprToSubscript v - . map (uncurry offsetToIx) $ zip ixs offs -synthesise _ _ _ = [] - -ixExprToSubscript :: F.Name -> [F.Index (FA.Analysis A)] -> F.Expression (FA.Analysis A) -ixExprToSubscript v es = - F.ExpSubscript a s (F.ExpValue a s (F.ValVariable v)) (F.AList a s es) - -- Make indexing expression for variable 'v' from an offset. -- essentially inverse to `ixToOffset` in StencilSpecification offsetToIx :: F.Name -> Int -> F.Index (FA.Analysis A) @@ -116,7 +95,3 @@ | otherwise = F.IxSingle a s Nothing (F.ExpBinary a s F.Subtraction (F.ExpValue a s (F.ValVariable v)) (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 ix = offsetToIx v o diff --git a/src/Camfort/Specification/Units.hs b/src/Camfort/Specification/Units.hs --- a/src/Camfort/Specification/Units.hs +++ b/src/Camfort/Specification/Units.hs @@ -27,18 +27,17 @@ (checkUnits, inferUnits, synthesiseUnits, inferCriticalVariables) where -import qualified Data.Map as M +import qualified Data.Map.Strict as M import Data.Char (isNumber) import Data.List (intercalate) -import Data.Maybe (fromMaybe, maybeToList, listToMaybe) +import Data.Maybe (fromMaybe, maybeToList, listToMaybe, mapMaybe) import Data.Generics.Uniplate.Operations import Control.Monad.State.Strict import Camfort.Helpers hiding (lineCol) +import Camfort.Helpers.Syntax import Camfort.Output import Camfort.Analysis.Annotations -import Camfort.Analysis.Syntax -import Camfort.Analysis.Types import Camfort.Input -- Provides the types and data accessors used in this module @@ -61,33 +60,35 @@ -- -- ************************************* -inferCriticalVariables, checkUnits, inferUnits, synthesiseUnits - :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> (Report, (Filename, F.ProgramFile Annotation)) +inferCriticalVariables + :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> (Report, Int) {-| Infer one possible set of critical variables for a program -} inferCriticalVariables uo (fname, pf) - | Right vars <- eVars = (okReport vars, (fname, pf)) - | Left exc <- eVars = (errReport exc, (fname, pf)) + | Right vars <- eVars = okReport vars + | Left exc <- eVars = (errReport exc, -1) where -- Format report - okReport [] = logs ++ "\n\n" ++ "No additional annotations are necessary.\n" - okReport vars = logs ++ "\n\n" ++ unlines [ fname ++ ": " ++ expReport ei | ei <- expInfo ] + okReport [] = (logs ++ "\n" ++ fname ++ ":\n" + ++ "No additional annotations are necessary.\n", 0) + okReport vars = (logs ++ "\n" ++ fname ++ ": " + ++ show numVars + ++ " variable declarations suggested to be given a specification:\n" + ++ unlines [ "\t" ++ expReport ei | ei <- expInfo ], numVars) 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 ] + expInfo = filter ((`elem` names) . FA.varName) $ declVariables pfUA + numVars = length expInfo - expReport e = showSrcSpan (FU.getSpan e) ++ " " ++ unrename nameMap v - where v = FA.varName e + expReport e = "(" ++ showSrcSpan (FU.getSpan e) ++ ")\t" ++ FA.srcName e varReport = intercalate ", " . map showVar - showVar (UnitVar v) = v - showVar (UnitLiteral _) = "" - showVar _ = "" + showVar (UnitVar (_, s)) = s + showVar (UnitLiteral _) = "" + showVar _ = "" - errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs + errReport exc = logs ++ "\n" ++ fname ++ ":\n" ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } @@ -97,16 +98,49 @@ pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf nameMap = FAR.extractNameMap pfRenamed +checkUnits, inferUnits + :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> Report {-| Check units-of-measure for a program -} checkUnits uo (fname, pf) - | Right mCons <- eCons = (okReport mCons, (fname, pf)) - | Left exc <- eCons = (errReport exc, (fname, pf)) + | Right mCons <- eCons = okReport mCons + | Left exc <- eCons = errReport exc where -- Format report - 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 ] + okReport Nothing = logs ++ "\n" ++ fname ++ "\t: Consistent. " ++ show nVars ++ " variables checked." + okReport (Just cons) = logs ++ "\n" ++ fname ++ "\t: Inconsistent:\n" ++ reportErrors cons + + reportErrors cons = unlines [ reportError con | con <- cons ] + reportError con = " - at " ++ srcSpan con + ++ pprintConstr (orient (unrename nameMap con)) + ++ additionalInfo con where + -- Create additional info for errors + additionalInfo con = + if null (errorInfo con) + then "" + else "\n instead" ++ intercalate "\n" (mapNotFirst (pad 10) (errorInfo con)) + -- Create additional info about inconsistencies involving variables + errorInfo con = + [" '" ++ sName ++ "' is '" ++ pprintUnitInfo (unrename nameMap u) ++ "'" + | UnitVar (vName, sName) <- universeBi con + , u <- findUnitConstrFor con vName ] + -- Find unit information for variable constraints + findUnitConstrFor con v = mapMaybe (\con' -> if con == con' + then Nothing + else constrainedTo v con') + (concat $ M.elems templateMap) + constrainedTo v (ConEq (UnitVar (v', _)) u) | v == v' = Just u + constrainedTo v (ConEq u (UnitVar (v', _))) | v == v' = Just u + constrainedTo _ _ = Nothing + + mapNotFirst f [] = [] + mapNotFirst f (x : xs) = x : (map f xs) + + orient (ConEq u (UnitVar v)) = ConEq (UnitVar v) u + orient c = c + + pad o = (++) (replicate o ' ') + srcSpan con | Just ss <- findCon con = showSrcSpan ss ++ " " | otherwise = "" @@ -121,15 +155,16 @@ varReport = intercalate ", " . map showVar - showVar (UnitVar v) = v `fromMaybe` M.lookup v nameMap - showVar (UnitLiteral _) = "" -- FIXME - showVar _ = "" + showVar (UnitVar (_, s)) = s + showVar (UnitLiteral _) = "" -- FIXME + showVar _ = "" - errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs + errReport exc = logs ++ "\n" ++ fname ++ ":\t " ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } (eCons, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInconsistentConstraints + templateMap = usTemplateMap state pfUA :: F.ProgramFile UA pfUA = usProgramFile state -- the program file after units analysis is done @@ -146,20 +181,18 @@ 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)) + | Right vars <- eVars = okReport vars + | Left exc <- eVars = errReport exc where -- Format report - okReport vars = logs ++ "\n\n" ++ unlines [ fname ++ ": " ++ expReport ei | ei <- expInfo ] + okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ 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) ] + expInfo = [ (e, u) | e <- declVariables pfUA + , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ] - expReport (e, u) = showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ unrename nameMap v - where v = FA.varName e + expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e - errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs + errReport exc = logs ++ "\n" ++ fname ++ ":\t" ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } @@ -170,27 +203,29 @@ pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf nameMap = FAR.extractNameMap pfRenamed +synthesiseUnits :: UnitOpts + -> Char + -> (Filename, F.ProgramFile Annotation) + -> (Report, (Filename, F.ProgramFile Annotation)) {-| Synthesis unspecified units for a program (after checking) -} -synthesiseUnits uo (fname, pf) - | Right [] <- eVars = checkUnits uo (fname, pf) +synthesiseUnits uo marker (fname, pf) + | Right [] <- eVars = (checkUnits uo (fname, pf), (fname, pf)) | Right vars <- eVars = (okReport vars, (fname, pfFinal)) | Left exc <- eVars = (errReport exc, (fname, pfFinal)) where -- Format report - okReport vars = logs ++ "\n\n" ++ unlines [ fname ++ ": " ++ expReport ei | ei <- expInfo ] + okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ 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) ] + expInfo = [ (e, u) | e <- declVariables pfUA + , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ] - expReport (e, u) = showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ (v `fromMaybe` M.lookup v nameMap) - where v = FA.varName e + expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e - errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs + errReport exc = logs ++ "\n" ++ fname ++ ":\t" ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } - (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables >>= runSynthesis + (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables >>= runSynthesis marker pfUA = usProgramFile state -- the program file after units analysis is done pfFinal = fmap prevAnnotation . fmap FA.prevAnnotation $ pfUA -- strip annotations @@ -202,11 +237,11 @@ 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 ++ ")" +showSrcSpan (FU.SrcSpan l u) = show l -lineCol :: FU.Position -> (Int, Int) -lineCol p = (fromIntegral $ FU.posLine p, fromIntegral $ FU.posColumn p) +declVariables :: F.ProgramFile UA -> [F.Expression UA] +declVariables pf = flip mapMaybe (universeBi pf) $ \ d -> case d of + F.DeclVariable _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ -> Just v + F.DeclArray _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just v + _ -> Nothing diff --git a/src/Camfort/Specification/Units/Environment.hs b/src/Camfort/Specification/Units/Environment.hs --- a/src/Camfort/Specification/Units/Environment.hs +++ b/src/Camfort/Specification/Units/Environment.hs @@ -20,9 +20,6 @@ module Camfort.Specification.Units.Environment where -import qualified Data.Label -import Data.Label.Mono (Lens) -import Data.Label.Monadic hiding (modify) import Control.Monad.State.Strict hiding (gets) import qualified Language.Fortran.AST as F @@ -39,6 +36,9 @@ import Text.Printf +-- | A (unique name, source name) variable +type VV = (F.Name, F.Name) + -- | Description of the unit of an expression. data UnitInfo = UnitParamPosAbs (String, Int) -- an abstract parameter identified by PU name and argument position @@ -52,7 +52,7 @@ | 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) + | UnitVar VV -- variable with undetermined units: (unique name, source name) | UnitMul UnitInfo UnitInfo -- two units multiplied | UnitPow UnitInfo Double -- a unit raised to a constant power deriving (Eq, Ord, Data, Typeable) @@ -70,9 +70,9 @@ UnitlessVar -> "1" UnitName name -> name UnitAlias name -> name - UnitVar var -> printf "#" var + UnitVar (vName, _) -> printf "#" vName UnitMul u1 (UnitPow u2 k) - | k < 0 -> maybeParen u1 ++ " / " ++ show (UnitPow u2 (-k)) + | k < 0 -> maybeParen u1 ++ " / " ++ maybeParen (UnitPow u2 (-k)) UnitMul u1 u2 -> maybeParenS u1 ++ " " ++ maybeParenS u2 UnitPow u 1 -> show u UnitPow u 0 -> "1" @@ -98,6 +98,16 @@ instance Show Constraint where show (ConEq u1 u2) = show u1 ++ " === " ++ show u2 show (ConConj cs) = intercalate " && " (map show cs) + +pprintConstr :: Constraint -> String +pprintConstr (ConEq u1@(UnitVar _) u2@(UnitVar _)) + = "'" ++ pprintUnitInfo u1 ++ "' should have the same units as '" ++ pprintUnitInfo u2 ++ "'" +pprintConstr (ConEq u1 u2) = "'" ++ pprintUnitInfo u1 ++ "' should be '" ++ pprintUnitInfo u2 ++ "'" +pprintConstr (ConConj cs) = intercalate "\n\t and " (map pprintConstr cs) + +pprintUnitInfo :: UnitInfo -> String +pprintUnitInfo (UnitVar (_, sName)) = printf "%s" sName +pprintUnitInfo ui = show ui -------------------------------------------------- diff --git a/src/Camfort/Specification/Units/InferenceBackend.hs b/src/Camfort/Specification/Units/InferenceBackend.hs --- a/src/Camfort/Specification/Units/InferenceBackend.hs +++ b/src/Camfort/Specification/Units/InferenceBackend.hs @@ -35,7 +35,7 @@ import Control.Monad.State.Strict import Control.Monad.ST import Control.Arrow (first, second) -import qualified Data.Map as M +import qualified Data.Map.Strict as M import qualified Data.Array as A import Camfort.Analysis.Annotations @@ -82,7 +82,7 @@ -------------------------------------------------- -- | Returns list of formerly-undetermined variables and their units. -inferVariables :: Constraints -> [(String, UnitInfo)] +inferVariables :: Constraints -> [(VV, UnitInfo)] inferVariables [] = [] inferVariables cons | null inconsists = [ (var, if null units then UnitlessVar else foldl1 UnitMul units) diff --git a/src/Camfort/Specification/Units/InferenceFrontend.hs b/src/Camfort/Specification/Units/InferenceFrontend.hs --- a/src/Camfort/Specification/Units/InferenceFrontend.hs +++ b/src/Camfort/Specification/Units/InferenceFrontend.hs @@ -27,8 +27,8 @@ import Data.Data (Data) import Data.List (nub) -import qualified Data.Map as M -import qualified Data.IntMap as IM +import qualified Data.Map.Strict as M +import qualified Data.IntMap.Strict as IM import qualified Data.Set as S import Data.Maybe (isJust, fromMaybe, catMaybes) import Data.Generics.Uniplate.Operations @@ -39,7 +39,9 @@ import Control.Monad.RWS.Strict import qualified Language.Fortran.AST as F +import Language.Fortran.Parser.Utils (readReal, readInteger) import qualified Language.Fortran.Analysis as FA +import Language.Fortran.Analysis (varName, srcName) import Camfort.Analysis.CommentAnnotator (annotateComments) import Camfort.Analysis.Annotations @@ -129,7 +131,7 @@ -- | Return a list of variable names mapped to their corresponding -- unit that was inferred. -runInferVariables :: UnitSolver [(String, UnitInfo)] +runInferVariables :: UnitSolver [(VV, UnitInfo)] runInferVariables = do cons <- usConstraints `fmap` get return $ inferVariables cons @@ -156,14 +158,16 @@ fname = puName pu -- | Return the list of parameters paired with its positional index. -indexedParams :: F.ProgramUnit UA -> [(Int, String)] +indexedParams :: F.ProgramUnit UA -> [(Int, VV)] 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) + | F.PUFunction _ _ _ _ _ (Just paList) (Just r) _ _ <- pu = zip [0..] $ map toVV (r : F.aStrip paList) + | F.PUFunction _ _ _ _ _ (Just paList) _ _ _ <- pu = zip [0..] $ (fname, sfname) : map toVV (F.aStrip paList) + | F.PUSubroutine _ _ _ _ (Just paList) _ _ <- pu = zip [1..] $ map toVV (F.aStrip paList) | otherwise = [] where - fname = puName pu + fname = puName pu + sfname = puSrcName pu + toVV e = (varName e, srcName e) -------------------------------------------------- @@ -183,14 +187,16 @@ 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)) + let sname = srcName v + modifyVarUnitMap $ M.insertWith (curry snd) (vname, sname) (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) + let sname = srcName v + modifyVarUnitMap $ M.insertWith (curry snd) (vname, sname) (UnitVar (vname, sname)) return v toUnitVar e = return e @@ -218,17 +224,17 @@ -- Figure out the unique names of the referenced variables and -- then insert unit info under each of those names. + insertUnitAssignments :: UnitInfo -> F.Block UA -> [String] -> UnitSolver () 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) ] + let m = M.fromList [ ((varName e, srcName e), info) + | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi decls :: [F.Expression UA] + , varRealName <- varRealNames + , varRealName == FA.srcName e ] modifyVarUnitMap $ M.unionWith const m - modifyGivenVarSet . S.union . S.fromList . M.keys $ m + modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m -------------------------------------------------- @@ -238,7 +244,7 @@ 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 + | Just info <- M.lookup (varName e, srcName e) varUnitMap = setUnitInfo info e annotateExp e = e return $ transformBi annotateExp pf @@ -263,11 +269,11 @@ 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 + F.ExpValue _ _ (F.ValInteger i) | readInteger i == Just 0 -> withLiterals genParamLit e + | otherwise -> withLiterals genUnitLiteral e + F.ExpValue _ _ (F.ValReal i) | readReal i == Just 0 -> withLiterals genParamLit e + | otherwise -> withLiterals genUnitLiteral e + _ -> return e -- Set all literals to unitless. expUnitless e @@ -306,12 +312,7 @@ -- 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 +substInstance callStack output (name, callId) = do tmap <- gets usTemplateMap -- Look up the templates associated with the given function or @@ -327,9 +328,15 @@ -- set of templates. modify $ \ s -> s { usCallIdRemap = IM.empty } - -- If any new instances are discovered, also process them. + -- If any new instances are discovered, also process them, unless recursive. let instances = nub [ (name, i) | UnitParamPosUse (name, _, i) <- universeBi template ] - template' <- foldM (substInstance (name:callStack)) [] instances + template' <- if name `elem` callStack then + -- Detected recursion: we do not support polymorphic-unit recursion, + -- ergo all subsequent recursive calls are assumed to have the same + -- unit-assignments as the first call. + return [] + else + foldM (substInstance (name:callStack)) [] instances -- Convert any remaining abstract parametric units into concrete ones. return . instantiate (name, callId) $ output ++ template ++ template' @@ -405,6 +412,7 @@ F.ExpBinary _ _ o e1 e2 | isOp AddOp o -> setF2C ConEq (getUnitInfo e1) (getUnitInfo e2) | isOp RelOp o -> setF2C ConEq (getUnitInfo e1) (getUnitInfo e2) F.ExpFunctionCall {} -> propagateFunctionCall e + F.ExpSubscript _ _ e1 _ -> return $ maybeSetUnitInfo (getUnitInfo e1) e _ -> whenDebug (tell ("propagateExp: unhandled: " ++ show e)) >> return e where -- Shorter names for convenience functions. @@ -573,12 +581,50 @@ -------------------------------------------------- +-- Fortran semantics for interpretation of constant expressions +-- involving numeric literals. +data FNum = FReal Double | FInt Integer +fnumToDouble (FReal x) = x +fnumToDouble (FInt x) = fromIntegral x + +fAdd, fSub, fMul, fDiv :: FNum -> FNum -> FNum +fAdd (FReal x) fy = FReal $ x + fnumToDouble fy +fAdd fx (FReal y) = FReal $ fnumToDouble fx + y +fAdd (FInt x) (FInt y) = FInt $ x + y +fSub (FReal x) fy = FReal $ x - fnumToDouble fy +fSub fx (FReal y) = FReal $ fnumToDouble fx - y +fSub (FInt x) (FInt y) = FInt $ x - y +fMul (FReal x) fy = FReal $ x * fnumToDouble fy +fMul fx (FReal y) = FReal $ fnumToDouble fx * y +fMul (FInt x) (FInt y) = FInt $ x * y +fDiv (FReal x) fy = FReal $ x / fnumToDouble fy +fDiv fx (FReal y) = FReal $ fnumToDouble fx / y +fDiv (FInt x) (FInt y) = FInt $ x `quot` y -- Haskell quot truncates towards zero, like Fortran +fPow (FReal x) fy = FReal $ x ** fnumToDouble fy +fPow fx (FReal y) = FReal $ fnumToDouble fx ** y +fPow (FInt x) (FInt y) + | y >= 0 = FInt $ x ^ y + | otherwise = FReal $ fromIntegral x ^^ y + +fDivMaybe mx my + | Just y <- my, + fnumToDouble y == 0.0 = Nothing + | otherwise = liftM2 fDiv mx my + -- | Statically computes if the expression is a constant value. constantExpression :: F.Expression a -> Maybe Double -constantExpression (F.ExpValue _ _ (F.ValInteger i)) = Just $ read i -constantExpression (F.ExpValue _ _ (F.ValReal r)) = Just $ read r --- FIXME: expand... -constantExpression _ = Nothing +constantExpression e = fnumToDouble `fmap` ce e + where + ce e = case e of + (F.ExpValue _ _ (F.ValInteger i)) -> FInt `fmap` readInteger i + (F.ExpValue _ _ (F.ValReal r)) -> FReal `fmap` readReal r + (F.ExpBinary _ _ F.Addition e1 e2) -> liftM2 fAdd (ce e1) (ce e2) + (F.ExpBinary _ _ F.Subtraction e1 e2) -> liftM2 fSub (ce e1) (ce e2) + (F.ExpBinary _ _ F.Multiplication e1 e2) -> liftM2 fMul (ce e1) (ce e2) + (F.ExpBinary _ _ F.Division e1 e2) -> fDivMaybe (ce e1) (ce e2) + (F.ExpBinary _ _ F.Exponentiation e1 e2) -> liftM2 fPow (ce e1) (ce e2) + -- FIXME: expand... + _ -> Nothing -- | Asks the question: is the operator within the given category? isOp :: BinOpKind -> F.BinaryOp -> Bool @@ -612,7 +658,7 @@ pf <- gets usProgramFile cons <- usConstraints `fmap` get vum <- usVarUnitMap `fmap` get - tell . unlines $ [ " " ++ show info ++ " :: " ++ n | (n, info) <- M.toList vum ] + 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 ] @@ -648,7 +694,9 @@ puName :: F.ProgramUnit UA -> F.Name puName pu | F.Named n <- FA.puName pu = n - | otherwise = "_nameless" + | otherwise = "_nameless" -varName :: F.Expression UA -> F.Name -varName = FA.varName +puSrcName :: F.ProgramUnit UA -> F.Name +puSrcName pu + | F.Named n <- FA.puSrcName pu = n + | otherwise = "_nameless" diff --git a/src/Camfort/Specification/Units/Monad.hs b/src/Camfort/Specification/Units/Monad.hs --- a/src/Camfort/Specification/Units/Monad.hs +++ b/src/Camfort/Specification/Units/Monad.hs @@ -19,7 +19,7 @@ {- | Defines the monad for the units-of-measure modules -} module Camfort.Specification.Units.Monad - ( UA, UnitSolver, UnitOpts(..), unitOpts0, UnitLogs, UnitState(..), LiteralsOpt(..), UnitException + ( UA, VV, UnitSolver, UnitOpts(..), unitOpts0, UnitLogs, UnitState(..), LiteralsOpt(..), UnitException , whenDebug, modifyVarUnitMap, modifyGivenVarSet, modifyUnitAliasMap , VarUnitMap, GivenVarSet, UnitAliasMap, TemplateMap, CallIdMap , modifyTemplateMap, modifyProgramFile, modifyProgramFileM, modifyCallIdRemapM @@ -31,13 +31,13 @@ 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.Map.Strict as M +import qualified Data.IntMap.Strict as IM import qualified Data.Set as S import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.AST as F -import Camfort.Specification.Units.Environment (UnitInfo, UnitAnnotation, Constraints(..)) +import Camfort.Specification.Units.Environment (UnitInfo, UnitAnnotation, Constraints(..), VV) import Camfort.Analysis.Annotations (Annotation, A, UA) -------------------------------------------------- @@ -92,8 +92,8 @@ -------------------------------------------------- --- | Variable unique name => unit -type VarUnitMap = M.Map F.Name UnitInfo +-- | Variable => unit +type VarUnitMap = M.Map VV UnitInfo -- | Set of variables given explicit unit annotations type GivenVarSet = S.Set F.Name -- | Alias name => definition diff --git a/src/Camfort/Specification/Units/Parser.y b/src/Camfort/Specification/Units/Parser.y --- a/src/Camfort/Specification/Units/Parser.y +++ b/src/Camfort/Specification/Units/Parser.y @@ -127,8 +127,9 @@ deriving (Show) lexer :: String -> Either AnnotationParseError [ Token ] -lexer ('=':xs) = lexer' xs -lexer _ = Left NotAnnotation +lexer (c:xs) + | c `elem` ['=', '!', '>', '<'] = lexer' xs + | otherwise = Left NotAnnotation addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] addToTokens tok rest = do diff --git a/src/Camfort/Specification/Units/Synthesis.hs b/src/Camfort/Specification/Units/Synthesis.hs --- a/src/Camfort/Specification/Units/Synthesis.hs +++ b/src/Camfort/Specification/Units/Synthesis.hs @@ -25,10 +25,9 @@ import Data.Matrix import Data.Maybe import Data.Ratio (numerator, denominator) -import qualified Data.Map as M +import qualified Data.Map.Strict 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 @@ -41,54 +40,51 @@ 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 the ProgramFile as comments. -runSynthesis :: [(String, UnitInfo)] -> UnitSolver [(String, UnitInfo)] -runSynthesis vars = do - modifyProgramFileM $ descendBiM (synthBlocks vars) -- descendBiM finds the head of lists +runSynthesis :: Char -> [(VV, UnitInfo)] -> UnitSolver [(VV, UnitInfo)] +runSynthesis marker vars = do + modifyProgramFileM $ descendBiM (synthBlocks marker vars) -- descendBiM finds the head of lists return vars -- 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) [] +synthBlocks :: Char -> [(VV, UnitInfo)] -> [F.Block UA] -> UnitSolver [F.Block UA] +synthBlocks marker vars = fmap reverse . foldM (synthBlock marker vars) [] -- 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 +synthBlock :: Char -> [(VV, UnitInfo)] -> [F.Block UA] -> F.Block UA -> UnitSolver [F.Block UA] +synthBlock marker vars bs b@(F.BlStatement a ss@(FU.SrcSpan lp up) _ (F.StDeclaration _ _ _ _ decls)) = do 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 + | vname `S.notMember` gvSet -- not a member of the already-given variables + , Just u <- lookup (vname, sname) vars -> do -- and a unit has been inferred -- Create new annotation which labels this as a refactored node. let newA = a { FA.prevAnnotation = (FA.prevAnnotation a) { prevAnnotation = (prevAnnotation (FA.prevAnnotation a)) { - refactored = Just loc } } } + refactored = Just lp } } } -- Create a zero-length span for the new comment node. let newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) -- Build the text of the comment with the unit annotation. - let txt = "= " ++ showUnitDecl nMap (e, u) + let txt = marker:" " ++ showUnitDecl (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 + vname = FA.varName e + sname = FA.srcName e (e :: F.Expression UA) -> return Nothing return (b:reverse newBs ++ bs) -synthBlock _ bs b = return (b:bs) +synthBlock _ _ bs b = return (b:bs) -- 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. @@ -100,5 +96,4 @@ insertSpacing n = (replicate n ' ' ++) -- Pretty print a unit declaration. -showUnitDecl nameMap (e, u) = "unit(" ++ show u ++ ") :: " ++ (v `fromMaybe` M.lookup v nameMap) - where v = FA.varName e +showUnitDecl (e, u) = "unit(" ++ show u ++ ") :: " ++ FA.srcName e diff --git a/src/Camfort/Transformation/CommonBlockElim.hs b/src/Camfort/Transformation/CommonBlockElim.hs --- a/src/Camfort/Transformation/CommonBlockElim.hs +++ b/src/Camfort/Transformation/CommonBlockElim.hs @@ -13,7 +13,9 @@ See the License for the specific language governing permissions and limitations under the License. -} -{-# LANGUAGE ImplicitParams, DeriveDataTypeable, TypeOperators #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} module Camfort.Transformation.CommonBlockElim where @@ -24,308 +26,417 @@ import Data.Data import Data.List import Data.Ord -import qualified Data.Map as Data.Map +import qualified Data.Map as M import Data.Generics.Uniplate.Operations -import Language.Fortran -import Language.Fortran.Pretty +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.Util.Position as FU +import qualified Language.Fortran.ParserMonad as PM +import qualified Language.Fortran.PrettyPrint as PP import Camfort.Helpers -import Camfort.Traverse +import Camfort.Helpers.Syntax import Camfort.Analysis.Annotations -import Camfort.Analysis.Syntax -import Camfort.Analysis.Types -import Camfort.Transformation.Syntax --- Typed common block representation -type TCommon p = (Maybe String, [(Variable, Type p)]) +-- Typed common-block representation +-- Tuple of: +-- * a (possible) common block name +-- * map from names to their types +type TCommon p = (Maybe F.Name, [(F.Name, F.BaseType)]) -- Typed and "located" common block representation +-- Right associated pairs tuple of: +-- * current filename +-- * current program unit name +-- * Typed common-block representation -- TODO: include column + line information -type TLCommon p = (Filename, (String, TCommon p)) +type TLCommon p = (Filename, (F.Name, TCommon p)) +type A1 = FA.Analysis Annotation +type CommonState = State (Report, [TLCommon A]) + -- Top-level functions for eliminating common blocks in a set of files -commonElimToModules :: Directory -> [(Filename, Program A)] -> (Report, [(Filename, Program A)]) +commonElimToModules :: + Directory + -> [(Filename, F.ProgramFile A)] + -> (Report, [(Filename, F.ProgramFile A)], [(Filename, F.ProgramFile A)]) -- Eliminates common blocks in a program directory (and convert to modules) -commonElimToModules d ps = let (ps', (r, cg)) = runState (analyseCommons ps) ("", []) - (r', ps'') = introduceModules d cg - psR = updateUseDecls ps' cg - in (r ++ r', psR ++ ps'') +commonElimToModules d pfs = + (r ++ r', pfs'', pfM) + where + (pfs', (r, cg)) = runState (analyseAndRmCommons pfs) ("", []) + meta = F.MetaInfo PM.Fortran90 + (r', pfM) = introduceModules meta d cg + pfs'' = updateUseDecls pfs' cg +analyseAndRmCommons :: [(Filename, F.ProgramFile A)] + -> CommonState [(Filename, F.ProgramFile A)] +analyseAndRmCommons = mapM analysePerPF +analysePerPF :: + (Filename, F.ProgramFile A) -> CommonState (Filename, F.ProgramFile A) +analysePerPF (fname, pf) = do + let pf' = FA.initAnalysis pf + let (pf'', tenv) = FAT.analyseTypes pf' + pf''' <- transformBiM (analysePerPU tenv fname) pf'' + return (fname, fmap FA.prevAnnotation pf''') -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 -> - -- ("doing an include: " ++ (show fname)) `trace` - let -- create dummy block - a0 = unitAnnotation - 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 - -- 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) []))] - -- defs' _ _ rs = concat rs +analysePerPU :: + FAT.TypeEnv -> Filename -> F.ProgramUnit A1 -> CommonState (F.ProgramUnit A1) +analysePerPU tenv fname p = + transformBiM (collectAndRmCommons tenv fname (F.getName p)) p - in mapM (\(f, ps) -> do ps' <- mapM (transformBiM (defs' f)) ps - return (f, ps')) pss +collectAndRmCommons :: FAT.TypeEnv -> Filename -> F.ProgramUnitName + -> F.Block A1 -> CommonState (F.Block A1) +collectAndRmCommons tenv fname pname = transformBiM commons + where + commons :: F.Statement A1 -> CommonState (F.Statement A1) + commons f@(F.StCommon a s@(FU.SrcSpan p1 _) cgrps) = do + mapM_ commonGroups (F.aStrip cgrps) + let a' = onPrev (\ap -> ap {refactored = Just p1, deleteNode = True}) a + return $ F.StCommon a' (deleteLine s) (F.AList a s []) + commons f = return f -collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A) -collectCommons fname pname b = - let tenv = typeEnv b + punitName (F.Named s) = s + punitName _ = "" - commons' :: Decl A -> State (Report, [TLCommon A]) (Decl A) - 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) - return $ (NullDecl (a { refactored = (Just $ fst sp) }) sp) - commons' f = return f + -- Process a common group, adding blocks to the common state + commonGroups :: F.CommonGroup A1 -> CommonState () + commonGroups (F.CommonGroup a (FU.SrcSpan p1 _) cname exprs) = do + let r' = show p1 ++ ": removed common declaration\n" + let tcommon = map typeCommonExprs (F.aStrip exprs) + let info = (fname, (punitName pname, (commonNameFromAST cname, tcommon))) + modify (\(r, infos) -> (r ++ r', info : infos)) - typeCommonExprs :: [Expr Annotation] -> [(Variable, Type Annotation)] - typeCommonExprs [] = [] - 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) + typeCommonExprs :: F.Expression A1 -> (F.Name, F.BaseType) + typeCommonExprs (F.ExpValue _ sp (F.ValVariable v)) = + case M.lookup v tenv of + Just (FA.IDType (Just t) (Just FA.CTVariable)) -> (v, t) + Just (FA.IDType (Just t) (Just FA.CTArray)) -> (v, t) + _ -> error $ "Variable '" ++ show v + ++ "' is of an unknown or higher-order type at: " ++ show sp + ++ show (M.lookup v tenv) - in transformBiM commons' b + typeCommonExprs e = error $ "Not expecting a non-variable expression \ + \in expression at: " ++ show (FU.getSpan e) + {- Comparison functions for common block names and variables -} -cmpTLConFName :: TLCommon A -> TLCommon A -> Ordering +cmpTLConFName :: TLCommon a -> TLCommon a -> Ordering cmpTLConFName (f1, (_, _)) (f2, (_, _)) = compare f1 f2 -cmpTLConPName :: TLCommon A -> TLCommon A -> Ordering +cmpTLConPName :: TLCommon a -> TLCommon a -> Ordering cmpTLConPName (_, (p1, _)) (_, (p2, _)) = compare p1 p2 -cmpTLConBNames :: TLCommon A -> TLCommon A -> Ordering +cmpTLConBNames :: TLCommon a -> TLCommon a -> Ordering cmpTLConBNames (_, (_, c1)) (_, (_, c2)) = cmpTConBNames c1 c2 -cmpTConBNames :: TCommon A -> TCommon A -> Ordering +cmpTConBNames :: TCommon a -> TCommon a -> Ordering cmpTConBNames (Nothing, _) (Nothing, _) = EQ cmpTConBNames (Nothing, _) (Just _, _) = LT cmpTConBNames (Just _, _) (Nothing, _) = GT -cmpTConBNames (Just n, _) (Just n', _) = if (n < n') then LT - else if (n > n') then GT else EQ +cmpTConBNames (Just n, _) (Just n', _) + | n < n' = LT + | n > n' = GT + | otherwise = EQ --- Fold [TLCommon p] to get a list of ([(TLCommon p, Renamer p)], [(Filename, Program A)]) --- How to decide which gets to be the "head" perhaps the one which triggers the *least* renaming (ooh!) --- (this is calculated by looking for the mode of the TLCommon (for a particular Common) --- (need to do gorouping, but sortBy is used already so... (IS THIS STABLE- does this matter?)) +cmpVarName :: TLCommon a -> TLCommon a -> Ordering +cmpVarName (_, (_, (_, vtys1))) (_, (_, (_, vtys2))) = + map fst vtys1 `compare` map fst vtys2 -onCommonBlock :: (TCommon A -> TCommon A) -> TLCommon A -> TLCommon A -onCommonBlock f (fname, (pname, tcommon)) = (fname, (pname, f tcommon)) +-- Fold [TLCommon p] to get a list of ([(TLCommon p, Renamer p)], +-- [(Filename, F.ProgramFile A)]) How to decide which gets to be the +-- "head" perhaps the one which triggers the *least* renaming (ooh!) +-- (this is calculated by looking for the mode of the TLCommon (for a +-- particular Common) (need to do gorouping, but sortBy is used +-- already so... (IS THIS STABLE- does this matter?)) commonName Nothing = "Common" commonName (Just x) = x --- Freshen the names for a common block and generate a renamer from the old block to this +commonNameFromAST (Just (F.ExpValue _ _ (F.ValVariable v))) = Just v +commonNameFromAST _ = Nothing + +-- 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))) = let mkRenamerAndCommon (r, tc) (v, t) = - let v' = (caml $ commonName cname) ++ "_" ++ v - in (Data.Map.insert v (Just v', Nothing) r, (v', t) : tc) - (r, fields') = foldl mkRenamerAndCommon (Data.Map.empty, []) fields + let v' = caml (commonName cname) ++ "_" ++ v + in (M.insert v (Just v', Nothing) r, (v', t) : tc) + (r, fields') = foldl mkRenamerAndCommon (M.empty, []) fields in ((fname, (pname, (cname, fields'))), Just r) --- 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 +-- 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 - -- 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 - -cmpVarName :: TLCommon A -> TLCommon A -> Ordering -cmpVarName (fname1, (pname1, (name1, vtys1))) (fnam2, (pname2, (name2, vtys2))) = map fst vtys1 `compare` map fst vtys2 +groupSortCommonBlock commons = gccs + where + -- Group by names of the common blocks + 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 mkTLCommonRenamers :: [TLCommon A] -> [(TLCommon A, RenamerCoercer)] -mkTLCommonRenamers commons = case allCoherentCommonsP commons of - (r, False) -> error $ "Common blocks are incoherent!\n" ++ r -- (r, []) -- Incoherent commons - (_, True) -> let gccs = groupSortCommonBlock commons - -- Find the "mode" common block and freshen the names for this, creating - -- 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) ++ - 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)) - in gcrcs' +mkTLCommonRenamers commons = + case allCoherentCommons commons of + (r, False) -> error $ "Common blocks are incoherent!\n" ++ r + (_, True) -> commons' + where + gccs = groupSortCommonBlock commons + -- Find the "mode" common block and freshen the names for + -- this, creating 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) ++ + map (\c -> (c, mkRenamerCoercerTLC c com)) (concat $ tail grp)) gccs + -- Now re-sort based on the file and program unit + commons' = sortBy (cmpFst cmpTLConFName) (sortBy (cmpFst cmpTLConPName) (concat gcrcs)) +type NameMap = M.Map F.Name F.Name -updateUseDecls :: [(Filename, Program A)] -> [TLCommon A] -> [(Filename, Program A)] -updateUseDecls fps tcs = - let tcrs = mkTLCommonRenamers tcs +-- Nothing represents an overall identity renamer/coercer for efficiency +-- a Nothing for a variable represent a variable-level (renamer) identity +-- a Nothing for a type represents a type-level (coercer) identity +type RenamerCoercer = + Maybe (M.Map F.Name (Maybe F.Name, Maybe (F.BaseType, F.BaseType))) - concatUses :: Uses A -> Uses A -> Uses A - concatUses (UseNil p) y = y - concatUses (Uses p x us p') y = Uses p x (UseNil p) p' +applyRenaming :: (Typeable (t A), Data (t A)) => NameMap -> t A -> t A +applyRenaming r = transformBi rename + where + rename :: F.Value A -> F.Value A + rename vn@(F.ValVariable v) = + case M.lookup v r of + Nothing -> vn + Just v' -> F.ValVariable v' - inames :: Decl A -> Maybe String - inames (Include _ (Con _ _ inc)) = Just inc - inames _ = Nothing +class Renaming r where + hasRenaming :: F.Name -> r -> Bool - importIncludeCommons :: ProgUnit A -> ProgUnit A - importIncludeCommons p = foldl (\p' iname -> ("Iname = " ++ iname) `trace` matchPUnitAlt iname p') p (reduceCollect inames p) +instance Renaming RenamerCoercer where + hasRenaming _ Nothing = False + hasRenaming v (Just rc) = M.member v rc - matchPUnitAlt :: Filename -> ProgUnit A -> ProgUnit A - 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' +-- sometimes we have a number of renamer coercers together +instance Renaming [RenamerCoercer] where + hasRenaming v = any (hasRenaming v) +updateUseDecls :: + [(Filename, F.ProgramFile A)] -> [TLCommon A] -> [(Filename, F.ProgramFile A)] +updateUseDecls fps tcs = map perPF fps + where + perPF (f, p@(F.ProgramFile (F.MetaInfo v) _ _)) = + (f, transformBi (importIncludeCommons v) $ transformBi (matchPUnit v f) p) + tcrs = mkTLCommonRenamers tcs - 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 - Just pname -> pname - tcrs' = (lookups' pname) (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' + inames :: F.Statement A -> Maybe String + inames (F.StInclude _ _ (F.ExpValue _ _ (F.ValString fname))) = Just fname + inames _ = Nothing - -- 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) [] - in addToProgUnit p' remainingAssignments + importIncludeCommons :: PM.FortranVersion -> F.ProgramUnit A -> F.ProgramUnit A + importIncludeCommons v p = + foldl (flip (matchPUnit v)) p (reduceCollect inames p) - -- 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 - else Decl p' srcP vars' typ) - where - (assgns, vars') = foldl matchVar ([],[]) vars - p' = if (length vars == length vars') then p else p { refactored = Just (fst srcP) } + insertUses :: [F.Block A] -> F.ProgramUnit A -> F.ProgramUnit A + insertUses uses = descendBi insertUses' + where insertUses' :: [F.Block A] -> [F.Block A] + insertUses' bs = uses ++ bs - 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, _) = - if (hasRenaming v rcs) then - case e of - -- Renaming exists and no default, then remove - 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 + matchPUnit :: PM.FortranVersion -> Filename -> F.ProgramUnit A -> F.ProgramUnit A + matchPUnit v fname p = + removeDecls v (map snd tcrs') p' + where + pname = case F.getName p of + F.Named pname -> pname + -- If no subname is available, use the filename + _ -> fname + tcrs' = lookups' pname (lookups' fname tcrs) + pos = getUnitStartPosition p + uses = mkUseStatementBlocks pos tcrs' + p' = insertUses uses p - in each fps (\(f, p) -> (f, map importIncludeCommons $ transformBi (matchPUnit f) p)) + -- Given the list of renamed/coercerd variables form common blocks, + -- remove any declaration sites + removeDecls :: PM.FortranVersion -> [RenamerCoercer] -> F.ProgramUnit A -> F.ProgramUnit A + removeDecls v rcs p = addToProgramUnit v p' remainingAssignments + where + (p', remainingAssignments) = runState (transformBiM (removeDecl rcs) p) [] + -- 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 :: [RenamerCoercer] + -> F.Statement A -> State [F.Statement A] (F.Statement A) + removeDecl rcs d@(F.StDeclaration a s@(FU.SrcSpan p1 _) typ attr decls) = do + modify (++ assgns) + return $ F.StDeclaration a' (deleteLine s) typ attr decls' + where + (F.AList al sl declsA) = decls + decls' = F.AList al' sl declsA' + (assgns, declsA') = foldl matchVar ([],[]) declsA + -- Update annotation if declarations are being added + (a', al') = if length declsA == length declsA' + then (a, al) + else (a {refactored = Just p1, deleteNode = True} + , al {refactored = Just pl1}) + where (FU.SrcSpan pl1 _ ) = sl + + matchVar :: ([F.Statement A], [F.Declarator A]) -> F.Declarator A + -> ([F.Statement A], [F.Declarator A]) + matchVar (assgns, decls) + dec@(F.DeclVariable a s + lvar@(F.ExpValue _ _ (F.ValVariable v)) len init) = + if hasRenaming v rcs + then case init of + -- Renaming exists and no default, then remove + Nothing -> (assgns, decls) + -- Renaming exists but has default, so create an + -- assignment for this + Just initExpr -> + ((F.StExpressionAssign a' s lvar initExpr) : assgns, decls) + else -- no renaming, preserve declaration + (assgns, dec : decls) + matchVar (assgns, decls) _ = (assgns, decls) + removeDecl _ d = return d + + -- 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 $ - 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 +addToProgramUnit :: + PM.FortranVersion -> F.ProgramUnit A -> [F.Statement A] -> F.ProgramUnit A +addToProgramUnit v pu stmnts = descendBi (addAfterDecls (map toBlock stmnts)) pu + where + -- Find the point where blocks are non-executable statements + -- and become executable statements/blocks + addAfterDecls :: [F.Block A] -> [F.Block A] -> [F.Block A] + addAfterDecls [] ys = ys + addAfterDecls [x] ys = x : ys + addAfterDecls (x:(x':xs)) ys + | F.nonExecutableStatementBlock v x && F.executableStatementBlock v x' + = x : (ys ++ (x' : xs)) + | F.executableStatementBlock v x = ys ++ (x:(x':xs)) --- Add additional statements to the start of a block -addToBlock :: Block A -> [Fortran A] -> Block A -addToBlock b [] = b -addToBlock (Block p useBlock imps sp decls stmt) stmts = Block p useBlock imps sp decls (prependStatements Nothing stmt stmts) + addAfterDecls (x:xs) ys = x : addAfterDecls xs ys --- Prepends statements onto a statement -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 - Nothing -> srcSpan stmt - Just s -> s + -- Convert a statement to a simple 'Statement' block + toBlock :: F.Statement A -> F.Block A + toBlock stmnt = + F.BlStatement (F.getAnnotation stmnt) (FU.getSpan stmnt) Nothing stmnt -useSrcLoc :: ProgUnit A -> SrcLoc -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 (BlockData _ s _ _ _ _) = fst s -useSrcLocB (Block _ (UseBlock _ s) _ _ _ _) = s +getUnitStartPosition :: F.ProgramUnit A -> FU.SrcSpan +getUnitStartPosition (F.PUMain _ s _ [] _) = s +getUnitStartPosition (F.PUMain _ _ _ bs _) = FU.getSpan (head bs) +getUnitStartPosition (F.PUSubroutine _ s _ _ _ [] _) = s +getUnitStartPosition (F.PUSubroutine _ _ _ _ _ bs _) = FU.getSpan (head bs) +getUnitStartPosition (F.PUFunction _ s _ _ _ _ _ [] _) = s +getUnitStartPosition (F.PUFunction _ _ _ _ _ _ _ bs _) = FU.getSpan (head bs) +getUnitStartPosition (F.PUBlockData _ s _ []) = s +getUnitStartPosition (F.PUBlockData _ _ _ bs) = FU.getSpan (head bs) -renamerToUse :: RenamerCoercer -> [(Variable, Variable)] +renamerToUse :: RenamerCoercer -> [(F.Name, F.Name)] renamerToUse Nothing = [] renamerToUse (Just m) = let entryToPair v (Nothing, _) = [] entryToPair v (Just v', _) = [(v, v')] - in Data.Map.foldlWithKey (\xs v e -> (entryToPair v e) ++ xs) [] m + in M.foldlWithKey (\xs v e -> entryToPair v e ++ xs) [] m -- 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) = - let a = unitAnnotation { refactored = Just s, newNode = True } -- previously-- Just (toCol0 s) - in Uses a (Use (commonName name) (renamerToUse r)) (mkUseStatements s trs) a +mkUseStatementBlocks :: FU.SrcSpan -> [(TCommon A, RenamerCoercer)] -> [F.Block A] +mkUseStatementBlocks s = map mkUseStmnt + where + a = unitAnnotation { refactored = Just pos, newNode = True } + (FU.SrcSpan pos pos') = s + s' = FU.SrcSpan (toCol0 pos) pos' + mkUseStmnt x@((name, _), r) = F.BlStatement a s' Nothing $ + F.StUse a s' useName F.Permissive useListA + where useName = F.ExpValue a s' (F.ValVariable (caml (commonName name))) + useListA = case useList of [] -> Nothing + us -> Just (F.AList a s' (reverse us)) + useList = mkUses pos x + mkUses :: FU.Position -> (TCommon A, RenamerCoercer) -> [F.Use A] + mkUses s ((name, _), r) = map useRenamer (renamerToUse r) + + useRenamer (v, vR) = F.UseRename a s' (F.ExpValue a s' (F.ValVariable v)) + (F.ExpValue a s' (F.ValVariable vR)) + mkRenamerCoercerTLC :: TLCommon A :? source -> TLCommon A :? target -> RenamerCoercer -mkRenamerCoercerTLC x@(fname, (pname, common1)) (_, (_, common2)) = mkRenamerCoercer common1 common2 +mkRenamerCoercerTLC x@(fname, (pname, common1)) (_, (_, common2)) = + mkRenamerCoercer common1 common2 mkRenamerCoercer :: TCommon A :? source -> TCommon A :? target -> RenamerCoercer mkRenamerCoercer (name1, vtys1) (name2, vtys2) - | name1 == name2 = if (vtys1 == vtys2) then Nothing else Just $ generate vtys1 vtys2 Data.Map.empty - | otherwise = error "Can't generate renamer between different common blocks\n" - where - generate [] [] theta = 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) - generate _ _ _ = error "Common blocks of different field length\n" - -allCoherentCommonsP :: [TLCommon A] -> (Report, Bool) -allCoherentCommonsP commons = foldM (\p (c1, c2) -> (coherentCommonsP c1 c2) >>= (\p' -> return $ p && p')) True (pairs commons) + | name1 == name2 = + if vtys1 == vtys2 then Nothing + else Just $ generate vtys1 vtys2 M.empty + | otherwise = + error "Can't generate renamer between different common blocks\n" + where + generate [] [] theta = theta + generate ((var1, ty1):vtys1) ((var2, ty2):vtys2) theta = + generate vtys1 vtys2 (M.insert var1 (varR, typR) theta) + where + varR = if var1 == var2 then Nothing else Just var2 + typR = if ty1 == ty2 then Nothing else Just (ty1, ty2) + generate _ _ _ = error "Common blocks of different field length\n" -coherentCommonsP :: TLCommon A -> TLCommon A -> (Report, Bool) -coherentCommonsP (f1, (p1, (n1, vtys1))) (f2, (p2, (n2, vtys2))) = - if (n1 == n2) then - let coherent :: [(Variable, Type A)] -> [(Variable, Type A)] -> (Report, Bool) - coherent [] [] = ("", True) - 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 " ++ - 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 +allCoherentCommons :: [TLCommon A] -> (Report, Bool) +allCoherentCommons commons = + foldM (\p (c1, c2) -> coherentCommons c1 c2 >>= \p' -> return $ p && p') + True (pairs commons) - 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) +coherentCommons :: TLCommon A -> TLCommon A -> (Report, Bool) +coherentCommons (f1, (p1, (n1, vtys1))) (f2, (p2, (n2, vtys2))) = + if n1 == n2 + then coherentCommons' vtys1 vtys2 + else error $ "Trying to compare differently named common blocks: " + ++ show n1 ++ " and " ++ show n2 ++ "\n" -introduceModules :: Directory -> [TLCommon A] -> (Report, [(Filename, Program A)]) -introduceModules d cenv = mapM (mkModuleFile d) (map (head . head) (groupSortCommonBlock cenv)) +coherentCommons' :: [(F.Name, F.BaseType)] -> [(F.Name, F.BaseType)] -> (Report, Bool) +coherentCommons' [] [] = ("", True) +coherentCommons' ((var1, ty1):xs) ((var2, ty2):ys) + | af ty1 == af ty2 = let (r', c) = coherentCommons' xs ys + in (r', c && True) + | otherwise = let r = var1 ++ ":" + ++ PP.pprintAndRender PM.Fortran90 ty1 Nothing + ++ "(" ++ show (af ty1) ++ ")" + ++ " differs from " ++ var2 + ++ ":" ++ PP.pprintAndRender PM.Fortran90 ty2 Nothing + ++ "(" ++ show (af ty2) ++ ")" ++ "\n" + (r', _) = coherentCommons' xs ys + in (r ++ r', False) + -- TODO - give more information in the error +coherentCommons' _ _ = ("Common blocks of different field lengths", False) +introduceModules :: + F.MetaInfo -> Directory -> [TLCommon A] + -> (Report, [(Filename, F.ProgramFile A)]) +introduceModules meta dir cenv = + mapM (mkModuleFile meta dir . head . head) (groupSortCommonBlock cenv) -mkModuleFile :: Directory -> (TLCommon A) -> (Report, (Filename, Program A)) -mkModuleFile d (_, (_, (name, varTys))) = - let modname = commonName name - fullpath = d ++ "/" ++ modname ++ ".f90" - r = "Created module " ++ modname ++ " at " ++ fullpath ++ "\n" - in (r, (fullpath, [mkModule modname varTys modname])) +mkModuleFile :: + F.MetaInfo -> Directory -> TLCommon A -> (Report, (Filename, F.ProgramFile A)) +mkModuleFile meta dir (_, (_, (name, varTys))) = + (r, (path, F.ProgramFile meta [([], mod)] [])) + where + modname = commonName name + path = dir ++ modname ++ ".f90" + r = "Creating module " ++ modname ++ " at " ++ path ++ "\n" + mod = mkModule modname varTys modname -mkModule :: String -> [(Variable, Type A)] -> String -> ProgUnit A +mkModule :: String -> [(F.Name, F.BaseType)] -> String -> F.ProgramUnit A mkModule name vtys fname = - let a = unitAnnotation { refactored = Just loc } - 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 [] + F.PUModule a sp (caml fname) decls Nothing + where + a = unitAnnotation { refactored = Just loc, newNode = True } + loc = FU.Position 0 0 0 + sp = FU.SrcSpan loc loc + toDeclBlock (v, t) = F.BlStatement a sp Nothing (toStmt (v, t)) + toStmt (v, t) = F.StDeclaration a sp (toTypeSpec t) Nothing (toDeclarator v) + toTypeSpec t = F.TypeSpec a sp t Nothing + toDeclarator v = F.AList a sp + [F.DeclVariable a sp + (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) Nothing Nothing] + decls = map toDeclBlock vtys diff --git a/src/Camfort/Transformation/CommonBlockElimToCalls.hs b/src/Camfort/Transformation/CommonBlockElimToCalls.hs deleted file mode 100644 --- a/src/Camfort/Transformation/CommonBlockElimToCalls.hs +++ /dev/null @@ -1,178 +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.Transformation.CommonBlockElimToCalls where - -import Control.Monad -import Control.Monad.State.Lazy - -import Data.Generics.Uniplate.Operations - -import Data.List - -import Language.Fortran -import Language.Haskell.Syntax (SrcLoc(..)) - -import Camfort.Helpers -import Camfort.Traverse -import Camfort.Analysis.Annotations -import Camfort.Analysis.Syntax -import Camfort.Analysis.Types -import Camfort.Transformation.Syntax -import Camfort.Transformation.CommonBlockElim - -import Debug.Trace - -{- This is somewhat experimental and incomplete -} - --- Top-level functions for eliminating common blocks in a set of files -commonElimToCalls :: Directory -> [(Filename, Program A)] -> (Report, [(Filename, Program A)]) - --- Eliminates common blocks in a program directory (and convert to calls) -commonElimToCalls d ps = let (ps', (r, cg)) = runState (analyseCommons ps) ("", []) - (r', ps'') = mapM (introduceCalls cg) ps' - in (r ++ r', ps'') - -{-Extending calls version-} -introduceCalls :: [TLCommon A] -> (Filename, Program A) -> (Report, (Filename, Program A)) -introduceCalls cenv (fname, ps) = do ps' <- mapM (transformBiM commonElim) ps - -- ps'' <- mapM (transformBiM commonElim'') ps' - return (fname, ps') - - where commonElim s@(Sub a sp mbt (SubName a' moduleName) (Arg p arg asp) b) = - - let commons = lookups moduleName (lookups fname cenv) - sortedC = sortBy cmpTConBNames commons - tArgs = extendArgs (nonNullArgs arg) asp (concatMap snd sortedC) - --ra = p { refactored = Just (fst sp) } - arg' = Arg unitAnnotation (ASeq unitAnnotation arg tArgs) asp - a' = a -- { pRefactored = Just sp } - r = (show $ srcLineCol $ snd asp) ++ ": changed common variables to parameters\n" - in do b' <- transformBiM (extendCalls fname moduleName cenv) b - (r, Sub a' sp mbt (SubName a' moduleName) arg' b') - - commonElim s = --case (getSubName s) of - -- Just n -> transformBiM (extendCalls fname n cenv) s - -- Nothing -> - transformBiM r s - where r :: ProgUnit A -> (Report, ProgUnit A) - r p = case getSubName p of - Just n -> transformBiM (extendCalls fname n cenv) p - Nothing -> return p - - -extendCalls :: String -> String -> [TLCommon A] -> Fortran A -> (Report, Fortran A) -extendCalls fname localSub cenv f@(Call p sp v@(Var _ _ ((VarName _ n, _):_)) (ArgList ap arglist)) = - let commons = lookups n (map snd cenv) - targetCommonNames = map fst (sortBy cmpTConBNames commons) - - localCommons = lookups localSub (lookups fname cenv) - localCommons' = sortBy cmpTConBNames localCommons - - p' = p { refactored = Just $ toCol0 $ fst sp } - ap' = ap { refactored = Just $ fst sp } - - arglist' = toArgList p' sp (select targetCommonNames localCommons') - r = (show $ srcLineCol $ fst sp) ++ ": call, added common variables as parameters\n" - in (r, Call p' sp v (ArgList ap' $ ESeq p' sp arglist arglist')) - - -- Nothing -> error "Source has less commons than the target!" -extendCalls _ _ _ f = return f - - -toArgList :: A -> SrcSpan -> [(Variable, Type A)] -> Expr A -toArgList p sp [] = NullExpr p sp -toArgList p sp ((v, _):xs) = ESeq p sp (Var p sp [(VarName p v, [])]) (toArgList p sp xs) - -select :: [Maybe String] -> [TCommon A] -> [(Variable, Type A)] -select [] _ = [] -select x [] = error $ "Source has less commons than the target!" ++ show x -select a@(x:xs) b@((y, e):yes) | x == y = e ++ select xs yes - | otherwise = select xs yes - -nonNullArgs (ASeq _ _ _) = True -nonNullArgs (ArgName _ _) = True -nonNullArgs (NullArg _) = False - - -extendArgs nonNullArgs sp' args = if nonNullArgs then - let p' = unitAnnotation { refactored = Just $ snd sp' } - in ASeq p' (ArgName p' "") (extendArgs' sp' args) - else extendArgs' sp' args - - -extendArgs' _ [] = NullArg unitAnnotation -extendArgs' sp' ((v, t):vts) = - let p' = unitAnnotation { refactored = Just $ fst sp' } - in ASeq p' (ArgName p' v) (extendArgs' sp' vts) - -{- blockExtendDecls (Block a s i sp ds f) ds' = Block a s i sp (DSeq unitAnnotation ds ds') f - - extendArgs _ [] = (NullDecl unitAnnotation, NullArg unitAnnotation) - extendArgs sp' ((v, t):vts) = - let p' = unitAnnotation { refactored = Just $ toCol0 $ fst sp' } - dec = Decl p' [(Var p' sp' [(VarName p' v, [])], NullExpr p' sp')] t - arg = ArgName p' v - (decs, args) = extendArgs sp' vts - in (DSeq p' dec decs, ASeq p' arg args) --} - - - - -{- - collectTCommons :: [Program Annotation] -> State (TCommons Annotation) [Program Annotation] - collectTCommons p = transformBiM collectTCommons' p -(transformBiM collectTCommons) --} - - -collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A) -collectCommons fname pname b = - let tenv = typeEnv b - - commons' :: Decl A -> State (Report, [TLCommon A]) (Decl A) - 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) - return $ (NullDecl (a { refactored = (Just $ fst sp) }) sp) - commons' f = return f - - typeCommonExprs :: [Expr Annotation] -> [(Variable, Type Annotation)] - typeCommonExprs [] = [] - 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 - -{- --- Turn common blocks into type defs - - commonToTypeDefs :: String -> [(String, [Program Annotation])] -> IO Report - commonToTypeDefs d = - let name = d ++ "Types" - unitSrcLoc = SrcLoc (name ++ ".f90") 0 0 - decls = undefined - mod = Module () (unitSrcLoc, unitSrcLoc) (SubName () name) [] ImplicitNode decls [] - in let ?variant = DefaultPP in writeFile (d ++ "/" ++ name ++ ".f90") (outputF mod) - - - commonToTypeDefs' :: String -> (String, [Program Annotation]) -> [Decls] - commonToTypeDefs' = undefined -- DerivedTypeDef p --} diff --git a/src/Camfort/Transformation/DeadCode.hs b/src/Camfort/Transformation/DeadCode.hs --- a/src/Camfort/Transformation/DeadCode.hs +++ b/src/Camfort/Transformation/DeadCode.hs @@ -15,44 +15,74 @@ -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} module Camfort.Transformation.DeadCode where import Camfort.Analysis.Annotations -import Camfort.Analysis.LVA -import Camfort.Analysis.Syntax -import Camfort.Transformation.Syntax -import Camfort.Traverse -import Language.Fortran - +import qualified Language.Fortran.Analysis.DataFlow as FAD +import qualified Language.Fortran.Analysis.Renaming as FAR +import qualified Language.Fortran.Analysis.BBlocks as FAB +import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Util.Position as FU +import qualified Language.Fortran.Analysis as FA import Camfort.Helpers +import Camfort.Helpers.Syntax -import Generics.Deriving.Copoint +import qualified Data.IntMap as IM +import qualified Data.Set as S +import Data.Generics.Uniplate.Operations +import Data.Maybe import GHC.Generics import Debug.Trace -import Data.Generics.Uniplate.Operations +-- Eliminate dead code from a program, based on the fortran-src +-- live-variable analysis -deadCode :: Bool -> (Filename, Program Annotation) -> (Report, (Filename, Program Annotation)) -deadCode flag (fname, p) = - let (r, p') = mapM ((transformBi elimEmptyFseq) . transformBiM (elimDead flag)) (lva p) - in if r == "" then (r, (fname, p')) - else (r, (fname, p')) >>= (deadCode flag) +-- Currently only strips out dead code through simple variable assignments +-- but not through array-subscript assignmernts +deadCode :: Bool -> (Filename, F.ProgramFile A) + -> (Report, (Filename, F.ProgramFile A)) +deadCode flag (fname, pf) = (report, (fname, fmap FA.prevAnnotation pf')) + where + (report, pf'') = deadCode' flag lva pf' + -- initialise analysis + pf' = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ pf + -- get map of program unit ==> basic block graph + bbm = FAB.genBBlockMap pf' + -- build the supergraph of global dependency + sgr = FAB.genSuperBBGr bbm + -- extract the supergraph itself + gr = FAB.superBBGrGraph sgr + -- live variables + lva = FAD.liveVariableAnalysis gr -elimEmptyFseq :: Fortran Annotation -> Fortran Annotation -elimEmptyFseq (FSeq _ _ (NullStmt _ _) n2@(NullStmt _ _)) = n2 -elimEmptyFseq f = f +deadCode' :: Bool -> FAD.InOutMap (S.Set F.Name) + -> F.ProgramFile (FA.Analysis A) + -> (Report, F.ProgramFile (FA.Analysis A)) +deadCode' flag lva pf = + if null report + then (report, pf') + else (report, pf') >>= deadCode' flag lva + where + (report, pf') = transformBiM (perStmt flag lva) pf -elimDead :: Bool -> Fortran Annotation -> (Report, Fortran Annotation) -elimDead flag x@(Assg a sp@(s1, s2) e1 e2) | (pRefactored a) == flag = - let lOut = liveOut a - -- currently assumes an assign defines only one access (which is usual) - in if ((varExprToAccesses e1) == []) || ((head $ varExprToAccesses e1) `elem` lOut) then - return x - else let report = "o" ++ (show . srcLineCol $ s1) ++ ": removed dead code\n" - in (report, NullStmt (a { refactored = (Just s1) }) (dropLine sp)) -elimDead _ x = return x - +-- Core of the transformation happens here on assignment statements +perStmt :: Bool + -> FAD.InOutMap (S.Set F.Name) + -> F.Statement (FA.Analysis A) -> (Report, F.Statement (FA.Analysis A)) +perStmt flag lva x@(F.StExpressionAssign a sp@(FU.SrcSpan s1 s2) e1 e2) + | pRefactored (FA.prevAnnotation a) == flag = + fromMaybe ("", x) $ + do label <- FA.insLabel a + (_, out) <- IM.lookup label lva + assignedName <- extractVariable e1 + if assignedName `S.member` out + then Nothing + else -- Dead assignment + Just (report, F.StExpressionAssign a' (dropLine sp) e1 e2) + where report = "o" ++ show s1 ++ ": removed dead code\n" + -- Set annotation to mark statement for elimination in + -- the reprinter + a' = onPrev (\ap -> ap {refactored = Just s1}) a +perStmt _ _ x = return x diff --git a/src/Camfort/Transformation/DerivedTypeIntro.hs b/src/Camfort/Transformation/DerivedTypeIntro.hs deleted file mode 100644 --- a/src/Camfort/Transformation/DerivedTypeIntro.hs +++ /dev/null @@ -1,259 +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 #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Camfort.Transformation.DerivedTypeIntro where - -import Data.Data -import Data.List hiding (union, insert) -import Data.Maybe -import Data.Set hiding (foldl, map) - -import Data.Generics.Uniplate.Operations - -import Control.Monad.State.Lazy - -import Debug.Trace - -import qualified Data.Map as Data.Map - -import Language.Fortran - -import Camfort.Analysis.Annotations -import Camfort.Analysis.IntermediateReps -import Camfort.Analysis.Syntax -import Camfort.Transformation.Syntax -import Camfort.Analysis.Types - -import Camfort.Helpers -import Camfort.Traverse - -typeStruct :: [(Filename, Program Annotation)] -> (Report, [(Filename, Program Annotation)]) -typeStruct fps = mapM (\(f, ps) -> mapM typeStructPerProgram ps >>= (\ps' -> return (f, ps'))) fps - --- raph data structures used to build interference graphs - -type Graph v a = [((v, v), a)] -- Note, this is graphs with labelled edges - -type WeightedEdge v a = ((v, v), (a, Int)) -type WeightedGraph v a = [WeightedEdge v a] - --- vertices :: WeightedGraph v a -> [v] (also works for Graph v a) -vertices = concatMap (\((x, y), _) -> [x, y]) - --- isVertex :: v -> WeightedGraph v a -> Bool (also works Graph v a) -isVertex v wgs = elem v (vertices wgs) - -getVertex v [] = Nothing -getVertex v (((v1, v2), d):es) = if v == v1 || v == v2 then Just d - else getVertex v es - - --- on-interprocedural version first - -typeStructPerProgram :: ProgUnit Annotation -> (Report, ProgUnit Annotation) -typeStructPerProgram p = descendBiM - (\b@(Block a uses implicits span decs blockBody) -> - let - tenv = typeEnv b - - -- Compute graph of semantically related projection variables - es = Exprs `topFrom` b - prjVarsWTarget = map locsFromArrayIndex es - iGraph = toInterferenceGraph prjVarsWTarget - wiGraph = calculateWeights iGraph -- weighted inteference graph - wgf = decomposeWeightedGraph wiGraph - - -- Generate definitions - tDefsAndNames = evalState (mapM (mkTypeDef tenv (fst span, fst span)) wgf) 0 - - nwgf = zip wgf (map snd tDefsAndNames) - - rAnnotation = if (length tDefsAndNames > 0) - then unitAnnotation { refactored = Just (fst span) } - else unitAnnotation - - blockBody' = elimProjectionDefs blockBody iGraph - - decs' = foldl (DSeq unitAnnotation) decs (map fst tDefsAndNames) - a' = if (length tDefsAndNames > 0) then a { refactored = Just (fst span) } else a - in -- Create outgoing block - (show wiGraph ++ "\n\n" ++ show wgf, Block a' uses implicits span decs' blockBody')) p - --- - Graph Access Variable here is a graph with projection variables at nodes --- - and the array target that they both index as the edge label - -toInterferenceGraph :: [[(Variable, Access)]] -> Graph Access Variable -toInterferenceGraph pvars = let rel = concatMap listToSymmRelation pvars - matchingArrayTargets r ((a, x), (b, y)) - | a == b = ((x, y), a) : r - | otherwise = r - in foldl matchingArrayTargets [] rel - - -listToSymmRelation :: [a] -> [(a, a)] -listToSymmRelation [] = [] -listToSymmRelation (x:xs) = ((repeat x) `zip` xs) ++ (listToSymmRelation xs) - - --- heck coherence of original manual projection approach - -correctManualImpl ranges stmt graph = - let (_, pvarmap) = runState (transformBiM collect stmt) Data.Map.empty - in Data.Map.foldWithKey - (\arr vixs p -> case (lookup arr ranges) of - Just (l, u) -> (sort (map snd vixs) == [l..u]) && p) True pvarmap - - where - collect :: Fortran A -> State (Data.Map.Map Variable [(Variable, Integer)]) (Fortran A) - collect a@(Assg p sp e1 e2) = - do indexMap <- get - case (do v <- varExprToVariable e1 - arr <- getVertex (VarA v) graph - case e2 of - (ConS _ _ val) -> - case (Data.Map.lookup arr indexMap) of - Just ixs -> - case (lookup v ixs) of - Just val' -> Nothing -- error "Repeated definition of projection" - Nothing -> Just $ Data.Map.update (\ixs -> Just $ ((v, read $ val) : ixs)) arr indexMap - Nothing -> Just $ Data.Map.insert arr [(v, read $ val)] indexMap) of - Just indexMap' -> do put indexMap'; return a - Nothing -> return a - collect f = return f - - -elimProjectionDefs :: Fortran A -> Graph Access Variable -> Fortran A -elimProjectionDefs stmt graph = transformBi ef stmt - where ef a@(Assg p sp e1 e2) = - case (varExprToVariable e1) of - Just v -> if (isVertex (VarA v) graph) then - NullStmt (p { refactored = Just $ dropLine' sp }) sp - else a - Nothing -> a - ef f = f - - -arrayAccessToProjection :: Fortran A -> Graph Access Variable -> Fortran A -arrayAccessToProjection = undefined - - --- ounts number of duplicate edges and makes this the "weight" - -calculateWeights :: (Eq (AnnotationFree a), Eq (AnnotationFree v), Ord a, Ord v) => Graph v a -> WeightedGraph v a -calculateWeights xs = calcWs (sort xs) 1 - where calcWs [] _ = [] - calcWs [((v1, v2), a)] n = [((v1, v2), (a, n))] - calcWs (e@((v1, v2), a):(e':es)) n | ((af e == af e') || (af e == (af (swap e')))) - = calcWs (e':es) (n + 1) - | otherwise = ((v1, v2), (a, n)) : (calcWs (e':es) 1) - -swap ((a, b), v) = ((b, a), v) - --- inds the variables that are used to index arrays directly - -locsFromArrayIndex :: Data t => t -> [(Variable, Access)] -locsFromArrayIndex x = - concat . concat $ - each (Vars `from` x) - (\(Var _ _ ves) -> - each ves (\(VarName _ v, ixs) -> - if (not $ all isConstant ixs) - then map (\x -> (v, x)) (Locs `from` ixs) - else [])) - - - - -findMatch v ix ((wg, n):wgns) = vertices - - --- replaceAccess :: [(WeightedGraph Variable Access, Variable)] -> Block Annotation -> Block Annotation --- replaceAccess wgns x = transformBi (\t@(VarName _ v, ixs) -> t) x --- --- - -mkTyDecl :: SrcSpan -> Variable -> Type Annotation -> Decl Annotation -mkTyDecl sp v t = let ua = unitAnnotation - in Decl ua sp [(Var ua sp [(VarName ua v, [])], NullExpr ua sp, Nothing)] t - -mkTypeDef :: TypeEnv Annotation -> SrcSpan -> WeightedGraph Access Variable -> State Int (Decl Annotation, String) -mkTypeDef tenv sp wg = (inventName wg) >>= (\name -> - let edgeToDecls ((vx, vy), (va, w)) = - case (lookup va tenv) of - Just t -> [mkTyDecl sp (accessToVarName vx) (arrayElementType t), - mkTyDecl sp (accessToVarName vy) (arrayElementType t)] - Nothing -> error $ "Can't find the type of " ++ show va ++ "\n" - - ra = unitAnnotation { refactored = Just (fst sp) } - - (_, (arrayVar, _)) = head wg - - tdecls = concatMap edgeToDecls wg - typeDecl = DerivedTypeDef ra sp (SubName ra name) [] [] tdecls - - typeCons = BaseType ra (DerivedType ra (SubName ra name)) [] (NullExpr ra sp) (NullExpr ra sp) - valDecl = Decl ra sp [(Var ra sp [(VarName ra (arrayVar ++ name), [])] , NullExpr ra sp, Nothing)] typeCons - in return $ (DSeq unitAnnotation typeDecl valDecl, name)) - -inventName :: WeightedGraph Access Variable -> State Int String -inventName graph = do n <- get - put (n + 1) - let vs = vertices graph - return $ map mode (transpose (map accessToVarName vs)) ++ (show n) --- -mode :: String -> Char -mode x = let freqs = (map (\x -> (head x, length x))) . group . sort $ x - sortedFreqs = sortBy (\x -> \y -> (snd x) `compare` (snd y)) freqs - max = last sortedFreqs - in -- mode or 'X' if mode is less than the majority - if (snd max) > ((length x) `div` 2) then fst max else 'X' - -decomposeWeightedGraph :: forall v a . (Show v, Ord v, Ord a) => WeightedGraph v a -> [WeightedGraph v a] -decomposeWeightedGraph g = map snd (concatMap (foldl binEdge []) (groupBy groupOnArrayVar (sortBy sortOnArrayVar g))) - where groupOnArrayVar (_, (av, _)) (_, (av', _)) = av == av' - sortOnArrayVar (_, (av, _)) (_, (av', _)) = compare av av' - --- ap snd (foldl binEdge [] g) - --- bins" edges into a list of graphs with a set of their vertices - -binEdge :: (Show v, Ord v, Ord a) => [(Set v, WeightedGraph v a)] -> WeightedEdge v a -> [(Set v, WeightedGraph v a)] -binEdge bins e@((x, y), _) = - let findBin v [] = ((insert x empty, []), []) - findBin v ((vs, es):bs) | member v vs = ((insert v vs, es), bs) - | otherwise = let (n, bs') = findBin v bs - in (n, (vs, es) : bs') - ((vs, es), bins') = findBin x bins - ((vs', es'), bins'') = findBin y bins' - in (vs `union` vs', e : (es ++ es')) : bins'' - - - - --- binEdge bins e@((x, y), _) = let r = binVertex y e (binVertex x e bins) in (show r) `trace` r - --- binVertex :: Ord a => a -> WeightedEdge a -> [(Set a, WeightedGraph a)] -> [(Set a, WeightedGraph a)] --- binVertex x e ss = bin' x e ss [] Nothing --- where bin' x e [] bs' Nothing = (insert x empty, [e]) : bs' --- bin' x e [] bs' (Just s) = s : bs' --- --- bin' x e ((vs, es):bs) bs' ms | member x vs = --- case ms of --- Nothing -> bin' x e bs bs' (Just (insert x vs, e:es)) --- Just (vs', es') -> bin' x e bs bs' (Just (union vs' (insert x vs'), (e:es) ++ es')) --- | otherwise = bin' x e bs ((vs, es):bs) ms diff --git a/src/Camfort/Transformation/EquivalenceElim.hs b/src/Camfort/Transformation/EquivalenceElim.hs --- a/src/Camfort/Transformation/EquivalenceElim.hs +++ b/src/Camfort/Transformation/EquivalenceElim.hs @@ -14,96 +14,155 @@ limitations under the License. -} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE FlexibleContexts #-} module Camfort.Transformation.EquivalenceElim where import Data.Data import Data.List - +import qualified Data.Map as M import Data.Generics.Uniplate.Operations import Control.Monad.State.Lazy -import Language.Fortran +import qualified Language.Fortran.AST as F +import qualified Language.Fortran.Analysis.Types as FAT (analyseTypes, TypeEnv) +import qualified Language.Fortran.Util.Position as FU +import qualified Language.Fortran.Analysis.Renaming as FAR +import qualified Language.Fortran.Analysis as FA import Camfort.Output -import Camfort.Traverse import Camfort.Helpers - -import Language.Fortran.Pretty - +import Camfort.Helpers.Syntax import Camfort.Analysis.Annotations -import Camfort.Analysis.Syntax -import Camfort.Analysis.Types - import Camfort.Transformation.DeadCode -import Camfort.Transformation.Syntax import Debug.Trace -type RfEqState = ([[Expr Annotation]], Int, Report) +type A1 = FA.Analysis Annotation +type RmEqState = ([[F.Expression A1]], Int, Report) -refactorEquivalences :: (Filename, Program Annotation) -> (Report, (Filename, Program Annotation)) -refactorEquivalences (fname, p) = - let ?fname = fname - in do p' <- mapM (transformBiM equivalences) p - deadCode True (fname, p') - where equivalences :: (?fname :: String) => Block Annotation -> (Report, Block Annotation) - equivalences b = let equiv = do b' <- rmEquivalences b - transformBiM (addCopy (typeEnv b)) b' - (b', (_, _, r)) = runState equiv ([], 0, "") - in (r, b') +refactorEquivalences :: + (Filename, F.ProgramFile A) -> (Report, (Filename, F.ProgramFile A)) +refactorEquivalences (fname, pf) = do + -- initialise analysis + let pf' = FAR.analyseRenames . FA.initAnalysis $ pf + -- calculate types + let (pf'', typeEnv) = FAT.analyseTypes pf' + -- Remove equivalences and add appropriate copy statements + pf''' <- refactoring typeEnv pf'' + -- Lastly deadcode eliminate any redundant copy statements + -- generated by the refactoring (but don't dead code elim + -- existing code) + deadCode True (fname, fmap FA.prevAnnotation pf''') + where + refactoring :: FAT.TypeEnv -> F.ProgramFile A1 -> (Report, F.ProgramFile A1) + refactoring tenv pf = (report, pf') + where + (pf', (_, _, report)) = runState equiv ([], 0, "") -addCopy :: (?fname :: String) => TypeEnv Annotation -> Fortran Annotation -> State RfEqState (Fortran Annotation) -addCopy tys x@(Assg a sp@(s1, s2) e1 e2) | not (pRefactored a) = - do eqs <- equivalents e1 - if (length eqs > 1) then + equiv = do pf' <- transformBiM perBlockRmEquiv pf + descendBiM (addCopysPerBlockGroup tenv) pf' - - let a' = a { refactored = Just s1 } - sp' = refactorSpan sp - eqs' = deleteBy (\x -> \y -> (af x) == (af y)) e1 eqs -- remove self from list +addCopysPerBlockGroup :: FAT.TypeEnv -> [F.Block A1] -> State RmEqState [F.Block A1] +addCopysPerBlockGroup tenv blocks = do + blockss <- mapM (addCopysPerBlock tenv) blocks + return $ concat blockss - -- Create copy statements - mkCopy (n, e') = let sp' = refactorSpanN n sp - in - case ((varExprToVariable e1) >>= (\v1' -> varExprToVariable e' >>= (\v' -> return $ eqType v1' v' tys))) of - Nothing -> Assg a' sp' e' e1 -- could be an error - Just False -> Assg a' sp' e' (Var a' sp' [(VarName a' "transfer", [e1, e'])]) - Just True -> Assg a' sp' e' e1 - eqs'' = map mkCopy (zip [0..(length eqs')] eqs') +addCopysPerBlock :: FAT.TypeEnv -> F.Block A1 -> State RmEqState [F.Block A1] +addCopysPerBlock tenv x@(F.BlStatement a0 s0 lab + (F.StExpressionAssign a sp@(FU.SrcSpan s1 s2) dstE srcE)) + | not (pRefactored $ FA.prevAnnotation a) = do + -- Find all variables/cells that are equivalent to the target + -- of this assignment + eqs <- equivalentsToExpr dstE + -- If there is only one, then it must refer to itself, so do nothing + if length eqs <= 1 + then return [x] + -- If there are more than one, copy statements must be generated + else do + (equivs, n, r) <- get - -- Reporting - (l, c) = srcLineCol s1 - reportF (e', i) = ?fname ++ show (l + i, c) ++ ": addded copy: " ++ (pprint e') ++ " due to refactored equivalence\n" - report n = concatMap reportF (zip eqs'' [n..(n + length eqs'')]) + -- Remove the destination from the equivalents + let eqs' = deleteBy (\x y -> af x == af y) dstE eqs - in do -- Update refactoring state - (equivs, n, r) <- get - put (equivs, n + (length eqs'), r ++ (report n)) + -- Make copy statements + let pos = afterAligned sp + let copies = map (mkCopy tenv pos dstE) eqs' - -- Sequence original assignment with new assignments - return $ FSeq a sp x (foldl1 (FSeq a' sp') eqs'') - else - return x -addCopy tys x = return x + -- Reporting + let (FU.Position _ c l) = s1 + let reportF i = show (l + i) ++ ":" ++ show c + ++ ": added copy due to refactored equivalence\n" + let report n = concatMap reportF [n..(n + length copies - 1)] + -- Update refactoring state + put (equivs, n + length eqs', r ++ report n) + -- Sequence original assignment with new assignments + return $ x : copies -rmEquivalences :: (?fname :: String) => (Block Annotation) -> State RfEqState (Block Annotation) -rmEquivalences = transformBiM rmEquiv' - where rmEquiv' :: Decl Annotation -> State RfEqState (Decl Annotation) - rmEquiv' f@(Equivalence a sp equivs) = - do (ess, n, r) <- get - put (equivs:ess, n - 1, r ++ ?fname ++ (show . srcLineCol . fst $ sp) ++ ": removed equivalence \n") - return (NullDecl (a { refactored = (Just $ fst sp) }) (dropLine sp)) - rmEquiv' f = return f +addCopysPerBlock tenv x = do + x' <- descendBiM (addCopysPerBlockGroup tenv) x + return [x'] --- equivalents e" returns a list of variables/memory cells that have been equivalenced with "e". --- -equivalents :: (?fname :: String) => Expr Annotation -> State RfEqState [Expr Annotation] -equivalents x = let inGroup x [] = [] - inGroup x (xs:xss) = if (AnnotationFree x `elem` (map AnnotationFree xs)) then xs - else inGroup x xss - in do (equivs, _, _) <- get - return (inGroup x equivs) +-- see if two expressions have the same type +equalTypes tenv e e' = do + v1 <- extractVariable e + v2 <- extractVariable e' + t1 <- M.lookup v1 tenv + t2 <- M.lookup v2 tenv + if t1 == t2 then Just t1 else Nothing + +-- Create copy statements. Parameters: +-- * A type environment to find out if a type cast is needed +-- * A SrcPos where the copy statements are going to inserted at +-- * The source expression +-- * The number of copies to increment the line by +-- paired with the destination expression +mkCopy :: FAT.TypeEnv + -> FU.Position + -> F.Expression A1 -> F.Expression A1 -> F.Block A1 +mkCopy tenv pos srcE dstE = FA.initAnalysis $ + F.BlStatement a sp Nothing $ + case equalTypes tenv srcE dstE of + -- Types not equal, so create a transfer + Nothing -> F.StExpressionAssign a sp dstE' call + where + call = F.ExpFunctionCall a sp transf argst + transf = F.ExpValue a sp (F.ValVariable "transfer") + argst = Just (F.AList a sp args) + args = map (F.Argument a sp Nothing) [srcE', dstE'] + -- Types are equal, simple a assignment + Just t -> F.StExpressionAssign a sp dstE' srcE' + where + -- Set position to be at col = 0 + sp = FU.SrcSpan (toCol0 pos) (toCol0 pos) + -- But store the aligned position in refactored so + -- that the reprint algorithm can add the appropriate indentation + a = unitAnnotation { refactored = Just pos, newNode = True } + dstE' = FA.stripAnalysis dstE + srcE' = FA.stripAnalysis srcE + +perBlockRmEquiv :: F.Block A1 -> State RmEqState (F.Block A1) +perBlockRmEquiv = transformBiM perStatementRmEquiv + +perStatementRmEquiv :: F.Statement A1 -> State RmEqState (F.Statement A1) +perStatementRmEquiv f@(F.StEquivalence a sp@(FU.SrcSpan spL spU) equivs) = do + (ess, n, r) <- get + let report = r ++ show spL ++ ": removed equivalence \n" + put (((map F.aStrip) . F.aStrip $ equivs) ++ ess, n - 1, r ++ report) + let a' = onPrev (\ap -> ap {refactored = Just spL, deleteNode = True}) a + return (F.StEquivalence a' (deleteLine sp) equivs) +perStatementRmEquiv f = return f + +-- 'equivalents e' returns a list of variables/memory cells +-- that have been equivalenced with "e". +equivalentsToExpr :: F.Expression A1 -> State RmEqState [F.Expression A1] +equivalentsToExpr x = do + (equivs, _, _) <- get + return (inGroup x equivs) + where + inGroup x [] = [] + inGroup x (xs:xss) = + if AnnotationFree x `elem` map AnnotationFree xs + then xs + else inGroup x xss diff --git a/src/Camfort/Transformation/Syntax.hs b/src/Camfort/Transformation/Syntax.hs deleted file mode 100644 --- a/src/Camfort/Transformation/Syntax.hs +++ /dev/null @@ -1,127 +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 ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} - -{-# LANGUAGE DeriveGeneric #-} - -module Camfort.Transformation.Syntax where - --- tandard imports - -import Data.Char -import Data.List -import Control.Monad.State.Lazy -import qualified Data.Map as Data.Map - --- ata-type generics imports - -import Data.Data -import Data.Generics.Uniplate.Data -import Data.Generics.Uniplate.Operations -import Data.Generics.Zipper -import Data.Typeable - --- amFort specific functionality - -import Camfort.Analysis.Annotations -import Camfort.Analysis.IntermediateReps -import Camfort.Traverse -import Language.Fortran - --- import Language.Haskell.Syntax (SrcLoc(..)) - --- ODO: Needs fixing with the spans - need to pull apart and put back together - -reassociate :: Fortran Annotation -> Fortran Annotation -reassociate (FSeq a1 sp1 (FSeq a2 sp2 a b) c) = FSeq a1 sp1 (reassociate a) (FSeq a2 sp2 (reassociate b) (reassociate c)) -reassociate t = t - --- reassociate :: Fortran Annotation -> Fortran Annotation --- reassociate (FSeq a1 sp1 (FSeq a2 sp2 a b) c) = FSeq a1 sp1 (reassociate a) (FSeq a2 sp2 (reassociate b) (reassociate c)) --- reassociate t = t - - --- elpers to do with source locations and parsing - -refactorSpan :: SrcSpan -> SrcSpan -refactorSpan (SrcLoc f ll cl, SrcLoc _ lu cu) = (SrcLoc f (lu+1) 0, SrcLoc f lu cu) - -refactorSpanN :: Int -> SrcSpan -> SrcSpan -refactorSpanN n (SrcLoc f ll cl, SrcLoc _ lu cu) = (SrcLoc f (lu+1+n) 0, SrcLoc f (lu+n) cu) - -incLine (SrcLoc f l c) = SrcLoc f (l + 1) c -decLine (SrcLoc f l c) = SrcLoc f (l - 1) c -incCol (SrcLoc f l c) = SrcLoc f l (c + 1) -decCol (SrcLoc f l c) = SrcLoc f l (c - 1) -toCol0 (SrcLoc f l c) = SrcLoc f l 0 - --- ropLine extends a span to the start of the next line --- his is particularly useful if a whole line is being redacted from a source file - -linesCovered :: SrcLoc -> SrcLoc -> Int -linesCovered (SrcLoc _ l1 _) (SrcLoc _ l2 _) = l2 - l1 + 1 - -dropLine :: SrcSpan -> SrcSpan -dropLine (s1, SrcLoc f l c) = (s1, SrcLoc f (l+1) 0) - -dropLine' :: SrcSpan -> SrcLoc -dropLine' (SrcLoc f l c, _) = SrcLoc f l 0 - -srcLineCol :: SrcLoc -> (Int, Int) -srcLineCol (SrcLoc _ l c) = (l, c) - -minaa (SrcLoc f l c) = (SrcLoc f (l-1) c) - -nullLoc :: SrcLoc -nullLoc = SrcLoc "" 0 0 - -nullSpan :: SrcSpan -nullSpan = (nullLoc, nullLoc) - -afterEnd :: SrcSpan -> SrcSpan -afterEnd (_, SrcLoc f l c) = (SrcLoc f (l+1) 0, SrcLoc f (l+1) 0) - --- ariable renaming - -caml (x:xs) = (toUpper x) : xs - -type Renamer = Data.Map.Map Variable Variable - -type RenamerCoercer = Maybe (Data.Map.Map Variable (Maybe Variable, Maybe (Type A, Type A))) - -- Nothing represents an overall identity renamer/coercer for efficiency - -- a Nothing for a variable represent a variable-level (renamer) identity - -- a Nothing for a type represents a type-level (coercer) identity - -applyRenaming :: (Typeable (t A), Data (t A)) => Renamer -> (t A) -> (t A) -applyRenaming r = transformBi ((\vn@(VarName p v) -> case Data.Map.lookup v r of - Nothing -> vn - Just v' -> VarName p v')::(VarName A -> VarName A)) - -class Renaming r where - hasRenaming :: Variable -> r -> Bool - -instance Renaming RenamerCoercer where - hasRenaming _ Nothing = False - hasRenaming v (Just rc) = Data.Map.member v rc - --- sometimes we have a number of renamer coercers together -instance Renaming [RenamerCoercer] where - hasRenaming v rcss = or (map (hasRenaming v) rcss) diff --git a/src/Camfort/Traverse.hs b/src/Camfort/Traverse.hs deleted file mode 100644 --- a/src/Camfort/Traverse.hs +++ /dev/null @@ -1,183 +0,0 @@ -{- - Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} - -module Camfort.Traverse where - -import Camfort.Analysis.Annotations -import Language.Fortran - -import Generics.Deriving.Base -import Generics.Deriving.Copoint -import GHC.Generics - -import Control.Monad.Trans.Writer.Lazy - -import Data.Generics.Zipper -import Data.Generics.Aliases -import Data.Generics.Str -import Data.Generics.Uniplate.Operations - -import Language.Fortran.Lexer - -import Control.Comonad - -import Data.Data -import Data.Maybe -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 - -extendBi :: (Biplate (from a) (to a), RComonad to) => (to a -> a) -> (from a) -> (from a) -extendBi f x = case biplate x of - (current, generate) -> generate $ strMap (rextend f) current - -reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a] -reduceCollect k x = execWriter (transformBiM (\y -> do case k y of - Just x -> tell [x] - Nothing -> return () - return y) x) - --- Data-type generic comonad-style traversal with zipper (contextual traversal) - -everywhere :: (Zipper a -> Zipper a) -> Zipper a -> Zipper a -everywhere k z = let everywhere' = enterRight . enterDown . k - - enterDown z = case (down' z) of - Just dz -> let dz' = everywhere' dz - in case (up $ dz') of - Just uz -> uz - Nothing -> dz' - Nothing -> z - - enterRight z = case (right z) of - Just rz -> let rz' = everywhere' rz - in case (left $ rz') of - Just lz -> lz - Nothing -> rz' - Nothing -> z - in everywhere' z - -zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a) -zfmap f x = zeverywhere (mkT f) x - --- This one is less useful as the definitions for comonads are then very annoying - -extendBi' :: (Biplate (from a) (to a), Comonad to) => (to a -> a) -> (from a) -> (from a) -extendBi' f x = case biplate x of - (current, generate) -> generate $ strMap (extend f) current - -class RComonad t where - rextract :: t a -> a - rextend :: (t a -> a) -> t a -> t a - -class RFunctor t where - rfmap :: (a -> a) -> t a -> t a - -instance RComonad Fortran where - rextract x = tag x - - rextend k y@(Assg _ sp e1 e2) = Assg (k y) sp e1 e2 - rextend k y@(For _ sp v e1 e2 e3 fs) = For (k y) sp v e1 e2 e3 (rextend k fs) - rextend k y@(FSeq _ sp f1 f2) = FSeq (k y) sp (rextend k f1) (rextend k f2) - rextend k y@(If _ sp e f1 fes f3) = let fes' = map (\(e, f) -> (e, rextend k f)) fes - f3' = case f3 of - Nothing -> Nothing - Just f3a -> Just (rextend k f3a) - in If (k y) sp e (rextend k f1) fes' f3' - rextend k y@(Allocate _ sp e1 e2) = Allocate (k y) sp e1 e2 - rextend k y@(Backspace _ sp sp') = Backspace (k y) sp sp' - rextend k y@(Call _ sp e as) = Call (k y) sp e as - rextend k y@(Open _ sp s) = Open (k y) sp s - rextend k y@(Close _ sp s) = Close (k y) sp s - rextend k y@(Continue _ sp) = Continue (k y) sp - rextend k y@(Cycle _ sp s) = Cycle (k y) sp s - rextend k y@(Deallocate _ sp es e) = Deallocate (k y) sp es e - rextend k y@(Endfile _ sp s) = Endfile (k y) sp s - rextend k y@(Exit _ sp s) = Exit (k y) sp s - rextend k y@(Forall _ sp es f) = Forall (k y) sp es (rextend k f) - rextend k y@(Goto _ sp s) = Goto (k y) sp s - rextend k y@(Nullify _ sp e) = Nullify (k y) sp e - rextend k y@(Inquire _ sp s e) = Inquire (k y) sp s e - rextend k y@(Rewind _ sp s) = Rewind (k y) sp s - rextend k y@(Stop _ sp e) = Stop (k y) sp e - rextend k y@(Where _ sp e f Nothing) = Where (k y) sp e (rextend k f) Nothing - rextend k y@(Where _ sp e f (Just f')) = Where (k y) sp e (rextend k f) (Just (rextend k f')) - rextend k y@(Write _ sp s e) = Write (k y) sp s e - rextend k y@(PointerAssg _ sp e1 e2) = PointerAssg (k y) sp e1 e2 - rextend k y@(Return _ sp e) = Return (k y) sp e - rextend k y@(Label _ sp s f) = Label (k y) sp s (rextend k f) - rextend k y@(Print _ sp e es) = Print (k y) sp e es - rextend k y@(ReadS _ sp s e) = ReadS (k y) sp s e - rextend k y@(TextStmt _ sp s) = TextStmt (k y) sp s - rextend k y@(NullStmt _ sp) = NullStmt (k y) sp - -class Refill d where - refill :: d a -> a -> d a - -instance Refill Fortran where - refill y@(Assg _ sp e1 e2) a = Assg a sp e1 e2 - refill y@(For _ sp v e1 e2 e3 fs) a = For a sp v e1 e2 e3 fs - refill y@(DoWhile _ sp e f) a = DoWhile a sp e f - refill y@(FSeq _ sp f1 f2) a = FSeq a sp f1 f2 - refill y@(If _ sp e f1 fes f3) a = If a sp e f1 fes f3 - refill y@(Allocate _ sp e1 e2) a = Allocate a sp e1 e2 - refill y@(Backspace _ sp sp') a = Backspace a sp sp' - refill y@(Call _ sp e as) a = Call a sp e as - refill y@(Open _ sp s) a = Open a sp s - refill y@(Close _ sp s) a = Close a sp s - refill y@(Continue _ sp) a = Continue a sp - refill y@(Cycle _ sp s) a = Cycle a sp s - refill y@(DataStmt _ sp p) a = DataStmt a sp p - refill y@(Deallocate _ sp es e) a = Deallocate a sp es e - refill y@(Endfile _ sp s) a = Endfile a sp s - refill y@(Exit _ sp s) a = Exit a sp s - refill y@(Forall _ sp es f) a = Forall a sp es f - refill y@(Format _ sp s) a = Format a sp s - refill y@(Goto _ sp s) a = Goto a sp s - refill y@(Nullify _ sp e) a = Nullify a sp e - refill y@(Inquire _ sp s e) a = Inquire a sp s e - refill y@(Pause _ sp s) a = Pause a sp s - refill y@(Rewind _ sp s) a = Rewind a sp s - refill y@(Stop _ sp e) a = Stop a sp e - refill y@(Where _ sp e f f') a = Where a sp e f f' - refill y@(Write _ sp s e) a = Write a sp s e - refill y@(PointerAssg _ sp e1 e2) a = PointerAssg a sp e1 e2 - refill y@(Return _ sp e) a = Return a sp e - refill y@(Label _ sp s f) a = Label a sp s f - refill y@(Print _ sp e es) a = Print a sp e es - refill y@(ReadS _ sp s e) a = ReadS a sp s e - refill y@(TextStmt _ sp s) a = TextStmt a sp s - refill y@(NullStmt _ sp) a = NullStmt a sp - - -annotation :: Tagged g => g a -> a -annotation = tag diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -30,15 +30,13 @@ import Camfort.Functionality import Data.Text (pack, unpack, split) -import qualified Data.Map as M import Data.Maybe {-| The entry point to CamFort. Displays user information, and handlers which functionality is being requested -} main = do - putStrLn introMsg args <- getArgs - + putStrLn "" if length args >= 2 then let (func : (inp : _)) = args @@ -59,9 +57,11 @@ fun inp (excluded_files opts) outp opts Nothing -> putStrLn fullUsageInfo - else if length args == 1 - then putStrLn $ usage ++ "Please specify an input file/directory" - else putStrLn fullUsageInfo + else do + putStrLn introMsg + if length args == 1 + then putStrLn $ usage ++ "Please specify an input file/directory" + else putStrLn fullUsageInfo -- * Options for CamFort and information on the different modes @@ -80,6 +80,10 @@ "stencil specification inference mode. ID = Do, Assign, or Both" , Option [] ["debug"] (NoArg Debug) "enable debug mode" + , Option [] ["doxygen"] (NoArg Doxygen) + "synthesise annotations compatible with Doxygen" + , Option [] ["ford"] (NoArg Ford) + "synthesise annotations compatible with Ford" ] compilerOpts :: [String] -> IO ([Flag], [String]) @@ -102,10 +106,7 @@ , String))] refactorings = [("common", (common, "common block elimination")), - ("commonArg", (commonToArgs, - "common block elimination (to parameter passing)")), ("equivalence", (equivalences, "equivalence elimination")), - ("dataType", (typeStructuring, "derived data type introduction")), ("dead", (dead, "dead-code elimination"))] {-| List of analses provided by CamFort -} @@ -113,22 +114,21 @@ , (FileOrDir -> [Filename] -> FileOrDir -> Options -> IO () , String))] analyses = - [--("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")), ("stencils-infer", (stencilsInfer, "stencil spec inference")), ("stencils-synth", (stencilsSynth, "stencil spec synthesis")), ("units-suggest", (unitsCriticals, - "suggest variables to annotate for units-of-measure for maximum coverage")), + "suggest variables to annotate with\ + \units-of-measure for maximum coverage")), ("units-check", (unitsCheck, "unit-of-measure checking")), ("units-infer", (unitsInfer, "unit-of-measure inference")), ("units-synth", (unitsSynth, "unit-of-measure synthesise specs.")) ] -- * Usage and about information -version = "0.804" +version = "0.900" introMsg = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure." usage = "Usage: camfort [OUTPUT] [OPTIONS...]\n" menu = diff --git a/tests/Camfort/Analysis/CommentAnnotatorSpec.hs b/tests/Camfort/Analysis/CommentAnnotatorSpec.hs --- a/tests/Camfort/Analysis/CommentAnnotatorSpec.hs +++ b/tests/Camfort/Analysis/CommentAnnotatorSpec.hs @@ -37,8 +37,8 @@ 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." ]) + (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) diff --git a/tests/Camfort/Specification/Stencils/CheckSpec.hs b/tests/Camfort/Specification/Stencils/CheckSpec.hs --- a/tests/Camfort/Specification/Stencils/CheckSpec.hs +++ b/tests/Camfort/Specification/Stencils/CheckSpec.hs @@ -3,86 +3,62 @@ 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 +import Test.Hspec 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) +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 - +spec :: Spec +spec = + describe "Stencils - Check" $ do + describe "Parsing comments into internal rep" $ do + it "parse and convert simple exact stencil (1)" $ + parseAndConvert "= stencil forward(depth=1, dim=1) :: x" + `shouldBe` + (Right $ Right [(["x"], Specification $ + Multiple $ Exact (Spatial (Sum [Product [Forward 1 1 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 exact stencil (2)" $ + parseAndConvert "= stencil forward(depth=1, dim=1) :: x, y, z" + `shouldBe` + (Right $ Right [(["x","y","z"], Specification $ + Multiple $ Exact (Spatial (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)]) + 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 $ + Multiple $ Exact (Spatial (Sum [Product [Centered 1 2 False]])))]) -{- 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 simple upper bounded stencil (3)" $ + parseAndConvert "= stencil atmost, forward(depth=1, dim=1) :: x" + `shouldBe` + (Right $ Right [(["x"], Specification $ + Multiple $ Bound Nothing (Just $ Spatial + (Sum [Product [Forward 1 1 True]])))]) - it "parse and convert stencil requiring distribution (5)" $ - (parseAndConvert "= stencil atleast, readonce, (forward(depth=1, dim=1) * ((centered(depth=1, dim=2)) + backward(depth=3, dim=4))) :: frob") - `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 simple lower bounded stencil (4)" $ + parseAndConvert "= stencil atleast, backward(depth=2, dim=1) :: x" + `shouldBe` + (Right $ Right [(["x"], Specification $ + Multiple $ Bound (Just $ Spatial + (Sum [Product [Backward 2 1 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]])))) + 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 $ + Single $ Bound (Just $ Spatial + (Sum [Product [Forward 1 1 True, Centered 1 2 True], + Product [Forward 1 1 True, Backward 3 4 True]])) Nothing)]) diff --git a/tests/Camfort/Specification/Stencils/GrammarSpec.hs b/tests/Camfort/Specification/Stencils/GrammarSpec.hs --- a/tests/Camfort/Specification/Stencils/GrammarSpec.hs +++ b/tests/Camfort/Specification/Stencils/GrammarSpec.hs @@ -47,10 +47,15 @@ `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" + it "region defn syntactic permutation" $ + parse "= region :: r = forward(dim=1,depth=1) + backward(depth=2, dim=2)" `shouldBe` - Right (SpecDec (Temporal ["a","b","c","foo"] True) ["foo", "bar"]) + Right (RegionDec "r" (Or (Forward 1 1 True) (Backward 2 2 True))) + + it "region defn irreflx syntactic permutation" $ + parse "= region :: r = forward(irreflexive,dim=1,depth=1) + backward(depth=2,irreflexive,dim=2)" + `shouldBe` + Right (RegionDec "r" (Or (Forward 1 1 False) (Backward 2 2 False))) {- Should no longer be possible it "complex stencil" $ diff --git a/tests/Camfort/Specification/Stencils/ModelSpec.hs b/tests/Camfort/Specification/Stencils/ModelSpec.hs --- a/tests/Camfort/Specification/Stencils/ModelSpec.hs +++ b/tests/Camfort/Specification/Stencils/ModelSpec.hs @@ -16,7 +16,7 @@ import Data.Bits import Data.List -import Data.Map hiding (map) +import Data.Set (toList) import Test.Hspec import Test.QuickCheck @@ -24,41 +24,98 @@ spec :: Spec spec = do + describe "Consistency of model vs access patterns" $ do + let singleOneDimSpec = Single $ Exact $ Spatial $ Sum + [ Product [ Forward 1 1 True ] ] + it "1D readOnce - positive" $ do + let acs = Single [[0], [1]] + consistent acs singleOneDimSpec `shouldBe` True + + it "1D readOnce - negative" $ do + let acs = Multiple [[0], [1]] + consistent acs singleOneDimSpec `shouldBe` False + + let reflCentOneDimSpec = Single $ Exact $ Spatial $ Sum + [ Product [ Centered 1 1 False ] ] + it "1D centered irreflexive - positive" $ do + let acs = Single [[-1], [1]] + consistent acs reflCentOneDimSpec `shouldBe` True + + let centeredAcs = Single [[-1], [0], [1]] + it "1D centered irreflexive - negative" $ + consistent centeredAcs reflCentOneDimSpec `shouldBe` False + + it "1D centered irreflexive lower bound - positive" $ do + let spec = Single $ Bound + (Just $ Spatial $ Sum [ Product [ Centered 1 1 False ] ]) + Nothing + consistent centeredAcs spec `shouldBe` True + + it "1D centered irreflexive upper bound - negative" $ do + let spec = Single $ Bound + Nothing + (Just $ Spatial $ Sum [ Product [ Centered 1 1 False ] ]) + consistent centeredAcs spec `shouldBe` False + + it "1D double bounded" $ do + let acs = Single [ [-3], [-2], [-1], [0], [1], [3] ] + let spec = Single $ Bound + (Just $ Spatial $ Sum [ Product [ Centered 1 1 True ] ]) + (Just $ Spatial $ Sum [ Product [ Centered 1 3 True ] ]) + consistent acs spec `shouldBe` True + + it "1D spec 3D access" $ do + let acs = Single [ [0,1,-2], [absoluteRep, 2,3] ] + let spec = Single $ Exact $ + Spatial $ Sum [ Product [ Forward 2 2 False ] ] + consistent acs spec `shouldBe` True + + let twoDimSpec = Single $ Exact $ + Spatial $ Sum [ Product [ Centered 0 1 True, Forward 1 2 True ] ] + + it "2 dimensional spec example" $ do + let acs = Single [ [0,0], [0,1] ] + consistent acs twoDimSpec `shouldBe` True + + it "Constant access not allowed in otherwise fine access pattern" $ do + let acs = Single [ [0,0], [0,1], [absoluteRep, absoluteRep] ] + consistent acs twoDimSpec `shouldBe` False + describe "Stencils - Model" $ do - describe "Test soundness of model 1" $ modelHasLeftInverse + 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 "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]) + 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]) + 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]) + 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 +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)) + 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 @@ -66,70 +123,89 @@ plus x y = x + y -variations :: [([[Int]], Syn.Result Spatial)] +variations :: [([[Int]], Syn.Multiplicity (Syn.Approximation Spatial))] variations = [ ([ [1], [0] ], - Exact $ Spatial NonLinear (Sum [Product [Forward 1 1 True]])) + Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True]])) , ([ [absoluteRep,1], [absoluteRep,0] ], - Exact $ Spatial NonLinear (Sum [Product [Forward 1 2 True]])) + Multiple $ Exact $ Spatial (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]])) + Multiple $ Exact $ Spatial (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]])) + Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Forward 1 2 False]])) , ([ [-1], [0] ], - Exact $ Spatial NonLinear (Sum [Product [Backward 1 1 True]])) + Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True]])) , ([ [absoluteRep,-1], [absoluteRep,0] ], - Exact $ Spatial NonLinear (Sum [Product [Backward 1 2 True]])) + Multiple $ Exact $ Spatial (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]])) + Multiple $ Exact $ Spatial (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 + Multiple $ Exact $ Spatial (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 + Multiple $ Exact $ Spatial (Sum [Product [ Forward 2 2 True, Centered 1 1 True ] ] )) ] -variations2 :: [(Syn.Result [[Int]], Int, Syn.Result Spatial)] +variations2 :: [( Syn.Multiplicity (Syn.Approximation [[Int]]) + , Int + , Syn.Multiplicity (Syn.Approximation 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]])) + ( Multiple $ Exact [ [0, absoluteRep], [1, absoluteRep] ] + , 2 + , Multiple $ Exact $ Spatial (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]]))) - ] + , ( Multiple $ Bound Nothing (Just [ [0, absoluteRep], [1, absoluteRep] + , [2, absoluteRep] ]) + , 2 + , Multiple $ Bound Nothing + (Just $ Spatial (Sum [Product [Forward 2 1 True]])) + ) + ] -variations3 :: [(Syn.Result [[Int]], Int, Syn.Result Spatial)] +variations3 :: [( Syn.Multiplicity (Syn.Approximation [[Int]]) + , Int + , Syn.Multiplicity (Syn.Approximation 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]]))) + ( Multiple $ + Bound Nothing (Just [ [0, absoluteRep, 0], [1, absoluteRep, 0] + , [2, absoluteRep, 0], [0, absoluteRep, 1] + , [1, absoluteRep, 1], [2, absoluteRep, 1]]) + , 3 + , Multiple $ + Bound Nothing (Just $ Spatial (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 + where + check ((ixs, spec), n) = + it ("("++show n++")") $ + sort mdl `shouldBe` sort ixs + where + mdl = toList . fromExact . fromMult . model' $ spec + model' = flip model $ length . head $ ixs 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 + where + check ((ixs, dims, spec), n) = + it ("("++show n++")") $ mdl `shouldBe` fmap sort <$> ixs + where + mdl = + let ?globalDimensionality = dims + in fmap (sort . toList) <$> mkModel spec diff --git a/tests/Camfort/Specification/Stencils/example2.f b/tests/Camfort/Specification/Stencils/example2.f new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Stencils/example2.f @@ -0,0 +1,45 @@ + program example2 + implicit none + + integer i, j, imax, jmax + parameter (imax = 3, jmax = 3) + real a(0:imax,0:jmax), b(0:imax,0:jmax), c, x + +c= region :: r1 = centered(depth=1, dim=1) + +c some kind of setup + do 1 i = 0, imax + do 2 j = 0, jmax + a(i,j) = i+j + 2 continue + 1 continue + +c compute mean + do 3 i = 1, (imax-1) + do 4 j = 1, (jmax-1) + if (.true.) then +c= region :: r2 = centered(depth=1, dim=2) + x = a(i-1,j) + a(i,j) + a(i+1,j) + abs(0) +c= stencil readOnce, (reflexive(dim=1))*r2 + (reflexive(dim=2))*r1 :: a + b(i,j) = (x + a(i,j-1) + a(i,j+1)) / 5.0 +c No specification should be inferred here + b(0,0) = a(i, j) + end if + 4 continue + x = a(i,0) + y = a(i-1,0) +c= stencil readOnce, backward(depth=1, dim=1) :: a + b(i,0) = (x + y)/2.0 + 3 continue + + b(i,j) = a(i,j) + + do i=1, imax + do j=1, jmx + x = a(1,j+1) + a(1,j-1) + a(i,j) = a(i,1) + a(i+1 ,1) + a(i-1,1) + a(1,j) + x + a(i,j) = a(i,j) + a(1,1) + end do + end do + + end diff --git a/tests/Camfort/Specification/Stencils/example3.f b/tests/Camfort/Specification/Stencils/example3.f new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Stencils/example3.f @@ -0,0 +1,31 @@ + program example3 + implicit none + + integer i, x, y, imax, xmax, ymax + parameter (imax = 3, jmax = 3) + + real a(0:imax,0:jmax), b(0:imax,0:jmax), c(0:imax), d(0:imax), acc + + do i=1,imax + do x=1,xmax + do y=1,ymax + acc = acc + a(x,y,i) + end do + end do + 1 b(1,i) = acc + end do + + do i=1,imax +c Label 1 should get same spec as this line + b(1,i) = a(:,:,i) + end do + + c(:) = d(:) + c(:) = a(0,:) + +c No spec here + do i=1,imax + c(i) = d(:) + end do + + end diff --git a/tests/Camfort/Specification/Stencils/example4.f b/tests/Camfort/Specification/Stencils/example4.f new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Stencils/example4.f @@ -0,0 +1,8 @@ + program example4 + logical BAR = .true. + integer X(0:5) + integer J + do J=1, 10 + IF (BAR) X(J) = X(J)+1 + end do + end diff --git a/tests/Camfort/Specification/StencilsSpec.hs b/tests/Camfort/Specification/StencilsSpec.hs --- a/tests/Camfort/Specification/StencilsSpec.hs +++ b/tests/Camfort/Specification/StencilsSpec.hs @@ -12,6 +12,7 @@ import Camfort.Functionality import Camfort.Helpers.Vec +import Camfort.Input import Camfort.Specification.Stencils import Camfort.Specification.Stencils.Synthesis import Camfort.Specification.Stencils.Model @@ -93,7 +94,7 @@ 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))]) + [(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 @@ -123,35 +124,36 @@ describe "Example stencil inferences" $ do it "five point stencil 2D" $ - (inferFromIndices $ VL fivepoint) + inferFromIndices (VL fivepoint) `shouldBe` - (exactSp $ Spatial Linear + (Specification $ Single $ Exact $ Spatial (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) + inferFromIndices (VL sevenpoint) `shouldBe` - (exactSp $ Spatial Linear + (Specification $ Single $ Exact $ Spatial (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) + inferFromIndices (VL fivepointErr) `shouldBe` - (exactSp $ Spatial Linear + (Specification $ Single $ Exact $ Spatial (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) + inferFromIndices (VL centeredFwd) `shouldBe` - (exactSp $ Spatial Linear (Sum [ Product [ Forward 1 1 True - , Centered 1 2 True] ])) + (Specification $ Single $ Exact $ Spatial + (Sum [ Product [ Forward 1 1 True + , Centered 1 2 True] ])) describe "2D stencil verification" $ mapM_ (test2DSpecVariation (Neighbour "i" 0) (Neighbour "j" 0)) variations @@ -167,77 +169,77 @@ "extracting offsets from indexing expressions; and vice versa") $ it "isomorphism" $ property prop_extract_synth_inverse - describe ("Inconsistent induction variable usage tests") $ do + 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 + indicesToSpec' ["i", "j"] + [Neighbour "i" 0, Neighbour "j" 0] + [[offsetToIx "i" 1, offsetToIx "j" 1], + [offsetToIx "i" 0, offsetToIx "j" 0]] + `shouldBe` (Just $ Specification $ Single $ Exact + (Spatial (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"] + 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 + [offsetToIx "i" 0, offsetToIx "j" 0]] + `shouldBe` (Just $ Specification $ Single $ Exact + (Spatial (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"] + 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 + [offsetToIx "j" 0, offsetToIx "i" 0]] + `shouldBe` (Just $ Specification $ Single $ Exact + (Spatial (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"] + 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 + [offsetToIx "j" absoluteRep, offsetToIx "i" 0]] + `shouldBe` (Just $ Specification $ Single $ Exact + (Spatial (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"] + indicesToSpec' ["i", "j"] [Neighbour "i" 0] - [[offsetToIx "i" 0, offsetToIx "i" 1]]) - `shouldBe` (Just $ Specification $ Left $ Exact - (Spatial Linear + [[offsetToIx "i" 0, offsetToIx "i" 1]] + `shouldBe` (Just $ Specification $ Single $ Exact + (Spatial (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"] + indicesToSpec' ["i", "j"] [Neighbour "i" 0] - [[offsetToIx "i" 0], [offsetToIx "i" absoluteRep]]) - `shouldBe` (Just $ Specification $ Left $ Exact - (Spatial Linear + [[offsetToIx "i" 0], [offsetToIx "i" absoluteRep]] + `shouldBe` (Just $ Specification $ Single $ Exact + (Spatial (Sum [Product [Centered 0 1 True]]))) it "inconsistent (1) RHS" $ - (indicesToSpec' ["i", "j"] + indicesToSpec' ["i", "j"] [Neighbour "i" 0, Neighbour "j" 0] [[offsetToIx "i" 1, offsetToIx "j" 1], - [offsetToIx "j" 0, offsetToIx "i" 0]]) + [offsetToIx "j" 0, offsetToIx "i" 0]] `shouldBe` Nothing it "inconsistent (2) RHS to LHS" $ - (indicesToSpec' ["i", "j"] + indicesToSpec' ["i", "j"] [Neighbour "i" 0] [[offsetToIx "i" 1, offsetToIx "j" 1], - [offsetToIx "j" 0, offsetToIx "i" 0]]) + [offsetToIx "j" 0, offsetToIx "i" 0]] `shouldBe` Nothing ------------------------- @@ -245,52 +247,40 @@ ------------------------- let file = "tests/Camfort/Specification/Stencils/example2.f" - program <- runIO $ readForparseSrcDir file [] + program <- runIO $ readParseSrcDir file [] describe "integration test on inference for example2.f" $ do it "stencil infer" $ - (fst $ callAndSummarise (infer AssignMode) program) + 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)) \ + \(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)) \ + \(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" + \(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) + 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." + \(23:1)-(23:86)\tCorrect.\n(31:1)-(31:56)\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" + program <- runIO $ readParseSrcDir file [] let file = "tests/Camfort/Specification/Stencils/example4.f" - program <- runIO $ readForparseSrcDir file [] + program <- runIO $ readParseSrcDir file [] - describe "integration test on inference for example4.f" $ do + describe "integration test on inference for example4.f" $ it "stencil infer" $ - (fst $ callAndSummarise (infer AssignMode) program) + fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` "\ntests/Camfort/Specification/Stencils/example4.f\n\ - \((6,8),(6,33)) \tstencil (reflexive(dim=1)) :: x" + \(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 @@ -348,109 +338,107 @@ return $ Cons x xs test2DSpecVariation a b (input, expectation) = - it ("format=" ++ show input) $ do - + it ("format=" ++ show input) $ -- Test inference - (indicesToSpec' ["i", "j"] - [a, b] - (map fromFormatToIx input)) + indicesToSpec' ["i", "j"] [a, b] (map fromFormatToIx input) `shouldBe` Just expectedSpec where - expectedSpec = Specification . Left $ expectation + expectedSpec = Specification expectation fromFormatToIx [ri,rj] = [ offsetToIx "i" ri, offsetToIx "j" rj ] -indicesToSpec' ivs lhs = fst . runWriter . (indicesToSpec ivmap "a" lhs) +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]]) + , Single $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (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]]) + , Multiple $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (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]]) + , Multiple $ Exact $ Spatial (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]]) + , Multiple $ Exact $ Spatial (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] ] + , Single $ Exact $ Spatial $ 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]]))) + , Single $ Bound (Just (Spatial (Sum [ Product [ Forward 1 1 True ] ]))) + (Just (Spatial (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]]) + , Single $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (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]]) + , Multiple $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (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]])))) + , Single $ Bound (Just (Spatial (Sum [Product [ Centered 0 2 True ]]))) + (Just (Spatial (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]]) + , Single $ Exact $ Spatial (Sum [Product [Centered 1 2 True]]) ) ] test3DSpecVariation (input, expectation) = - it ("format=" ++ show input) $ do - + it ("format=" ++ show input) $ -- Test inference - (indicesToSpec' ["i", "j", "k"] - [Neighbour "i" 0, Neighbour "j" 0, Neighbour "k" 0] - (map fromFormatToIx input)) + indicesToSpec' ["i", "j", "k"] + [Neighbour "i" 0, Neighbour "j" 0, Neighbour "k" 0] + (map fromFormatToIx input) `shouldBe` Just expectedSpec where - expectedSpec = Specification . Left $ expectation + expectedSpec = Specification 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]]) + , Single $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (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]]) + , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]]) ) ] diff --git a/tests/Camfort/Specification/Units/ex1.f90 b/tests/Camfort/Specification/Units/ex1.f90 new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Units/ex1.f90 @@ -0,0 +1,29 @@ +program energy + != unit :: speed = m/s + + != unit (m / s** (2)) :: gravity + != unit (m) :: height + != unit (kg) :: mass + real, parameter :: mass = 3.00, gravity = 9.81, height = 4.20 + != unit (kg m** (2) / s** (2)) :: potential_energy + real :: potential_energy + + != unit (1) :: half + != unit (speed) :: velocity + real, parameter :: half = 0.5, velocity = 4.00 + != unit (kg m** (2) / s** (2)) :: kinetic_energy + != unit (kg m** (2) / s** (2)) :: total_energy + real :: kinetic_energy, total_energy + + potential_energy = mass * gravity * height + kinetic_energy = half * mass * square(velocity) + + total_energy = potential_energy + kinetic_energy + + contains + + real function square(x) + real x + square = x * x + end function square +end program energy diff --git a/tests/Camfort/Specification/Units/ex2.f90 b/tests/Camfort/Specification/Units/ex2.f90 new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Units/ex2.f90 @@ -0,0 +1,11 @@ +program energy + + != unit (m) :: height + != unit (kg) :: mass + real, parameter :: mass = 3.00, gravity = .81, height = 4.20 + + != unit (kg m** (2) / s** (2)) :: potential_energy + real :: potential_energy + + potential_energy = mass * gravity * height +end program energy diff --git a/tests/Camfort/Specification/Units/ex3.f90 b/tests/Camfort/Specification/Units/ex3.f90 new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Units/ex3.f90 @@ -0,0 +1,14 @@ +program energy + + != unit (m) :: height + != unit (kg) :: mass + real, parameter :: mass = 3.00, gravity = .81, height = 4.20 + + integer :: i = 0 + integer :: j = i + + != unit (kg m**2 / s**2) :: potential_energy + real :: potential_energy + + potential_energy = mass * gravity * height +end program energy diff --git a/tests/Camfort/Specification/Units/param.f90 b/tests/Camfort/Specification/Units/param.f90 new file mode 100644 --- /dev/null +++ b/tests/Camfort/Specification/Units/param.f90 @@ -0,0 +1,10 @@ + program param + implicit none + != unit(m) :: x, y + real, parameter :: x = 4, y = 5 + != unit(s) :: t + real, parameter :: t = 2 + real :: v1, v2 + v1 = x / t + v2 = y / t + end program diff --git a/tests/Camfort/Specification/UnitsSpec.hs b/tests/Camfort/Specification/UnitsSpec.hs --- a/tests/Camfort/Specification/UnitsSpec.hs +++ b/tests/Camfort/Specification/UnitsSpec.hs @@ -3,16 +3,24 @@ import qualified Data.ByteString.Char8 as B +import Language.Fortran.Parser.Any +import qualified Language.Fortran.Analysis as FA +import qualified Language.Fortran.Analysis.Renaming as FAR import Camfort.Input import Camfort.Functionality import Camfort.Output +import Camfort.Analysis.Annotations import Camfort.Specification.Units +import Camfort.Specification.Units.Monad +import Camfort.Specification.Units.InferenceFrontend import Camfort.Specification.Units.InferenceBackend import Camfort.Specification.Units.Environment import Data.List import Data.Maybe +import Data.Either import qualified Data.Array as A import qualified Numeric.LinearAlgebra as H +import qualified Data.Map.Strict as M import Numeric.LinearAlgebra ( atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols, takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks, @@ -23,8 +31,56 @@ import Test.QuickCheck import Test.Hspec.QuickCheck +runFrontendInit litMode pf = usConstraints state + where + pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf + uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode } + (_, state, logs) = runUnitSolver uOpts pf' initInference + +runUnits litMode pf m = (r, usConstraints state) + where + pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf + uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode } + (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m + +runUnits' litMode pf m = (state, logs) + where + pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf + uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = True, uoLiterals = litMode } + (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m + +runUnitsRenamed' litMode pf m = (state, logs) + where + pf' = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf + uOpts = unitOpts0 { uoNameMap = FAR.extractNameMap pf', uoDebug = True, uoLiterals = litMode } + (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m + spec :: Spec spec = do + describe "Unit Inference Frontend" $ do + describe "Literal Mode" $ do + it "litTest1 Mixed" $ do + head (fromJust (head (rights [fst (runUnits LitMixed litTest1 runInconsistentConstraints)]))) `shouldSatisfy` + conParamEq (ConEq (UnitName "a") (UnitMul (UnitName "a") (UnitVar ("j", "j")))) + it "litTest1 Poly" $ do + head (fromJust (head (rights [fst (runUnits LitPoly litTest1 runInconsistentConstraints)]))) `shouldSatisfy` + conParamEq (ConEq (UnitName "a") (UnitMul (UnitName "a") (UnitVar ("j", "j")))) + it "litTest1 Unitless" $ do + head (fromJust (head (rights [fst (runUnits LitUnitless litTest1 runInconsistentConstraints)]))) `shouldSatisfy` + conParamEq (ConEq (UnitName "a") (UnitVar ("k", "k"))) + describe "Polymorphic functions" $ do + it "squarePoly1" $ do + show (sort (head (rights [fst (runUnits LitMixed squarePoly1 runInferVariables)]))) `shouldBe` + show (sort [(("a", "a"),UnitName "m"),(("b", "b"), UnitName "s"),(("x", "x"),UnitPow (UnitName "m") 2.0),(("y", "y"),UnitPow (UnitName "s") 2.0)]) + describe "Recursive functions" $ do + it "Recursive Addition is OK" $ do + show (sort (head (rights [fst (runUnits LitMixed recursive1 runInferVariables)]))) `shouldBe` + show (sort [(("y", "y"),UnitName "m"),(("z", "z"), UnitName "m")]) + describe "Recursive functions" $ do + it "Recursive Multiplication is not OK" $ do + head (fromJust (head (rights [fst (runUnits LitMixed recursive2 runInconsistentConstraints)]))) `shouldSatisfy` + conParamEq (ConEq (UnitParamPosAbs ("recur", 0)) (UnitParamPosAbs ("recur", 2))) + describe "Unit Inference Backend" $ do describe "Flatten constraints" $ do it "testCons1" $ do @@ -47,9 +103,9 @@ it "testCons2" $ do criticalVariables testCons2 `shouldSatisfy` null it "testCons3" $ do - criticalVariables testCons3 `shouldBe` [UnitVar "c",UnitVar "e"] + criticalVariables testCons3 `shouldBe` [UnitVar ("c", "c"), UnitVar ("e", "e")] it "testCons4" $ do - criticalVariables testCons4 `shouldBe` [UnitVar "simple2_a22"] + criticalVariables testCons4 `shouldBe` [UnitVar ("simple2_a22", "simple2_a22")] it "testCons5" $ do criticalVariables testCons5 `shouldSatisfy` null describe "Infer Variables" $ do @@ -59,16 +115,16 @@ -------------------------------------------------- testCons1 = [ ConEq (UnitName "kg") (UnitName "m") - , ConEq (UnitVar "x") (UnitName "m") - , ConEq (UnitVar "y") (UnitName "kg")] + , ConEq (UnitVar ("x", "x")) (UnitName "m") + , ConEq (UnitVar ("y", "y")) (UnitName "kg")] testCons1_flattened = [([UnitPow (UnitName "kg") 1.0],[UnitPow (UnitName "m") 1.0]) - ,([UnitPow (UnitVar "x") 1.0],[UnitPow (UnitName "m") 1.0]) - ,([UnitPow (UnitVar "y") 1.0],[UnitPow (UnitName "kg") 1.0])] + ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0]) + ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])] 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])] + ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0]) + ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])] -------------------------------------------------- @@ -76,11 +132,11 @@ ,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 (UnitVar ("simple1_a5", "simple1_a5")) (UnitAlias "accel") + ,ConEq (UnitVar ("simple1_t4", "simple1_t4")) (UnitName "s") + ,ConEq (UnitVar ("simple1_v3", "simple1_v3")) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) + ,ConEq (UnitVar ("simple1_x1", "simple1_x1")) (UnitName "m") + ,ConEq (UnitVar ("simple1_y2", "simple1_y2")) (UnitName "m") ,ConEq (UnitParamPosUse ("simple1_sqr6",0,0)) (UnitParamPosUse ("simple1_mul7",0,1)) ,ConEq (UnitParamPosUse ("simple1_sqr6",1,0)) (UnitParamPosUse ("simple1_mul7",1,1)) ,ConEq (UnitParamPosUse ("simple1_sqr6",1,0)) (UnitParamPosUse ("simple1_mul7",2,1)) @@ -91,37 +147,107 @@ ,([],[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 (UnitVar ("simple1_a5", "simple1_a5")) 1.0,UnitPow (UnitAlias "accel") (-1.0)],[]) + ,([UnitPow (UnitVar ("simple1_t4", "simple1_t4")) 1.0],[UnitPow (UnitName "s") 1.0]) + ,([UnitPow (UnitVar ("simple1_v3", "simple1_v3")) 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0)]) + ,([UnitPow (UnitVar ("simple1_x1", "simple1_x1")) 1.0],[UnitPow (UnitName "m") 1.0]) + ,([UnitPow (UnitVar ("simple1_y2", "simple1_y2")) 1.0],[UnitPow (UnitName "m") 1.0]) ,([UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",0,1)) (-1.0)],[]) ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",1,1)) (-1.0)],[]) ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",2,1)) (-1.0)],[]) ,([UnitPow (UnitParamPosUse ("simple1_mul7",0,1)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",1,1)) (-1.0),UnitPow (UnitParamPosUse ("simple1_mul7",2,1)) (-1.0)],[]) ,([UnitPow (UnitAlias "accel") 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-2.0)])] -testCons3 = [ ConEq (UnitVar "a") (UnitVar "e") - , ConEq (UnitVar "a") (UnitMul (UnitVar "b") (UnitMul (UnitVar "c") (UnitVar "d"))) - , ConEq (UnitVar "d") (UnitName "m") ] +testCons3 = [ ConEq (UnitVar ("a", "a")) (UnitVar ("e", "e")) + , ConEq (UnitVar ("a", "a")) (UnitMul (UnitVar ("b", "b")) (UnitMul (UnitVar ("c", "c")) (UnitVar ("d", "d")))) + , ConEq (UnitVar ("d", "d")) (UnitName "m") ] -testCons3_shifted = [([UnitPow (UnitVar "a") 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])] +testCons3_shifted = [([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("e", "e")) (-1.0)],[]) + ,([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("b", "b")) (-1.0),UnitPow (UnitVar ("c", "c")) (-1.0),UnitPow (UnitVar ("d", "d")) (-1.0)],[]) + ,([UnitPow (UnitVar ("d", "d")) 1.0],[UnitPow (UnitName "m") 1.0])] -testCons4 = [ConEq (UnitVar "simple2_a11") (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") +testCons4 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse ("simple2_sqr3",0,0)) + ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitParamPosUse ("simple2_sqr3",1,0)) + ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11")) + ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitVar ("simple2_a22", "simple2_a22")) ,ConEq (UnitParamPosUse ("simple2_sqr3",0,0)) (UnitMul (UnitParamPosUse ("simple2_sqr3",1,0)) (UnitParamPosUse ("simple2_sqr3",1,0)))] -testCons5 = [ConEq (UnitVar "simple2_a11") (UnitParamPosUse ("simple2_sqr3",0,0)) +testCons5 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse ("simple2_sqr3",0,0)) ,ConEq (UnitAlias "accel") (UnitParamPosUse ("simple2_sqr3",1,0)) - ,ConEq (UnitVar "simple2_a11") (UnitVar "simple2_a11") - ,ConEq (UnitVar "simple2_a22") (UnitAlias "accel") + ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11")) + ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitAlias "accel") ,ConEq (UnitParamPosUse ("simple2_sqr3",0,0)) (UnitMul (UnitParamPosUse ("simple2_sqr3",1,0)) (UnitParamPosUse ("simple2_sqr3",1,0))) ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))] -testCons5_infer = [("simple2_a11",UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0))) - ,("simple2_a22",UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))] +testCons5_infer = [(("simple2_a11", "simple2_a11"),UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0))) + ,(("simple2_a22", "simple2_a22"),UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))] + +-------------------------------------------------- + +litTest1 = flip fortranParser "litTest1.f90" . B.pack $ unlines + [ "program main" + , " != unit(a) :: x" + , " real :: x, j, k" + , "" + , " j = 1 + 1" + , " k = j * j" + , " x = x + k" + , " x = x * j ! inconsistent" + , "end program main" ] + +squarePoly1 = flip fortranParser "squarePoly1.f90" . B.pack $ unlines + [ "! Demonstrates parametric polymorphism through functions-calling-functions." + , "program squarePoly" + , " implicit none" + , " real :: x" + , " real :: y" + , " != unit(m) :: a" + , " real :: a" + , " != unit(s) :: b" + , " real :: b" + , " x = squareP(a)" + , " y = squareP(b)" + , " contains" + , " real function square(n)" + , " real :: n" + , " square = n * n" + , " end function" + , " real function squareP(m)" + , " real :: m" + , " squareP = square(m)" + , " end function" + , "end program" ] + +recursive1 = flip fortranParser "recursive1.f90" . B.pack $ unlines + [ "program main" + , " != unit(m) :: y" + , " integer :: x = 5, y = 2, z" + , " z = recur(x,y)" + , " print *, y" + , "contains" + , " real recursive function recur(n, b) result(r)" + , " integer :: n, b" + , " if (n .EQ. 0) then" + , " r = b" + , " else" + , " r = b + recur(n - 1, b)" + , " end if" + , " end function recur" + , "end program main" ] + +recursive2 = flip fortranParser "recursive2.f90" . B.pack $ unlines + [ "program main" + , " != unit(m) :: y" + , " integer :: x = 5, y = 2, z" + , " z = recur(x,y)" + , " print *, y" + , "contains" + , " real recursive function recur(n, b) result(r)" + , " integer :: n, b" + , " if (n .EQ. 0) then" + , " r = b" + , " else" + , " r = b * recur(n - 1, b) ! inconsistent" + , " end if" + , " end function recur" + , "end program main" ] diff --git a/tests/Camfort/Transformation/CommonSpec.hs b/tests/Camfort/Transformation/CommonSpec.hs --- a/tests/Camfort/Transformation/CommonSpec.hs +++ b/tests/Camfort/Transformation/CommonSpec.hs @@ -14,29 +14,32 @@ data Example = Example FilePath FilePath examples = - [ Example "toArgs.f90" "toArgs.expected.f90" - , Example "toArgs2.f90" "toArgs2.expected.f90" - ] + [ Example "common.f90" "common.expected.f90" ] -readExpected :: FilePath -> IO String -readExpected filename = do +readSample :: FilePath -> IO String +readSample 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 +removeSample filename = do + let path = samplesBase filename + removeFile path spec :: Spec spec = - describe "Issue #9" $ - context "lalala" $ do - expected <- runIO $ readExpected "toArgs.expected.f90" - actual <- runIO $ readActual "toArgs.f90" + describe "Common block integration test" $ + context "common.f90 into common.expect.f90 and foo.f90" $ do + expected <- runIO $ readSample "common.expected.f90" + expectedMod <- runIO $ readSample "cmn.expected.f90" + + let outFile = samplesBase "common.f90.out" + runIO $ common (samplesBase "common.f90") [] outFile () + + actual <- runIO $ readSample "common.f90.out" + actualMod <- runIO $ readSample "cmn.f90" + runIO $ removeSample "common.f90.out" + runIO $ removeSample "cmn.f90" it "it eliminates common statement" $ - actual `shouldBe` expected + actual `shouldBe` expected + it "it produces a correct module file" $ + actualMod `shouldBe` expectedMod diff --git a/tests/Camfort/Transformation/EquivalenceElimSpec.hs b/tests/Camfort/Transformation/EquivalenceElimSpec.hs --- a/tests/Camfort/Transformation/EquivalenceElimSpec.hs +++ b/tests/Camfort/Transformation/EquivalenceElimSpec.hs @@ -54,15 +54,13 @@ it "it eliminates equivalence statements" $ actual `shouldBe` expected ---- - report <- runIO $ doRefactor (mapM refactorEquivalences) (samplesBase "equiv.f90") [] "equiv.expected.f90" + let rfun = mapM refactorEquivalences + let infile = samplesBase "equiv.f90" + report <- runIO $ doRefactor rfun infile [] "equiv.expected.f90" it "report is as expected" $ report `shouldBe` expectedReport - expectedReport = - "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" + "6:3: removed equivalence \n\ + \14:3: added copy due to refactored equivalence\n\ + \15:3: added copy due to refactored equivalence\n" diff --git a/tests/Camfort/Transformation/samples/common.f90 b/tests/Camfort/Transformation/samples/common.f90 new file mode 100644 --- /dev/null +++ b/tests/Camfort/Transformation/samples/common.f90 @@ -0,0 +1,10 @@ +subroutine test(a,b, c) + +integer :: c1, c2, c3 +COMMON /cmn/ c1, c2, c3 + +real :: a, b, c + +print *, a, b, c + +end subroutine test diff --git a/tests/Camfort/Transformation/samples/equiv.f90 b/tests/Camfort/Transformation/samples/equiv.f90 new file mode 100644 --- /dev/null +++ b/tests/Camfort/Transformation/samples/equiv.f90 @@ -0,0 +1,20 @@ +program wrt + implicit none + integer :: x = 97 + character :: y + character :: z(20) + equivalence (x, y, z(2)) + + z(1) = "c" + + write (*,'(i8,A)') x, y + + + write (*,'(i8,A,A,A)') x, y, z(1), z(2) + + x = 97 + 98 * (2**8) + + write (*,'(i8,A,A,A,A)') x, y, z(1), z(2), z(3) + + +end program wrt