diff --git a/camfort.cabal b/camfort.cabal --- a/camfort.cabal +++ b/camfort.cabal @@ -1,5 +1,5 @@ name: camfort -version: 0.900 +version: 0.901 synopsis: CamFort - Cambridge Fortran infrastructure description: CamFort is a tool for the analysis, transformation, verification of Fortran code. @@ -17,9 +17,9 @@ 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 +extra-source-files: tests/fixtures/Specification/Stencils/*.f + tests/fixtures/Specification/Units/*.f90 + tests/fixtures/Transformation/*.f90 source-repository head type: git @@ -76,7 +76,7 @@ transformers >= 0.4, GenericPretty >= 1.2, QuickCheck >= 2.8, - fortran-src >= 0.1.0.3, + fortran-src >= 0.1.0.4, filepath, fgl >= 5.5, bytestring >= 0.10 @@ -131,7 +131,7 @@ transformers >= 0.4, vector >= 0.1, GenericPretty >= 1.2, - fortran-src >= 0.1.0.3, + fortran-src >= 0.1.0.4, filepath, bytestring >= 0.10, fgl >= 5.5 @@ -156,11 +156,12 @@ directory >= 1.2, hspec >= 2.2, QuickCheck >= 2.8, - fortran-src >= 0.1.0.3, + fortran-src >= 0.1.0.4, uniplate >= 1.6.10, mtl >= 2.1, bytestring >= 0.10, array >= 0.4, hmatrix >= 0.15, + text >= 0.11.2.3, camfort default-language: Haskell2010 diff --git a/dist/build/Camfort/Specification/Stencils/Grammar.hs b/dist/build/Camfort/Specification/Stencils/Grammar.hs new file mode 100644 --- /dev/null +++ b/dist/build/Camfort/Specification/Stencils/Grammar.hs @@ -0,0 +1,980 @@ +{-# 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 qualified Data.Text as T + +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 :: ((Depth Int, Dim Int, Bool)) -> (HappyAbsSyn ) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> ((Depth Int, Dim Int, Bool)) +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: ((Dim Int, Bool)) -> (HappyAbsSyn ) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> ((Dim Int, Bool)) +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: ((Depth Int, Bool)) -> (HappyAbsSyn ) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> ((Depth Int, Bool)) +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (Depth Int) -> (HappyAbsSyn ) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (Depth Int) +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Dim Int) -> (HappyAbsSyn ) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Dim Int) +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Bool) -> (HappyAbsSyn ) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Bool) +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: (Spec) -> (HappyAbsSyn ) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> (Spec) +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (Mod) -> (HappyAbsSyn ) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> (Mod) +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: ([Mod]) -> (HappyAbsSyn ) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> ([Mod]) +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (Mod) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (Mod) +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: ([String]) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> ([String]) +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +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# "\x51\x00\x71\x00\x00\x00\x74\x00\x50\x00\xfe\xff\x41\x00\x73\x00\x0c\x00\x79\x00\x08\x00\x00\x00\x70\x00\x00\x00\x00\x00\x6f\x00\x6d\x00\x6c\x00\x00\x00\x0c\x00\x6e\x00\x6b\x00\x25\x00\x35\x00\x35\x00\x35\x00\x69\x00\x41\x00\x00\x00\x47\x00\x0c\x00\x3c\x00\x68\x00\x0c\x00\x0c\x00\x00\x00\x6a\x00\x00\x00\x67\x00\x3c\x00\x66\x00\x65\x00\x3d\x00\x36\x00\x40\x00\x00\x00\x64\x00\x4d\x00\x63\x00\x4c\x00\x00\x00\x0c\x00\x37\x00\x00\x00\x00\x00\x62\x00\x60\x00\x61\x00\x5f\x00\x00\x00\x5e\x00\x5d\x00\x00\x00\x5c\x00\x5a\x00\x00\x00\x56\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x2e\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x59\x00\x53\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x30\x00\x2a\x00\x24\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x57\x00\x00\x00\x4b\x00\x55\x00\x54\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\xff\xff\x3b\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x49\x00\x00\x00\x42\x00\x3e\x00\x00\x00\x34\x00\x06\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"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xe0\xff\xe2\xff\x00\x00\xdf\xff\xde\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\xff\xe1\xff\xe0\xff\x00\x00\xe5\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf7\xff\xfd\xff\xdc\xff\xe6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xfc\xff\xf9\xff\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xff\xea\xff\x00\x00\xf3\xff\xed\xff\x00\x00\xfb\xff\x00\x00\xdd\xff\x00\x00\xef\xff\xee\xff\xeb\xff\xec\xff\xf0\xff\xf1\xff\xe8\xff\xe9\xff\xf8\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x03\x00\x04\x00\x04\x00\x06\x00\x07\x00\x07\x00\x08\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x04\x00\x07\x00\x06\x00\x07\x00\x04\x00\x13\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x02\x00\x13\x00\x02\x00\x06\x00\x07\x00\x13\x00\x07\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x03\x00\x0b\x00\x0c\x00\x06\x00\x07\x00\x08\x00\x03\x00\x00\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x0f\x00\x10\x00\x06\x00\x07\x00\x08\x00\x14\x00\x05\x00\x05\x00\x08\x00\x08\x00\x09\x00\x09\x00\x05\x00\x06\x00\x05\x00\x08\x00\x06\x00\x08\x00\x0f\x00\x10\x00\x08\x00\x09\x00\x08\x00\x0f\x00\x10\x00\x06\x00\x07\x00\x06\x00\x0f\x00\x10\x00\x01\x00\x02\x00\x02\x00\x0d\x00\x02\x00\x02\x00\x0d\x00\x02\x00\x02\x00\x02\x00\x01\x00\x0a\x00\x14\x00\x12\x00\x14\x00\x05\x00\x08\x00\x05\x00\x0e\x00\x15\x00\x09\x00\xff\xff\x09\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\xff\xff\x0e\x00\x08\x00\xff\xff\x02\x00\x0d\x00\x0d\x00\x12\x00\x14\x00\x12\x00\x14\x00\x10\x00\x0d\x00\x03\x00\x12\x00\xff\xff\x13\x00\x13\x00\xff\xff\x13\x00\x13\x00\x11\x00\x11\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x0c\x00\x0d\x00\x3e\x00\x0e\x00\x0f\x00\x3f\x00\x40\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0d\x00\x45\x00\x0e\x00\x0f\x00\x0d\x00\x14\x00\x10\x00\x11\x00\x12\x00\x13\x00\x10\x00\x11\x00\x12\x00\x13\x00\x06\x00\x14\x00\x1b\x00\x39\x00\x3a\x00\x14\x00\x4a\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1c\x00\x1d\x00\x29\x00\x1c\x00\x1d\x00\x2a\x00\x2b\x00\x2c\x00\x30\x00\x04\x00\x02\x00\x2a\x00\x2b\x00\x2c\x00\x31\x00\x22\x00\x23\x00\x2a\x00\x2b\x00\x2c\x00\x33\x00\x2e\x00\x2e\x00\x46\x00\x2f\x00\x30\x00\x30\x00\x3b\x00\x3c\x00\x2e\x00\x3d\x00\x47\x00\x2f\x00\x22\x00\x23\x00\x2f\x00\x30\x00\x48\x00\x22\x00\x23\x00\x0e\x00\x0f\x00\x49\x00\x22\x00\x23\x00\x06\x00\x04\x00\x34\x00\x43\x00\x23\x00\x24\x00\x25\x00\x27\x00\x16\x00\x1f\x00\x02\x00\x1e\x00\x4e\x00\x38\x00\x36\x00\x2e\x00\x2f\x00\x2e\x00\x45\x00\xff\xff\x30\x00\x00\x00\x30\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4d\x00\x29\x00\x00\x00\x04\x00\x27\x00\x27\x00\x39\x00\x37\x00\x43\x00\x42\x00\x23\x00\x16\x00\x0c\x00\x34\x00\x00\x00\x18\x00\x19\x00\x00\x00\x1a\x00\x1b\x00\x21\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (1, 35) [ + (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), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35) + ] + +happy_n_terms = 22 :: Int +happy_n_nonterms = 14 :: 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 happyOut13 happy_x_2 of { happy_var_2 -> + case happyOut17 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 4# 2# happyReduction_4 +happyReduction_4 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (applyAttr Forward happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_5 = happyReduce 4# 2# happyReduction_5 +happyReduction_5 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (applyAttr Backward happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_6 = happyReduce 4# 2# happyReduction_6 +happyReduction_6 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (applyAttr Centered happy_var_3 + ) `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_2 3# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn7 + ((happy_var_1, fst happy_var_2, snd happy_var_2) + )}} + +happyReduce_13 = happySpecReduce_2 3# happyReduction_13 +happyReduction_13 happy_x_2 + happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_2 of { happy_var_2 -> + happyIn7 + ((fst happy_var_2, happy_var_1, snd happy_var_2) + )}} + +happyReduce_14 = happySpecReduce_3 3# happyReduction_14 +happyReduction_14 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut11 happy_x_3 of { happy_var_3 -> + happyIn7 + ((happy_var_2, happy_var_3, happy_var_1) + )}}} + +happyReduce_15 = happySpecReduce_3 3# happyReduction_15 +happyReduction_15 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn7 + ((happy_var_3, happy_var_2, happy_var_1) + )}}} + +happyReduce_16 = happySpecReduce_2 4# happyReduction_16 +happyReduction_16 happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn8 + ((happy_var_2, happy_var_1) + )}} + +happyReduce_17 = happySpecReduce_2 4# happyReduction_17 +happyReduction_17 happy_x_2 + happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_2 of { happy_var_2 -> + happyIn8 + ((happy_var_1, happy_var_2) + )}} + +happyReduce_18 = happySpecReduce_1 4# happyReduction_18 +happyReduction_18 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn8 + ((happy_var_1, True) + )} + +happyReduce_19 = happySpecReduce_2 5# happyReduction_19 +happyReduction_19 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_2 of { happy_var_2 -> + happyIn9 + ((happy_var_1, happy_var_2) + )}} + +happyReduce_20 = happySpecReduce_2 5# happyReduction_20 +happyReduction_20 happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn9 + ((happy_var_2, happy_var_1) + )}} + +happyReduce_21 = happySpecReduce_1 5# happyReduction_21 +happyReduction_21 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn9 + ((happy_var_1, True) + )} + +happyReduce_22 = happySpecReduce_3 6# happyReduction_22 +happyReduction_22 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_3 of { (TNum happy_var_3) -> + happyIn10 + (Depth $ read happy_var_3 + )} + +happyReduce_23 = happySpecReduce_3 7# happyReduction_23 +happyReduction_23 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_3 of { (TNum happy_var_3) -> + happyIn11 + (Dim $ read happy_var_3 + )} + +happyReduce_24 = happySpecReduce_1 8# happyReduction_24 +happyReduction_24 happy_x_1 + = happyIn12 + (False + ) + +happyReduce_25 = happySpecReduce_3 9# happyReduction_25 +happyReduction_25 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_2 of { happy_var_2 -> + case happyOut6 happy_x_3 of { happy_var_3 -> + happyIn13 + (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3 + )}}} + +happyReduce_26 = happySpecReduce_2 9# happyReduction_26 +happyReduction_26 happy_x_2 + happy_x_1 + = case happyOut14 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn13 + (Spatial [happy_var_1] happy_var_2 + )}} + +happyReduce_27 = happySpecReduce_2 9# happyReduction_27 +happyReduction_27 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn13 + (Spatial [happy_var_1] happy_var_2 + )}} + +happyReduce_28 = happySpecReduce_1 9# happyReduction_28 +happyReduction_28 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn13 + (Spatial [] happy_var_1 + )} + +happyReduce_29 = happySpecReduce_1 10# happyReduction_29 +happyReduction_29 happy_x_1 + = happyIn14 + (ReadOnce + ) + +happyReduce_30 = happySpecReduce_2 11# happyReduction_30 +happyReduction_30 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn15 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_31 = happySpecReduce_1 11# happyReduction_31 +happyReduction_31 happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + happyIn15 + ([happy_var_1] + )} + +happyReduce_32 = happySpecReduce_1 12# happyReduction_32 +happyReduction_32 happy_x_1 + = happyIn16 + (AtMost + ) + +happyReduce_33 = happySpecReduce_1 12# happyReduction_33 +happyReduction_33 happy_x_1 + = happyIn16 + (AtLeast + ) + +happyReduce_34 = happySpecReduce_2 13# happyReduction_34 +happyReduction_34 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TId happy_var_1) -> + case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn17 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_35 = happySpecReduce_1 13# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOutTok happy_x_1 of { (TId happy_var_1) -> + happyIn17 + ([happy_var_1] + )} + +happyNewToken action sts stk [] = + happyDoAction 21# 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 "dim" -> cont 8#; + TId "depth" -> cont 9#; + TId "forward" -> cont 10#; + TId "backward" -> cont 11#; + TId "centered" -> cont 12#; + TId happy_dollar_dollar -> cont 13#; + TNum happy_dollar_dollar -> cont 14#; + TPlus -> cont 15#; + TStar -> cont 16#; + TDoubleColon -> cont 17#; + TEqual -> cont 18#; + TLParen -> cont 19#; + TRParen -> cont 20#; + _ -> happyError' (tk:tks) + } + +happyError_ 21# 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 + + +newtype Depth a = Depth a +newtype Dim a = Dim a + +applyAttr :: (Int -> Int -> Bool -> Region) + -> (Depth Int, Dim Int, Bool) + -> Region +applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl + +data Specification + = RegionDec String Region + | SpecDec Spec [String] + deriving (Show, Eq, Ord, Typeable, Data) + +data Region + = Forward Int Int Bool + | Backward Int Int Bool + | Centered Int Int Bool + | Or Region Region + | And Region Region + | Var String + deriving (Show, Eq, Ord, Typeable, Data) + +data Spec = Spatial [Mod] Region + deriving (Show, Eq, Ord, Typeable, Data) + +data Mod + = AtLeast + | AtMost + | ReadOnce + deriving (Show, Eq, Ord, Typeable, Data) + +-------------------------------------------------- + +data Token + = TDoubleColon + | TStar + | TPlus + | TEqual + | TComma + | TLParen + | TRParen + | TId String + | TNum String + deriving (Show) + +addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] +addToTokens tok rest = do + tokens <- lexer' rest + return $ tok : tokens + +lexer :: String -> Either AnnotationParseError [ Token ] +lexer input | length (stripLeadingWhiteSpace input) >= 2 = + case stripLeadingWhiteSpace input of + -- Check the leading character is '=' for specification + '=':input' -> testAnnotation input' + '!':input' -> testAnnotation input' + '>':input' -> testAnnotation input' + '<':input' -> testAnnotation input' + _ -> Left NotAnnotation + where + stripLeadingWhiteSpace = T.unpack . T.strip . T.pack + testAnnotation inp = + -- First test to see if the input looks like an actual + -- specification of either a stencil or region + if (inp `hasPrefix` "stencil" || inp `hasPrefix` "region") + then lexer' inp + else Left NotAnnotation + hasPrefix [] str = False + hasPrefix (' ':xs) str = hasPrefix xs str + hasPrefix xs str = isPrefixOf str xs +lexer _ = Left NotAnnotation + + +lexer' :: String -> Either AnnotationParseError [ Token ] +lexer' [] = return [] +lexer' (' ':xs) = lexer' xs +lexer' ('\t':xs) = lexer' xs +lexer' (':':':':xs) = addToTokens TDoubleColon xs +lexer' ('*':xs) = addToTokens TStar xs +lexer' ('+':xs) = addToTokens TPlus xs +lexer' ('=':xs) = addToTokens TEqual xs +-- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead. +lexer' (',':xs) + | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs') + | otherwise = addToTokens TComma xs +lexer' ('(':xs) = addToTokens TLParen xs +lexer' (')':xs) = addToTokens TRParen xs +lexer' (x:xs) + | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_' + | isNumber x = aux TNum isNumber + | otherwise + = failWith $ "Not an indentifier " ++ show x + where + aux f p = (f target :) `fmap` lexer' rest + where (target, rest) = span p (x:xs) +lexer' x + = failWith $ "Not a valid piece of stencil syntax " ++ show x + +-------------------------------------------------- + +-- specParser :: String -> Either AnnotationParseError Specification +specParser :: AnnotationParser Specification +specParser src = do + tokens <- lexer src + parseSpec tokens >>= modValidate + +-- Check whether modifiers are used correctly +modValidate :: Specification -> Either AnnotationParseError Specification +modValidate (SpecDec (Spatial mods r) vars) = + do mods' <- modValidate' $ sort mods + return $ SpecDec (Spatial mods' r) vars + + where modValidate' [] = return $ [] + + modValidate' (AtLeast : AtLeast : xs) + = failWith "Duplicate 'atLeast' modifier; use at most one." + + modValidate' (AtMost : AtMost : xs) + = failWith "Duplicate 'atMost' modifier; use at most one." + + modValidate' (ReadOnce : ReadOnce : xs) + = failWith "Duplicate 'readOnce' modifier; use at most one." + + modValidate' (AtLeast : AtMost : xs) + = failWith $ "Conflicting modifiers: cannot use 'atLeast' and " + ++ "'atMost' together" + + modValidate' (x : xs) + = do xs' <- modValidate' xs + return $ x : xs' +modValidate x = return x + +happyError :: [ Token ] -> Either AnnotationParseError a +happyError t = failWith $ "Could not parse specification at: " ++ show t +{-# 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 new file mode 100644 --- /dev/null +++ b/dist/build/Camfort/Specification/Units/Parser.hs @@ -0,0 +1,766 @@ +{-# 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.Text as T +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 [] = Left NotAnnotation +lexer (c:xs) + | c `elem` ['=', '!', '>', '<'] = + -- First test to see if the input looks like an actual unit specification + if "unit" `isPrefixOf` (T.unpack . T.strip . T.toLower . T.pack $ xs) + then lexer' xs + else Left NotAnnotation + | otherwise = Left NotAnnotation + +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 = failWith $ "Not valid unit syntax at " ++ show (x:xs) ++ "\n" + 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 = failWith $ "Could not parse unit specification at: " ++ show t ++ "\n" +{-# 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 new file mode 100644 --- /dev/null +++ b/dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs @@ -0,0 +1,980 @@ +{-# 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 qualified Data.Text as T + +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 :: ((Depth Int, Dim Int, Bool)) -> (HappyAbsSyn ) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> ((Depth Int, Dim Int, Bool)) +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: ((Dim Int, Bool)) -> (HappyAbsSyn ) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> ((Dim Int, Bool)) +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: ((Depth Int, Bool)) -> (HappyAbsSyn ) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> ((Depth Int, Bool)) +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: (Depth Int) -> (HappyAbsSyn ) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> (Depth Int) +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: (Dim Int) -> (HappyAbsSyn ) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> (Dim Int) +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: (Bool) -> (HappyAbsSyn ) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> (Bool) +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: (Spec) -> (HappyAbsSyn ) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> (Spec) +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (Mod) -> (HappyAbsSyn ) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> (Mod) +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: ([Mod]) -> (HappyAbsSyn ) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> ([Mod]) +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: (Mod) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> (Mod) +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: ([String]) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> ([String]) +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +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# "\x51\x00\x71\x00\x00\x00\x74\x00\x50\x00\xfe\xff\x41\x00\x73\x00\x0c\x00\x79\x00\x08\x00\x00\x00\x70\x00\x00\x00\x00\x00\x6f\x00\x6d\x00\x6c\x00\x00\x00\x0c\x00\x6e\x00\x6b\x00\x25\x00\x35\x00\x35\x00\x35\x00\x69\x00\x41\x00\x00\x00\x47\x00\x0c\x00\x3c\x00\x68\x00\x0c\x00\x0c\x00\x00\x00\x6a\x00\x00\x00\x67\x00\x3c\x00\x66\x00\x65\x00\x3d\x00\x36\x00\x40\x00\x00\x00\x64\x00\x4d\x00\x63\x00\x4c\x00\x00\x00\x0c\x00\x37\x00\x00\x00\x00\x00\x62\x00\x60\x00\x61\x00\x5f\x00\x00\x00\x5e\x00\x5d\x00\x00\x00\x5c\x00\x5a\x00\x00\x00\x56\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x2e\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x59\x00\x53\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x30\x00\x2a\x00\x24\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x57\x00\x00\x00\x4b\x00\x55\x00\x54\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\xff\xff\x3b\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x49\x00\x00\x00\x42\x00\x3e\x00\x00\x00\x34\x00\x06\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"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xe0\xff\xe2\xff\x00\x00\xdf\xff\xde\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\xff\xe1\xff\xe0\xff\x00\x00\xe5\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf7\xff\xfd\xff\xdc\xff\xe6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xfc\xff\xf9\xff\xfa\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xff\xea\xff\x00\x00\xf3\xff\xed\xff\x00\x00\xfb\xff\x00\x00\xdd\xff\x00\x00\xef\xff\xee\xff\xeb\xff\xec\xff\xf0\xff\xf1\xff\xe8\xff\xe9\xff\xf8\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x03\x00\x04\x00\x04\x00\x06\x00\x07\x00\x07\x00\x08\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x04\x00\x07\x00\x06\x00\x07\x00\x04\x00\x13\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x02\x00\x13\x00\x02\x00\x06\x00\x07\x00\x13\x00\x07\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x03\x00\x0b\x00\x0c\x00\x06\x00\x07\x00\x08\x00\x03\x00\x00\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x0f\x00\x10\x00\x06\x00\x07\x00\x08\x00\x14\x00\x05\x00\x05\x00\x08\x00\x08\x00\x09\x00\x09\x00\x05\x00\x06\x00\x05\x00\x08\x00\x06\x00\x08\x00\x0f\x00\x10\x00\x08\x00\x09\x00\x08\x00\x0f\x00\x10\x00\x06\x00\x07\x00\x06\x00\x0f\x00\x10\x00\x01\x00\x02\x00\x02\x00\x0d\x00\x02\x00\x02\x00\x0d\x00\x02\x00\x02\x00\x02\x00\x01\x00\x0a\x00\x14\x00\x12\x00\x14\x00\x05\x00\x08\x00\x05\x00\x0e\x00\x15\x00\x09\x00\xff\xff\x09\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x00\xff\xff\x0e\x00\x08\x00\xff\xff\x02\x00\x0d\x00\x0d\x00\x12\x00\x14\x00\x12\x00\x14\x00\x10\x00\x0d\x00\x03\x00\x12\x00\xff\xff\x13\x00\x13\x00\xff\xff\x13\x00\x13\x00\x11\x00\x11\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x0c\x00\x0d\x00\x3e\x00\x0e\x00\x0f\x00\x3f\x00\x40\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0d\x00\x45\x00\x0e\x00\x0f\x00\x0d\x00\x14\x00\x10\x00\x11\x00\x12\x00\x13\x00\x10\x00\x11\x00\x12\x00\x13\x00\x06\x00\x14\x00\x1b\x00\x39\x00\x3a\x00\x14\x00\x4a\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x1c\x00\x1d\x00\x29\x00\x1c\x00\x1d\x00\x2a\x00\x2b\x00\x2c\x00\x30\x00\x04\x00\x02\x00\x2a\x00\x2b\x00\x2c\x00\x31\x00\x22\x00\x23\x00\x2a\x00\x2b\x00\x2c\x00\x33\x00\x2e\x00\x2e\x00\x46\x00\x2f\x00\x30\x00\x30\x00\x3b\x00\x3c\x00\x2e\x00\x3d\x00\x47\x00\x2f\x00\x22\x00\x23\x00\x2f\x00\x30\x00\x48\x00\x22\x00\x23\x00\x0e\x00\x0f\x00\x49\x00\x22\x00\x23\x00\x06\x00\x04\x00\x34\x00\x43\x00\x23\x00\x24\x00\x25\x00\x27\x00\x16\x00\x1f\x00\x02\x00\x1e\x00\x4e\x00\x38\x00\x36\x00\x2e\x00\x2f\x00\x2e\x00\x45\x00\xff\xff\x30\x00\x00\x00\x30\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4d\x00\x29\x00\x00\x00\x04\x00\x27\x00\x27\x00\x39\x00\x37\x00\x43\x00\x42\x00\x23\x00\x16\x00\x0c\x00\x34\x00\x00\x00\x18\x00\x19\x00\x00\x00\x1a\x00\x1b\x00\x21\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (1, 35) [ + (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), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35) + ] + +happy_n_terms = 22 :: Int +happy_n_nonterms = 14 :: 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 happyOut13 happy_x_2 of { happy_var_2 -> + case happyOut17 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 4# 2# happyReduction_4 +happyReduction_4 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (applyAttr Forward happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_5 = happyReduce 4# 2# happyReduction_5 +happyReduction_5 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (applyAttr Backward happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_6 = happyReduce 4# 2# happyReduction_6 +happyReduction_6 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn6 + (applyAttr Centered happy_var_3 + ) `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_2 3# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn7 + ((happy_var_1, fst happy_var_2, snd happy_var_2) + )}} + +happyReduce_13 = happySpecReduce_2 3# happyReduction_13 +happyReduction_13 happy_x_2 + happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_2 of { happy_var_2 -> + happyIn7 + ((fst happy_var_2, happy_var_1, snd happy_var_2) + )}} + +happyReduce_14 = happySpecReduce_3 3# happyReduction_14 +happyReduction_14 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_2 of { happy_var_2 -> + case happyOut11 happy_x_3 of { happy_var_3 -> + happyIn7 + ((happy_var_2, happy_var_3, happy_var_1) + )}}} + +happyReduce_15 = happySpecReduce_3 3# happyReduction_15 +happyReduction_15 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn7 + ((happy_var_3, happy_var_2, happy_var_1) + )}}} + +happyReduce_16 = happySpecReduce_2 4# happyReduction_16 +happyReduction_16 happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_2 of { happy_var_2 -> + happyIn8 + ((happy_var_2, happy_var_1) + )}} + +happyReduce_17 = happySpecReduce_2 4# happyReduction_17 +happyReduction_17 happy_x_2 + happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_2 of { happy_var_2 -> + happyIn8 + ((happy_var_1, happy_var_2) + )}} + +happyReduce_18 = happySpecReduce_1 4# happyReduction_18 +happyReduction_18 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn8 + ((happy_var_1, True) + )} + +happyReduce_19 = happySpecReduce_2 5# happyReduction_19 +happyReduction_19 happy_x_2 + happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_2 of { happy_var_2 -> + happyIn9 + ((happy_var_1, happy_var_2) + )}} + +happyReduce_20 = happySpecReduce_2 5# happyReduction_20 +happyReduction_20 happy_x_2 + happy_x_1 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn9 + ((happy_var_2, happy_var_1) + )}} + +happyReduce_21 = happySpecReduce_1 5# happyReduction_21 +happyReduction_21 happy_x_1 + = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn9 + ((happy_var_1, True) + )} + +happyReduce_22 = happySpecReduce_3 6# happyReduction_22 +happyReduction_22 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_3 of { (TNum happy_var_3) -> + happyIn10 + (Depth $ read happy_var_3 + )} + +happyReduce_23 = happySpecReduce_3 7# happyReduction_23 +happyReduction_23 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_3 of { (TNum happy_var_3) -> + happyIn11 + (Dim $ read happy_var_3 + )} + +happyReduce_24 = happySpecReduce_1 8# happyReduction_24 +happyReduction_24 happy_x_1 + = happyIn12 + (False + ) + +happyReduce_25 = happySpecReduce_3 9# happyReduction_25 +happyReduction_25 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut14 happy_x_2 of { happy_var_2 -> + case happyOut6 happy_x_3 of { happy_var_3 -> + happyIn13 + (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3 + )}}} + +happyReduce_26 = happySpecReduce_2 9# happyReduction_26 +happyReduction_26 happy_x_2 + happy_x_1 + = case happyOut14 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn13 + (Spatial [happy_var_1] happy_var_2 + )}} + +happyReduce_27 = happySpecReduce_2 9# happyReduction_27 +happyReduction_27 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn13 + (Spatial [happy_var_1] happy_var_2 + )}} + +happyReduce_28 = happySpecReduce_1 9# happyReduction_28 +happyReduction_28 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn13 + (Spatial [] happy_var_1 + )} + +happyReduce_29 = happySpecReduce_1 10# happyReduction_29 +happyReduction_29 happy_x_1 + = happyIn14 + (ReadOnce + ) + +happyReduce_30 = happySpecReduce_2 11# happyReduction_30 +happyReduction_30 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn15 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_31 = happySpecReduce_1 11# happyReduction_31 +happyReduction_31 happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + happyIn15 + ([happy_var_1] + )} + +happyReduce_32 = happySpecReduce_1 12# happyReduction_32 +happyReduction_32 happy_x_1 + = happyIn16 + (AtMost + ) + +happyReduce_33 = happySpecReduce_1 12# happyReduction_33 +happyReduction_33 happy_x_1 + = happyIn16 + (AtLeast + ) + +happyReduce_34 = happySpecReduce_2 13# happyReduction_34 +happyReduction_34 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TId happy_var_1) -> + case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn17 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_35 = happySpecReduce_1 13# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOutTok happy_x_1 of { (TId happy_var_1) -> + happyIn17 + ([happy_var_1] + )} + +happyNewToken action sts stk [] = + happyDoAction 21# 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 "dim" -> cont 8#; + TId "depth" -> cont 9#; + TId "forward" -> cont 10#; + TId "backward" -> cont 11#; + TId "centered" -> cont 12#; + TId happy_dollar_dollar -> cont 13#; + TNum happy_dollar_dollar -> cont 14#; + TPlus -> cont 15#; + TStar -> cont 16#; + TDoubleColon -> cont 17#; + TEqual -> cont 18#; + TLParen -> cont 19#; + TRParen -> cont 20#; + _ -> happyError' (tk:tks) + } + +happyError_ 21# 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 + + +newtype Depth a = Depth a +newtype Dim a = Dim a + +applyAttr :: (Int -> Int -> Bool -> Region) + -> (Depth Int, Dim Int, Bool) + -> Region +applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl + +data Specification + = RegionDec String Region + | SpecDec Spec [String] + deriving (Show, Eq, Ord, Typeable, Data) + +data Region + = Forward Int Int Bool + | Backward Int Int Bool + | Centered Int Int Bool + | Or Region Region + | And Region Region + | Var String + deriving (Show, Eq, Ord, Typeable, Data) + +data Spec = Spatial [Mod] Region + deriving (Show, Eq, Ord, Typeable, Data) + +data Mod + = AtLeast + | AtMost + | ReadOnce + deriving (Show, Eq, Ord, Typeable, Data) + +-------------------------------------------------- + +data Token + = TDoubleColon + | TStar + | TPlus + | TEqual + | TComma + | TLParen + | TRParen + | TId String + | TNum String + deriving (Show) + +addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] +addToTokens tok rest = do + tokens <- lexer' rest + return $ tok : tokens + +lexer :: String -> Either AnnotationParseError [ Token ] +lexer input | length (stripLeadingWhiteSpace input) >= 2 = + case stripLeadingWhiteSpace input of + -- Check the leading character is '=' for specification + '=':input' -> testAnnotation input' + '!':input' -> testAnnotation input' + '>':input' -> testAnnotation input' + '<':input' -> testAnnotation input' + _ -> Left NotAnnotation + where + stripLeadingWhiteSpace = T.unpack . T.strip . T.pack + testAnnotation inp = + -- First test to see if the input looks like an actual + -- specification of either a stencil or region + if (inp `hasPrefix` "stencil" || inp `hasPrefix` "region") + then lexer' inp + else Left NotAnnotation + hasPrefix [] str = False + hasPrefix (' ':xs) str = hasPrefix xs str + hasPrefix xs str = isPrefixOf str xs +lexer _ = Left NotAnnotation + + +lexer' :: String -> Either AnnotationParseError [ Token ] +lexer' [] = return [] +lexer' (' ':xs) = lexer' xs +lexer' ('\t':xs) = lexer' xs +lexer' (':':':':xs) = addToTokens TDoubleColon xs +lexer' ('*':xs) = addToTokens TStar xs +lexer' ('+':xs) = addToTokens TPlus xs +lexer' ('=':xs) = addToTokens TEqual xs +-- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead. +lexer' (',':xs) + | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs') + | otherwise = addToTokens TComma xs +lexer' ('(':xs) = addToTokens TLParen xs +lexer' (')':xs) = addToTokens TRParen xs +lexer' (x:xs) + | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_' + | isNumber x = aux TNum isNumber + | otherwise + = failWith $ "Not an indentifier " ++ show x + where + aux f p = (f target :) `fmap` lexer' rest + where (target, rest) = span p (x:xs) +lexer' x + = failWith $ "Not a valid piece of stencil syntax " ++ show x + +-------------------------------------------------- + +-- specParser :: String -> Either AnnotationParseError Specification +specParser :: AnnotationParser Specification +specParser src = do + tokens <- lexer src + parseSpec tokens >>= modValidate + +-- Check whether modifiers are used correctly +modValidate :: Specification -> Either AnnotationParseError Specification +modValidate (SpecDec (Spatial mods r) vars) = + do mods' <- modValidate' $ sort mods + return $ SpecDec (Spatial mods' r) vars + + where modValidate' [] = return $ [] + + modValidate' (AtLeast : AtLeast : xs) + = failWith "Duplicate 'atLeast' modifier; use at most one." + + modValidate' (AtMost : AtMost : xs) + = failWith "Duplicate 'atMost' modifier; use at most one." + + modValidate' (ReadOnce : ReadOnce : xs) + = failWith "Duplicate 'readOnce' modifier; use at most one." + + modValidate' (AtLeast : AtMost : xs) + = failWith $ "Conflicting modifiers: cannot use 'atLeast' and " + ++ "'atMost' together" + + modValidate' (x : xs) + = do xs' <- modValidate' xs + return $ x : xs' +modValidate x = return x + +happyError :: [ Token ] -> Either AnnotationParseError a +happyError t = failWith $ "Could not parse specification at: " ++ show t +{-# 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 new file mode 100644 --- /dev/null +++ b/dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs @@ -0,0 +1,766 @@ +{-# 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.Text as T +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 [] = Left NotAnnotation +lexer (c:xs) + | c `elem` ['=', '!', '>', '<'] = + -- First test to see if the input looks like an actual unit specification + if "unit" `isPrefixOf` (T.unpack . T.strip . T.toLower . T.pack $ xs) + then lexer' xs + else Left NotAnnotation + | otherwise = Left NotAnnotation + +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 = failWith $ "Not valid unit syntax at " ++ show (x:xs) ++ "\n" + 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 = failWith $ "Could not parse unit specification at: " ++ show t ++ "\n" +{-# 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/Functionality.hs b/src/Camfort/Functionality.hs --- a/src/Camfort/Functionality.hs +++ b/src/Camfort/Functionality.hs @@ -78,8 +78,8 @@ getExcludes = getOption -- * Wrappers on all of the features -ast d excludes f _ = do - xs <- readParseSrcDir (d ++ "/" ++ f) excludes +ast d excludes _ _ = do + xs <- readParseSrcDir d excludes print (map (\(_, _, p) -> p) xs) countVarDecls inSrc excludes _ _ = do diff --git a/src/Camfort/Output.hs b/src/Camfort/Output.hs --- a/src/Camfort/Output.hs +++ b/src/Camfort/Output.hs @@ -144,7 +144,7 @@ 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) + 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) 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 @@ -64,7 +64,7 @@ let gr = FAB.superBBGrGraph sgr -- get map of variable name ==> { defining AST-Block-IDs } let dm = FAD.genDefMap bm - let pprint = map (\(span, spec) -> show span ++ "\t" ++ spec) + let pprint = map (\(span, spec) -> show span ++ " " ++ spec) -- perform reaching definitions analysis let rd = FAD.reachingDefinitions dm gr -- create graph of definition "flows" @@ -144,7 +144,7 @@ Just subs -> do -- Create list of relative indices ivmap <- snd <$> get - -- Do inference + -- Do analysis let realName v = v `fromMaybe` (v `M.lookup` ?nameMap) let lhsN = fromMaybe [] (neighbourIndex ivmap subs) let correctNames = map (first realName) @@ -161,12 +161,14 @@ 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 - ++ "\tbut at " ++ show span' ++ " the code behaves as" - ++ "\n\t \t " - ++ pprintSpecDecls inferred) ] + let sp = replicate 8 ' ' + tell [ (span, + "Not well specified.\n" + ++ sp ++ "Specification is:\n" + ++ sp ++ sp ++ pprintSpecDecls specDecls ++ "\n" + ++ sp ++ "but at " ++ show span' ++ " the code behaves as\n" + ++ sp ++ sp ++ pprintSpecDecls inferred) ] + return b' Nothing -> return b' diff --git a/src/Camfort/Specification/Stencils/Grammar.hs b/src/Camfort/Specification/Stencils/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Camfort/Specification/Stencils/Grammar.hs @@ -0,0 +1,1275 @@ +{-# 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 ((Depth Int, Dim Int, Bool)) + | HappyAbsSyn8 ((Dim Int, Bool)) + | HappyAbsSyn9 ((Depth Int, Bool)) + | HappyAbsSyn10 (Depth Int) + | HappyAbsSyn11 (Dim Int) + | HappyAbsSyn12 (Bool) + | HappyAbsSyn13 (Spec) + | HappyAbsSyn14 (Mod) + | HappyAbsSyn15 ([Mod]) + | HappyAbsSyn17 ([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, + action_77, + action_78, + action_79, + action_80, + action_81, + action_82 :: () => 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, + happyReduce_27, + happyReduce_28, + happyReduce_29, + happyReduce_30, + happyReduce_31, + happyReduce_32, + happyReduce_33, + happyReduce_34, + happyReduce_35, + happyReduce_36, + happyReduce_37 :: () => ({-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 (18) = happyShift action_5 +action_0 (19) = happyShift action_3 +action_0 (4) = happyGoto action_4 +action_0 (5) = happyGoto action_2 +action_0 _ = happyFail + +action_1 (19) = happyShift action_3 +action_1 (5) = happyGoto action_2 +action_1 _ = happyFail + +action_2 _ = happyReduce_1 + +action_3 (36) = happyShift action_21 +action_3 _ = happyFail + +action_4 (40) = happyAccept +action_4 _ = happyFail + +action_5 (20) = happyShift action_11 +action_5 (21) = happyShift action_12 +action_5 (23) = happyShift action_13 +action_5 (24) = happyShift action_14 +action_5 (27) = happyShift action_15 +action_5 (28) = happyShift action_16 +action_5 (29) = happyShift action_17 +action_5 (30) = happyShift action_18 +action_5 (32) = happyShift action_19 +action_5 (38) = happyShift action_20 +action_5 (6) = happyGoto action_6 +action_5 (13) = happyGoto action_7 +action_5 (14) = happyGoto action_8 +action_5 (15) = happyGoto action_9 +action_5 (16) = happyGoto action_10 +action_5 _ = happyFail + +action_6 (34) = happyShift action_35 +action_6 (35) = happyShift action_36 +action_6 _ = happyReduce_30 + +action_7 (36) = happyShift action_34 +action_7 _ = happyFail + +action_8 (21) = happyShift action_12 +action_8 (27) = happyShift action_15 +action_8 (28) = happyShift action_16 +action_8 (29) = happyShift action_17 +action_8 (32) = happyShift action_19 +action_8 (38) = happyShift action_20 +action_8 (6) = happyGoto action_33 +action_8 _ = happyFail + +action_9 (20) = happyShift action_11 +action_9 (14) = happyGoto action_32 +action_9 _ = happyFail + +action_10 (21) = happyShift action_12 +action_10 (23) = happyShift action_13 +action_10 (24) = happyShift action_14 +action_10 (27) = happyShift action_15 +action_10 (28) = happyShift action_16 +action_10 (29) = happyShift action_17 +action_10 (32) = happyShift action_19 +action_10 (38) = happyShift action_20 +action_10 (6) = happyGoto action_29 +action_10 (15) = happyGoto action_30 +action_10 (16) = happyGoto action_31 +action_10 _ = happyReduce_33 + +action_11 _ = happyReduce_31 + +action_12 (38) = happyShift action_28 +action_12 _ = happyFail + +action_13 _ = happyReduce_34 + +action_14 _ = happyReduce_35 + +action_15 (38) = happyShift action_27 +action_15 _ = happyFail + +action_16 (38) = happyShift action_26 +action_16 _ = happyFail + +action_17 (38) = happyShift action_25 +action_17 _ = happyFail + +action_18 (38) = happyShift action_24 +action_18 _ = happyFail + +action_19 _ = happyReduce_11 + +action_20 (21) = happyShift action_12 +action_20 (27) = happyShift action_15 +action_20 (28) = happyShift action_16 +action_20 (29) = happyShift action_17 +action_20 (32) = happyShift action_19 +action_20 (38) = happyShift action_20 +action_20 (6) = happyGoto action_23 +action_20 _ = happyFail + +action_21 (32) = happyShift action_22 +action_21 _ = happyFail + +action_22 (37) = happyShift action_54 +action_22 _ = happyFail + +action_23 (34) = happyShift action_35 +action_23 (35) = happyShift action_36 +action_23 (39) = happyShift action_53 +action_23 _ = happyFail + +action_24 (32) = happyShift action_40 +action_24 (17) = happyGoto action_52 +action_24 _ = happyFail + +action_25 (22) = happyShift action_47 +action_25 (25) = happyShift action_48 +action_25 (26) = happyShift action_49 +action_25 (7) = happyGoto action_51 +action_25 (10) = happyGoto action_44 +action_25 (11) = happyGoto action_45 +action_25 (12) = happyGoto action_46 +action_25 _ = happyFail + +action_26 (22) = happyShift action_47 +action_26 (25) = happyShift action_48 +action_26 (26) = happyShift action_49 +action_26 (7) = happyGoto action_50 +action_26 (10) = happyGoto action_44 +action_26 (11) = happyGoto action_45 +action_26 (12) = happyGoto action_46 +action_26 _ = happyFail + +action_27 (22) = happyShift action_47 +action_27 (25) = happyShift action_48 +action_27 (26) = happyShift action_49 +action_27 (7) = happyGoto action_43 +action_27 (10) = happyGoto action_44 +action_27 (11) = happyGoto action_45 +action_27 (12) = happyGoto action_46 +action_27 _ = happyFail + +action_28 (25) = happyShift action_42 +action_28 _ = happyFail + +action_29 (34) = happyShift action_35 +action_29 (35) = happyShift action_36 +action_29 _ = happyReduce_29 + +action_30 _ = happyReduce_32 + +action_31 (23) = happyShift action_13 +action_31 (24) = happyShift action_14 +action_31 (15) = happyGoto action_30 +action_31 (16) = happyGoto action_31 +action_31 _ = happyReduce_33 + +action_32 (21) = happyShift action_12 +action_32 (27) = happyShift action_15 +action_32 (28) = happyShift action_16 +action_32 (29) = happyShift action_17 +action_32 (32) = happyShift action_19 +action_32 (38) = happyShift action_20 +action_32 (6) = happyGoto action_41 +action_32 _ = happyFail + +action_33 (34) = happyShift action_35 +action_33 (35) = happyShift action_36 +action_33 _ = happyReduce_28 + +action_34 (32) = happyShift action_40 +action_34 (17) = happyGoto action_39 +action_34 _ = happyFail + +action_35 (21) = happyShift action_12 +action_35 (27) = happyShift action_15 +action_35 (28) = happyShift action_16 +action_35 (29) = happyShift action_17 +action_35 (32) = happyShift action_19 +action_35 (38) = happyShift action_20 +action_35 (6) = happyGoto action_38 +action_35 _ = happyFail + +action_36 (21) = happyShift action_12 +action_36 (27) = happyShift action_15 +action_36 (28) = happyShift action_16 +action_36 (29) = happyShift action_17 +action_36 (32) = happyShift action_19 +action_36 (38) = happyShift action_20 +action_36 (6) = happyGoto action_37 +action_36 _ = happyFail + +action_37 _ = happyReduce_9 + +action_38 (35) = happyShift action_36 +action_38 _ = happyReduce_8 + +action_39 _ = happyReduce_2 + +action_40 (32) = happyShift action_40 +action_40 (17) = happyGoto action_71 +action_40 _ = happyReduce_37 + +action_41 (34) = happyShift action_35 +action_41 (35) = happyShift action_36 +action_41 _ = happyReduce_27 + +action_42 (37) = happyShift action_70 +action_42 _ = happyFail + +action_43 (39) = happyShift action_69 +action_43 _ = happyFail + +action_44 (22) = happyShift action_47 +action_44 (25) = happyShift action_48 +action_44 (8) = happyGoto action_66 +action_44 (11) = happyGoto action_67 +action_44 (12) = happyGoto action_68 +action_44 _ = happyFail + +action_45 (22) = happyShift action_47 +action_45 (26) = happyShift action_49 +action_45 (9) = happyGoto action_63 +action_45 (10) = happyGoto action_64 +action_45 (12) = happyGoto action_65 +action_45 _ = happyFail + +action_46 (25) = happyShift action_48 +action_46 (26) = happyShift action_49 +action_46 (10) = happyGoto action_61 +action_46 (11) = happyGoto action_62 +action_46 _ = happyFail + +action_47 _ = happyReduce_24 + +action_48 (37) = happyShift action_60 +action_48 _ = happyFail + +action_49 (37) = happyShift action_59 +action_49 _ = happyFail + +action_50 (39) = happyShift action_58 +action_50 _ = happyFail + +action_51 (39) = happyShift action_57 +action_51 _ = happyFail + +action_52 (39) = happyShift action_56 +action_52 _ = happyFail + +action_53 _ = happyReduce_10 + +action_54 (21) = happyShift action_12 +action_54 (27) = happyShift action_15 +action_54 (28) = happyShift action_16 +action_54 (29) = happyShift action_17 +action_54 (32) = happyShift action_19 +action_54 (38) = happyShift action_20 +action_54 (6) = happyGoto action_55 +action_54 _ = happyFail + +action_55 (34) = happyShift action_35 +action_55 (35) = happyShift action_36 +action_55 _ = happyReduce_3 + +action_56 (31) = happyShift action_81 +action_56 _ = happyReduce_25 + +action_57 _ = happyReduce_6 + +action_58 _ = happyReduce_5 + +action_59 (33) = happyShift action_80 +action_59 _ = happyFail + +action_60 (33) = happyShift action_79 +action_60 _ = happyFail + +action_61 (25) = happyShift action_48 +action_61 (11) = happyGoto action_78 +action_61 _ = happyFail + +action_62 (26) = happyShift action_49 +action_62 (10) = happyGoto action_77 +action_62 _ = happyFail + +action_63 _ = happyReduce_13 + +action_64 (22) = happyShift action_47 +action_64 (12) = happyGoto action_76 +action_64 _ = happyReduce_21 + +action_65 (26) = happyShift action_49 +action_65 (10) = happyGoto action_75 +action_65 _ = happyFail + +action_66 _ = happyReduce_12 + +action_67 (22) = happyShift action_47 +action_67 (12) = happyGoto action_74 +action_67 _ = happyReduce_18 + +action_68 (25) = happyShift action_48 +action_68 (11) = happyGoto action_73 +action_68 _ = happyFail + +action_69 _ = happyReduce_4 + +action_70 (33) = happyShift action_72 +action_70 _ = happyFail + +action_71 _ = happyReduce_36 + +action_72 (39) = happyShift action_82 +action_72 _ = happyFail + +action_73 _ = happyReduce_16 + +action_74 _ = happyReduce_17 + +action_75 _ = happyReduce_20 + +action_76 _ = happyReduce_19 + +action_77 _ = happyReduce_15 + +action_78 _ = happyReduce_14 + +action_79 _ = happyReduce_23 + +action_80 _ = happyReduce_22 + +action_81 _ = happyReduce_26 + +action_82 _ = happyReduce_7 + +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 ((HappyAbsSyn17 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn13 happy_var_2) `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn4 + (SpecDec happy_var_2 happy_var_4 + ) `HappyStk` happyRest + +happyReduce_3 = happyReduce 5 5 happyReduction_3 +happyReduction_3 ((HappyAbsSyn6 happy_var_5) `HappyStk` + _ `HappyStk` + (HappyTerminal (TId happy_var_3)) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn5 + ((happy_var_3, happy_var_5) + ) `HappyStk` happyRest + +happyReduce_4 = happyReduce 4 6 happyReduction_4 +happyReduction_4 (_ `HappyStk` + (HappyAbsSyn7 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (applyAttr Forward happy_var_3 + ) `HappyStk` happyRest + +happyReduce_5 = happyReduce 4 6 happyReduction_5 +happyReduction_5 (_ `HappyStk` + (HappyAbsSyn7 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (applyAttr Backward happy_var_3 + ) `HappyStk` happyRest + +happyReduce_6 = happyReduce 4 6 happyReduction_6 +happyReduction_6 (_ `HappyStk` + (HappyAbsSyn7 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn6 + (applyAttr Centered happy_var_3 + ) `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_2 7 happyReduction_12 +happyReduction_12 (HappyAbsSyn8 happy_var_2) + (HappyAbsSyn10 happy_var_1) + = HappyAbsSyn7 + ((happy_var_1, fst happy_var_2, snd happy_var_2) + ) +happyReduction_12 _ _ = notHappyAtAll + +happyReduce_13 = happySpecReduce_2 7 happyReduction_13 +happyReduction_13 (HappyAbsSyn9 happy_var_2) + (HappyAbsSyn11 happy_var_1) + = HappyAbsSyn7 + ((fst happy_var_2, happy_var_1, snd happy_var_2) + ) +happyReduction_13 _ _ = notHappyAtAll + +happyReduce_14 = happySpecReduce_3 7 happyReduction_14 +happyReduction_14 (HappyAbsSyn11 happy_var_3) + (HappyAbsSyn10 happy_var_2) + (HappyAbsSyn12 happy_var_1) + = HappyAbsSyn7 + ((happy_var_2, happy_var_3, happy_var_1) + ) +happyReduction_14 _ _ _ = notHappyAtAll + +happyReduce_15 = happySpecReduce_3 7 happyReduction_15 +happyReduction_15 (HappyAbsSyn10 happy_var_3) + (HappyAbsSyn11 happy_var_2) + (HappyAbsSyn12 happy_var_1) + = HappyAbsSyn7 + ((happy_var_3, happy_var_2, happy_var_1) + ) +happyReduction_15 _ _ _ = notHappyAtAll + +happyReduce_16 = happySpecReduce_2 8 happyReduction_16 +happyReduction_16 (HappyAbsSyn11 happy_var_2) + (HappyAbsSyn12 happy_var_1) + = HappyAbsSyn8 + ((happy_var_2, happy_var_1) + ) +happyReduction_16 _ _ = notHappyAtAll + +happyReduce_17 = happySpecReduce_2 8 happyReduction_17 +happyReduction_17 (HappyAbsSyn12 happy_var_2) + (HappyAbsSyn11 happy_var_1) + = HappyAbsSyn8 + ((happy_var_1, happy_var_2) + ) +happyReduction_17 _ _ = notHappyAtAll + +happyReduce_18 = happySpecReduce_1 8 happyReduction_18 +happyReduction_18 (HappyAbsSyn11 happy_var_1) + = HappyAbsSyn8 + ((happy_var_1, True) + ) +happyReduction_18 _ = notHappyAtAll + +happyReduce_19 = happySpecReduce_2 9 happyReduction_19 +happyReduction_19 (HappyAbsSyn12 happy_var_2) + (HappyAbsSyn10 happy_var_1) + = HappyAbsSyn9 + ((happy_var_1, happy_var_2) + ) +happyReduction_19 _ _ = notHappyAtAll + +happyReduce_20 = happySpecReduce_2 9 happyReduction_20 +happyReduction_20 (HappyAbsSyn10 happy_var_2) + (HappyAbsSyn12 happy_var_1) + = HappyAbsSyn9 + ((happy_var_2, happy_var_1) + ) +happyReduction_20 _ _ = notHappyAtAll + +happyReduce_21 = happySpecReduce_1 9 happyReduction_21 +happyReduction_21 (HappyAbsSyn10 happy_var_1) + = HappyAbsSyn9 + ((happy_var_1, True) + ) +happyReduction_21 _ = notHappyAtAll + +happyReduce_22 = happySpecReduce_3 10 happyReduction_22 +happyReduction_22 (HappyTerminal (TNum happy_var_3)) + _ + _ + = HappyAbsSyn10 + (Depth $ read happy_var_3 + ) +happyReduction_22 _ _ _ = notHappyAtAll + +happyReduce_23 = happySpecReduce_3 11 happyReduction_23 +happyReduction_23 (HappyTerminal (TNum happy_var_3)) + _ + _ + = HappyAbsSyn11 + (Dim $ read happy_var_3 + ) +happyReduction_23 _ _ _ = notHappyAtAll + +happyReduce_24 = happySpecReduce_1 12 happyReduction_24 +happyReduction_24 _ + = HappyAbsSyn12 + (False + ) + +happyReduce_25 = happyReduce 4 13 happyReduction_25 +happyReduction_25 (_ `HappyStk` + (HappyAbsSyn17 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (Temporal happy_var_3 False + ) `HappyStk` happyRest + +happyReduce_26 = happyReduce 5 13 happyReduction_26 +happyReduction_26 (_ `HappyStk` + _ `HappyStk` + (HappyAbsSyn17 happy_var_3) `HappyStk` + _ `HappyStk` + _ `HappyStk` + happyRest) + = HappyAbsSyn13 + (Temporal happy_var_3 True + ) `HappyStk` happyRest + +happyReduce_27 = happySpecReduce_3 13 happyReduction_27 +happyReduction_27 (HappyAbsSyn6 happy_var_3) + (HappyAbsSyn14 happy_var_2) + (HappyAbsSyn15 happy_var_1) + = HappyAbsSyn13 + (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3 + ) +happyReduction_27 _ _ _ = notHappyAtAll + +happyReduce_28 = happySpecReduce_2 13 happyReduction_28 +happyReduction_28 (HappyAbsSyn6 happy_var_2) + (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn13 + (Spatial [happy_var_1] happy_var_2 + ) +happyReduction_28 _ _ = notHappyAtAll + +happyReduce_29 = happySpecReduce_2 13 happyReduction_29 +happyReduction_29 (HappyAbsSyn6 happy_var_2) + (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn13 + (Spatial [happy_var_1] happy_var_2 + ) +happyReduction_29 _ _ = notHappyAtAll + +happyReduce_30 = happySpecReduce_1 13 happyReduction_30 +happyReduction_30 (HappyAbsSyn6 happy_var_1) + = HappyAbsSyn13 + (Spatial [] happy_var_1 + ) +happyReduction_30 _ = notHappyAtAll + +happyReduce_31 = happySpecReduce_1 14 happyReduction_31 +happyReduction_31 _ + = HappyAbsSyn14 + (ReadOnce + ) + +happyReduce_32 = happySpecReduce_2 15 happyReduction_32 +happyReduction_32 (HappyAbsSyn15 happy_var_2) + (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn15 + (happy_var_1 : happy_var_2 + ) +happyReduction_32 _ _ = notHappyAtAll + +happyReduce_33 = happySpecReduce_1 15 happyReduction_33 +happyReduction_33 (HappyAbsSyn14 happy_var_1) + = HappyAbsSyn15 + ([happy_var_1] + ) +happyReduction_33 _ = notHappyAtAll + +happyReduce_34 = happySpecReduce_1 16 happyReduction_34 +happyReduction_34 _ + = HappyAbsSyn14 + (AtMost + ) + +happyReduce_35 = happySpecReduce_1 16 happyReduction_35 +happyReduction_35 _ + = HappyAbsSyn14 + (AtLeast + ) + +happyReduce_36 = happySpecReduce_2 17 happyReduction_36 +happyReduction_36 (HappyAbsSyn17 happy_var_2) + (HappyTerminal (TId happy_var_1)) + = HappyAbsSyn17 + (happy_var_1 : happy_var_2 + ) +happyReduction_36 _ _ = notHappyAtAll + +happyReduce_37 = happySpecReduce_1 17 happyReduction_37 +happyReduction_37 (HappyTerminal (TId happy_var_1)) + = HappyAbsSyn17 + ([happy_var_1] + ) +happyReduction_37 _ = notHappyAtAll + +happyNewToken action sts stk [] = + action 40 40 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 18; + TId "region" -> cont 19; + TId "readonce" -> cont 20; + TId "reflexive" -> cont 21; + TId "irreflexive" -> cont 22; + TId "atmost" -> cont 23; + TId "atleast" -> cont 24; + TId "dim" -> cont 25; + TId "depth" -> cont 26; + TId "forward" -> cont 27; + TId "backward" -> cont 28; + TId "centered" -> cont 29; + TId "dependency" -> cont 30; + TId "mutual" -> cont 31; + TId happy_dollar_dollar -> cont 32; + TNum happy_dollar_dollar -> cont 33; + TPlus -> cont 34; + TStar -> cont 35; + TDoubleColon -> cont 36; + TEqual -> cont 37; + TLParen -> cont 38; + TRParen -> cont 39; + _ -> happyError' (tk:tks) + } + +happyError_ 40 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 + + +newtype Depth a = Depth a +newtype Dim a = Dim a + +applyAttr :: (Int -> Int -> Bool -> Region) + -> (Depth Int, Dim Int, Bool) + -> Region +applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl + +data Specification + = RegionDec String Region + | SpecDec Spec [String] + deriving (Show, Eq, Ord, Typeable, Data) + +data Region + = Forward Int Int Bool + | Backward Int Int Bool + | Centered Int Int Bool + | Or Region Region + | And Region Region + | Var String + deriving (Show, Eq, Ord, Typeable, Data) + +data Spec + = Spatial [Mod] Region + | 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 @@ -6,6 +6,7 @@ import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace) import Data.List (intersect, sort, isPrefixOf) import Data.Data +import qualified Data.Text as T import Debug.Trace @@ -163,12 +164,6 @@ 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 @@ -179,6 +174,7 @@ '<':input' -> testAnnotation input' _ -> Left NotAnnotation where + stripLeadingWhiteSpace = T.unpack . T.strip . T.pack testAnnotation inp = -- First test to see if the input looks like an actual -- specification of either a stencil or region 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 @@ -233,7 +233,7 @@ else return [] -- Not an assign we are interested in _ -> return []) - if mode == Synth && not (null specs) + if mode == Synth && not (null specs) && specs /= [[]] then let specComment = Synth.formatSpec (Just (tabs ++ '!':marker:" ")) ?nameMap (span, Left (concat specs')) specs' = map (mapMaybe noSpecAlready) specs @@ -258,14 +258,14 @@ else return [] -- descend into the body of the do-statement - body' <- mapM (descendBiM (perBlockInfer mode marker)) body + body' <- mapM (descendBiM (perBlockInfer mode marker)) body -- Remove any induction variable from the state return $ F.BlDo ann span lab cname lab' mDoSpec body' tlab perBlockInfer mode marker b = do -- Go inside child blocks - mapM_ (descendBiM (perBlockInfer mode marker)) $ children b - return b + b' <- descendM (descendBiM (perBlockInfer mode marker)) $ b + return b' genSpecifications :: Params => FAD.InductionVarMapByASTBlock @@ -349,12 +349,25 @@ genRHSsubscripts :: F.Block (FA.Analysis A) -> M.Map Variable [[F.Index (FA.Analysis A)]] -genRHSsubscripts b = - collect [ (FA.varName exp, e) - | F.ExpSubscript _ _ exp subs <- FA.rhsExprs b - , isVariableExpr exp - , let e = F.aStrip subs - , not (null e)] +genRHSsubscripts b = genRHSsubscripts' (transformBi replaceModulo b) + where + -- Any occurence of an subscript "modulo(e, e')" is replaced with "e" + replaceModulo :: F.Expression (FA.Analysis A) -> F.Expression (FA.Analysis A) + replaceModulo e@(F.ExpSubscript _ _ + (F.ExpValue _ _ (F.ValVariable "modulo")) subs) = + -- We expect that the first parameter to modulo is being treated + -- as an IxSingle element + case (head $ F.aStrip subs) of + (F.IxSingle _ _ _ e') -> e' + _ -> e + replaceModulo e = e + + genRHSsubscripts' b = + collect [ (FA.varName exp, e) + | F.ExpSubscript _ _ exp subs <- FA.rhsExprs b + , isVariableExpr exp + , let e = F.aStrip subs + , not (null e)] getInductionVar :: Maybe (F.DoSpecification (FA.Analysis A)) -> [Variable] getInductionVar (Just (F.DoSpecification _ _ (F.StExpressionAssign _ _ e _) _ _)) 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 @@ -165,7 +165,7 @@ mkModel (Backward dep dim reflx) = fromList [mkSingleEntryNeg i dim ?globalDimensionality | i <- [(-dep)..i0]] - where i0 = if reflx then 0 else 1 + where i0 = if reflx then 0 else -1 mkModel (Centered dep dim reflx) = fromList [mkSingleEntryNeg i dim ?globalDimensionality | i <- [(-dep)..dep] \\ i0] 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 span ++ " \t" + Nothing -> show span ++ " " Just pr -> pr formatSpec prefix nm (span, Left []) = "" @@ -70,7 +70,7 @@ (intercalate "\n" $ map (\s -> prefix' ++ doSpec s) specs) where prefix' = case prefix of - Nothing -> show span ++ " \t" + Nothing -> show span ++ " " Just pr -> pr commaSep = intercalate ", " doSpec (arrayVar, spec) = 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 @@ -69,22 +69,22 @@ | Left exc <- eVars = (errReport exc, -1) where -- Format report - okReport [] = (logs ++ "\n" ++ fname ++ ":\n" - ++ "No additional annotations are necessary.\n", 0) + okReport [] = (logs ++ "\n" ++ fname + ++ ":No additional annotations are necessary.\n", 0) okReport vars = (logs ++ "\n" ++ fname ++ ": " ++ show numVars ++ " variable declarations suggested to be given a specification:\n" - ++ unlines [ "\t" ++ expReport ei | ei <- expInfo ], numVars) + ++ unlines [ " " ++ expReport ei | ei <- expInfo ], numVars) where names = map showVar vars - expInfo = filter ((`elem` names) . FA.varName) $ declVariables pfUA + expInfo = filter ((`elem` names) . FA.srcName) $ declVariables pfUA numVars = length expInfo - expReport e = "(" ++ showSrcSpan (FU.getSpan e) ++ ")\t" ++ FA.srcName e + expReport e = "(" ++ showSrcSpan (FU.getSpan e) ++ ") " ++ FA.srcName e varReport = intercalate ", " . map showVar - showVar (UnitVar (_, s)) = s + showVar (UnitVar (_, s)) = s showVar (UnitLiteral _) = "" showVar _ = "" @@ -106,8 +106,8 @@ | Left exc <- eCons = errReport exc where -- Format report - okReport Nothing = logs ++ "\n" ++ fname ++ "\t: Consistent. " ++ show nVars ++ " variables checked." - okReport (Just cons) = logs ++ "\n" ++ fname ++ "\t: Inconsistent:\n" ++ reportErrors cons + okReport Nothing = logs ++ "\n" ++ fname ++ ": Consistent. " ++ show nVars ++ " variables checked." + okReport (Just cons) = logs ++ "\n" ++ fname ++ ": Inconsistent:\n" ++ reportErrors cons reportErrors cons = unlines [ reportError con | con <- cons ] reportError con = " - at " ++ srcSpan con @@ -159,7 +159,7 @@ showVar (UnitLiteral _) = "" -- FIXME showVar _ = "" - errReport exc = logs ++ "\n" ++ fname ++ ":\t " ++ show exc + errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } @@ -192,7 +192,7 @@ expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e - errReport exc = logs ++ "\n" ++ fname ++ ":\t" ++ show exc + errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } @@ -221,7 +221,7 @@ expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e - errReport exc = logs ++ "\n" ++ fname ++ ":\t" ++ show exc + errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } 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 @@ -33,6 +33,7 @@ import Data.List import Data.Matrix import Data.Ratio +import qualified Debug.Trace as D import Text.Printf @@ -76,9 +77,17 @@ UnitMul u1 u2 -> maybeParenS u1 ++ " " ++ maybeParenS u2 UnitPow u 1 -> show u UnitPow u 0 -> "1" - UnitPow u k -> printf "%s**%s" (maybeParen u) kStr - where kStr | k < 0 = printf "(%f)" k - | otherwise = show k + UnitPow u k -> + case doubleToRationalSubset k of + Just r -> printf "%s**%s" (maybeParen u) (showRational r) + Nothing -> error $ + printf "Irrational unit exponent: %s**%f" (maybeParen u) k + where showRational r + | r < 0 = printf "(%s)" (showRational' r) + | otherwise = showRational' r + showRational' r + | denominator r == 1 = show (numerator r) + | otherwise = printf "%s / %s" (numerator r) (denominator r) where maybeParen x | all isAlphaNum s = s | otherwise = "(" ++ s ++ ")" @@ -87,6 +96,30 @@ | otherwise = "(" ++ s ++ ")" where s = show x isUnitMulOk c = isSpace c || isAlphaNum c || c `elem` "*." + +-- Converts doubles to a rational that can be expressed +-- as a rational with denominator at most 10 +-- otherwise Noting +doubleToRationalSubset :: Double -> Maybe Rational +doubleToRationalSubset x | x < 0 = + doubleToRationalSubset (abs x) >>= (\x -> return (-x)) +doubleToRationalSubset x = + doubleToRational' 0 1 (ceiling x) 1 + where + -- The maximum common denominator, controls granularity + n = 16 + doubleToRational' a b c d + | b <= n && d <= n = + let mediant = (fromIntegral (a+c))/(fromIntegral (b+d)) + in if x == mediant + then if b + d <= n + then Just $ (a + c) % (b + d) + else Nothing + else if x > mediant + then doubleToRational' (a+c) (b+d) c d + else doubleToRational' a b (a+c) (b+d) + | b > n = Just $ c % d + | otherwise = Just $ a % b -- | A relation between UnitInfos data Constraint 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 @@ -11,6 +11,7 @@ import Data.Data import Data.List import Data.Char (isLetter, isNumber, isAlphaNum, toLower) +import qualified Data.Text as T } %monad { Either AnnotationParseError } { >>= } { return } @@ -127,8 +128,13 @@ deriving (Show) lexer :: String -> Either AnnotationParseError [ Token ] +lexer [] = Left NotAnnotation lexer (c:xs) - | c `elem` ['=', '!', '>', '<'] = lexer' xs + | c `elem` ['=', '!', '>', '<'] = + -- First test to see if the input looks like an actual unit specification + if "unit" `isPrefixOf` (T.unpack . T.strip . T.toLower . T.pack $ xs) + then lexer' xs + else Left NotAnnotation | otherwise = Left NotAnnotation addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] @@ -154,7 +160,7 @@ 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) + | otherwise = failWith $ "Not valid unit syntax at " ++ show (x:xs) ++ "\n" where aux p cons = let (target, rest) = span p xs @@ -166,6 +172,6 @@ parseUnit tokens happyError :: [ Token ] -> Either AnnotationParseError a -happyError t = Left NotAnnotation -- failWith $ "Could not parse specification at: " ++ show t +happyError t = failWith $ "Could not parse unit specification at: " ++ show t ++ "\n" } diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -94,7 +94,7 @@ where header = introMsg ++ usage ++ menu ++ "\nOptions:" -- * Which modes do not require an output -outputNotRequired = ["count" +outputNotRequired = ["count", "ast" , "stencils-infer", "stencils-check" , "units-infer", "units-check", "units-suggest"] @@ -128,13 +128,14 @@ ("units-synth", (unitsSynth, "unit-of-measure synthesise specs.")) ] -- * Usage and about information -version = "0.900" +version = "0.902" introMsg = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure." usage = "Usage: camfort [OUTPUT] [OPTIONS...]\n" menu = "Refactor functions:\n" - ++ concatMap (\(k, (_, info)) -> "\t" ++ k ++ replicate (15 - length k) ' ' - ++ "\t [" ++ info ++ "] \n") refactorings + ++ concatMap (\(k, (_, info)) -> space ++ k ++ replicate (15 - length k) ' ' + ++ " [" ++ info ++ "] \n") refactorings ++ "\nAnalysis functions:\n" - ++ concatMap (\(k, (_, info)) -> "\t" ++ k ++ replicate (15 - length k) ' ' - ++ "\t [" ++ info ++ "] \n") analyses + ++ concatMap (\(k, (_, info)) -> space ++ k ++ replicate (15 - length k) ' ' + ++ " [" ++ info ++ "] \n") analyses + where space = replicate 5 ' ' 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 @@ -51,6 +51,12 @@ Nothing consistent centeredAcs spec `shouldBe` True + it "1D backward irreflexive lower bound - positive" $ do + let spec = Single $ Bound + (Just $ Spatial $ Sum [ Product [ Backward 1 1 False ] ]) + Nothing + consistent (Single [[-1]]) spec `shouldBe` True + it "1D centered irreflexive upper bound - negative" $ do let spec = Single $ Bound Nothing diff --git a/tests/Camfort/Specification/Stencils/example2.f b/tests/Camfort/Specification/Stencils/example2.f deleted file mode 100644 --- a/tests/Camfort/Specification/Stencils/example2.f +++ /dev/null @@ -1,45 +0,0 @@ - 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 deleted file mode 100644 --- a/tests/Camfort/Specification/Stencils/example3.f +++ /dev/null @@ -1,31 +0,0 @@ - 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 deleted file mode 100644 --- a/tests/Camfort/Specification/Stencils/example4.f +++ /dev/null @@ -1,8 +0,0 @@ - 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 @@ -22,11 +22,18 @@ import Camfort.Analysis.Annotations import qualified Language.Fortran.AST as F import Language.Fortran.Util.Position +import Language.Fortran.ParserMonad +import Camfort.Reprint +import Camfort.Output import Data.Map.Strict (toList) import qualified Data.IntMap as IM import qualified Data.Set as S +import Data.Functor.Identity +import qualified Data.ByteString.Char8 as B +import System.FilePath + import Test.Hspec import Test.QuickCheck import Test.Hspec.QuickCheck @@ -246,39 +253,65 @@ -- Some integration tests ------------------------- - let file = "tests/Camfort/Specification/Stencils/example2.f" + let file = "tests" + "fixtures" + "Specification" + "Stencils" + "example2.f" + let fileSynthExpected = "tests" + "fixtures" + "Specification" + "Stencils" + "example2.expected.f" program <- runIO $ readParseSrcDir file [] + programSrc <- runIO $ readFile file + synthExpectedSrc <- runIO $ readFile fileSynthExpected describe "integration test on inference for example2.f" $ do it "stencil infer" $ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` - "\ntests/Camfort/Specification/Stencils/example2.f\n\ - \(24:8)-(24:53) \tstencil readOnce, (reflexive(dim=1))*(centered(depth=1, dim=2)) \ + "\ntests/fixtures/Specification/Stencils/example2.f\n\ + \(24:8)-(24:53) stencil 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) stencil readOnce, (backward(depth=1, dim=1)) :: a\n\ + \(41:8)-(41:103) stencil 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" + \(42:8)-(42:37) stencil readOnce, (reflexive(dim=1))*(reflexive(dim=2)) :: a" it "stencil check" $ fst (callAndSummarise (\f p -> (check f p, p)) program) `shouldBe` - "\ntests/Camfort/Specification/Stencils/example2.f\n\ - \(23:1)-(23:86)\tCorrect.\n(31:1)-(31:56)\tCorrect." + "\ntests/fixtures/Specification/Stencils/example2.f\n\ + \(23:1)-(23:86) Correct.\n(31:1)-(31:56) Correct." - let file = "tests/Camfort/Specification/Stencils/example3.f" + it "stencil synth" $ + (B.unpack . runIdentity + $ reprint (refactoring Fortran77) + (snd . head . snd $ synth AssignMode '=' (map (\(f, _, p) -> (f, p)) program)) + (B.pack programSrc)) + `shouldBe` synthExpectedSrc + + let file = "tests" + "fixtures" + "Specification" + "Stencils" + "example3.f" program <- runIO $ readParseSrcDir file [] - let file = "tests/Camfort/Specification/Stencils/example4.f" + let file = "tests" + "fixtures" + "Specification" + "Stencils" + "example4.f" program <- runIO $ readParseSrcDir file [] describe "integration test on inference for example4.f" $ it "stencil infer" $ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` - "\ntests/Camfort/Specification/Stencils/example4.f\n\ - \(6:8)-(6:33) \tstencil (reflexive(dim=1)) :: x" + "\ntests/fixtures/Specification/Stencils/example4.f\n\ + \(6:8)-(6:33) stencil (reflexive(dim=1)) :: x" {- Properties of `spanBoundingBox`: idempotent and associative -} diff --git a/tests/Camfort/Specification/Units/ex1.f90 b/tests/Camfort/Specification/Units/ex1.f90 deleted file mode 100644 --- a/tests/Camfort/Specification/Units/ex1.f90 +++ /dev/null @@ -1,29 +0,0 @@ -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 deleted file mode 100644 --- a/tests/Camfort/Specification/Units/ex2.f90 +++ /dev/null @@ -1,11 +0,0 @@ -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 deleted file mode 100644 --- a/tests/Camfort/Specification/Units/ex3.f90 +++ /dev/null @@ -1,14 +0,0 @@ -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 deleted file mode 100644 --- a/tests/Camfort/Specification/Units/param.f90 +++ /dev/null @@ -1,10 +0,0 @@ - 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 @@ -21,6 +21,7 @@ import qualified Data.Array as A import qualified Numeric.LinearAlgebra as H import qualified Data.Map.Strict as M +import GHC.Real import Numeric.LinearAlgebra ( atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols, takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks, @@ -111,6 +112,9 @@ describe "Infer Variables" $ do it "testCons5" $ do inferVariables testCons5 `shouldBe` testCons5_infer + describe "Check that (restricted) double to ratios is consistent" $ do + it "test all in -10/-10 ... 10/10, apart from /0" $ + do and [testDoubleToRationalSubset x y | x <- [-10..10], y <- [-10..10]] -------------------------------------------------- @@ -182,6 +186,11 @@ testCons5_infer = [(("simple2_a11", "simple2_a11"),UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0))) ,(("simple2_a22", "simple2_a22"),UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))] +testDoubleToRationalSubset :: Integer -> Integer -> Bool +testDoubleToRationalSubset x y = + if x <= 10 && y <= 10 && x >= -10 && y >= -10 && y /= 0 + then doubleToRationalSubset (fromIntegral x / fromIntegral y) == Just (x % y) + else True -------------------------------------------------- litTest1 = flip fortranParser "litTest1.f90" . B.pack $ unlines 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 @@ -9,12 +9,9 @@ import Camfort.Functionality samplesBase :: FilePath -samplesBase = "tests" "Camfort" "Transformation" "samples" +samplesBase = "tests" "fixtures" "Transformation" data Example = Example FilePath FilePath - -examples = - [ Example "common.f90" "common.expected.f90" ] readSample :: FilePath -> IO String readSample filename = do 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 @@ -14,7 +14,6 @@ limitations under the License. -} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE FlexibleContexts #-} module Camfort.Transformation.EquivalenceElimSpec where @@ -30,7 +29,7 @@ import Camfort.Input samplesBase :: FilePath -samplesBase = "tests" "Camfort" "Transformation" "samples" +samplesBase = "tests" "fixtures" "Transformation" readExpected :: FilePath -> IO String readExpected filename = do diff --git a/tests/Camfort/Transformation/samples/common.f90 b/tests/Camfort/Transformation/samples/common.f90 deleted file mode 100644 --- a/tests/Camfort/Transformation/samples/common.f90 +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 --- a/tests/Camfort/Transformation/samples/equiv.f90 +++ /dev/null @@ -1,20 +0,0 @@ -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 diff --git a/tests/fixtures/Specification/Stencils/example2.f b/tests/fixtures/Specification/Stencils/example2.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/Specification/Stencils/example2.f @@ -0,0 +1,47 @@ + 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) + if (.true.) then + a(i,j) = a(modulo(i,imax),1) + a(modulo(i+1,imax) ,1) + a(modulo(i-1,imax),1) + a(1,j) + x + a(i,j) = a(i,j) + a(1,1) + end if + end do + end do + + end diff --git a/tests/fixtures/Specification/Stencils/example3.f b/tests/fixtures/Specification/Stencils/example3.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/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/fixtures/Specification/Stencils/example4.f b/tests/fixtures/Specification/Stencils/example4.f new file mode 100644 --- /dev/null +++ b/tests/fixtures/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/fixtures/Specification/Units/ex1.f90 b/tests/fixtures/Specification/Units/ex1.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/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/fixtures/Specification/Units/ex2.f90 b/tests/fixtures/Specification/Units/ex2.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/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/fixtures/Specification/Units/ex3.f90 b/tests/fixtures/Specification/Units/ex3.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/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/fixtures/Specification/Units/param.f90 b/tests/fixtures/Specification/Units/param.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/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/fixtures/Transformation/common.f90 b/tests/fixtures/Transformation/common.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Transformation/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/fixtures/Transformation/equiv.f90 b/tests/fixtures/Transformation/equiv.f90 new file mode 100644 --- /dev/null +++ b/tests/fixtures/Transformation/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