camfort 0.901 → 0.902
raw patch · 46 files changed
+2963/−6337 lines, 46 filesdep +binarydep +latticesdep +partial-orderdep ~fortran-srcPVP ok
version bump matches the API change (PVP)
Dependencies added: binary, lattices, partial-order, sbv
Dependency ranges changed: fortran-src
API changes (from Hackage documentation)
- Camfort.Helpers.Vec: lengthV :: Vec n a -> Int
- Camfort.Helpers.Vec: showV :: Show a => Vec n a -> String
- Camfort.Helpers.Vec: vmap :: (a -> b) -> Vec n a -> Vec n b
- Camfort.Helpers.Vec: zipVec :: Vec m Int -> Vec n Int -> (Vec (Max n m) Int, Vec (Max n m) Int)
- Camfort.Specification.Stencils.InferenceBackend: [List] :: (IsNatural n, Permutable n) => Vec n a -> List a
- Camfort.Specification.Stencils.InferenceBackend: [ReflEq] :: EqT a a
- Camfort.Specification.Stencils.InferenceBackend: [VL] :: (IsNatural n, Permutable n) => [Vec n a] -> VecList a
- Camfort.Specification.Stencils.InferenceBackend: allRegionPermutations :: (Permutable n) => [Span (Vec n Int)] -> [Span (Vec n Int)]
- Camfort.Specification.Stencils.InferenceBackend: class Permutable (n :: Nat)
- Camfort.Specification.Stencils.InferenceBackend: composeConsecutiveSpans :: Span (Vec n Int) -> Span (Vec n Int) -> [Span (Vec n Int)]
- Camfort.Specification.Stencils.InferenceBackend: data EqT (a :: k) (b :: k)
- Camfort.Specification.Stencils.InferenceBackend: data List a
- Camfort.Specification.Stencils.InferenceBackend: data VecList a
- Camfort.Specification.Stencils.InferenceBackend: foldL :: (a -> a -> [a]) -> [a] -> [a]
- Camfort.Specification.Stencils.InferenceBackend: fromList :: [a] -> List a
- Camfort.Specification.Stencils.InferenceBackend: fromLists :: [[Int]] -> VecList Int
- Camfort.Specification.Stencils.InferenceBackend: fromRegionsToSpec :: IsNatural n => [Span (Vec n Int)] -> Approximation Spatial
- Camfort.Specification.Stencils.InferenceBackend: instance Camfort.Specification.Stencils.InferenceBackend.Permutable 'Camfort.Helpers.Vec.Z
- Camfort.Specification.Stencils.InferenceBackend: instance Camfort.Specification.Stencils.InferenceBackend.Permutable ('Camfort.Helpers.Vec.S 'Camfort.Helpers.Vec.Z)
- Camfort.Specification.Stencils.InferenceBackend: instance Camfort.Specification.Stencils.InferenceBackend.Permutable ('Camfort.Helpers.Vec.S n) => Camfort.Specification.Stencils.InferenceBackend.Permutable ('Camfort.Helpers.Vec.S ('Camfort.Helpers.Vec.S n))
- Camfort.Specification.Stencils.InferenceBackend: lcons :: a -> List a -> List a
- Camfort.Specification.Stencils.InferenceBackend: lnil :: List a
- Camfort.Specification.Stencils.InferenceBackend: normaliseSpan :: Span (Vec n Int) -> Span (Vec n Int)
- Camfort.Specification.Stencils.InferenceBackend: permutationsV :: Permutable n => Vec n a -> [(Vec n a, Vec n a -> Vec n a)]
- Camfort.Specification.Stencils.InferenceBackend: reducor :: [a] -> ([a] -> [a]) -> ([a] -> Int) -> [a]
- Camfort.Specification.Stencils.InferenceBackend: selectionsV :: Permutable n => Vec n a -> [Selection n a]
- Camfort.Specification.Stencils.InferenceBackend: simplify :: Approximation Spatial -> Approximation Spatial
- Camfort.Specification.Stencils.InferenceBackend: simplifySpatial :: Spatial -> Spatial
- Camfort.Specification.Stencils.InferenceBackend: spanBoundingBox :: Span (Vec n Int) -> Span (Vec n Int) -> Span (Vec n Int)
- Camfort.Specification.Stencils.InferenceBackend: toSpec1D :: Dimension -> Int -> Int -> Approximation Spatial
- Camfort.Specification.Stencils.InferenceBackend: toSpecND :: Span (Vec n Int) -> Approximation Spatial
- Camfort.Specification.Stencils.InferenceFrontend: strength :: Monad m => (a, m b) -> m (a, b)
- Camfort.Specification.Stencils.Model: class Model spec where type Domain spec dimensionality = maximum . dimensions where {
- Camfort.Specification.Stencils.Model: consistent :: Multiplicity [[Int]] -> Multiplicity (Approximation Spatial) -> Bool
- Camfort.Specification.Stencils.Model: cprodV :: [[Int]] -> [[Int]] -> [[Int]]
- Camfort.Specification.Stencils.Model: cprodVs :: [[[Int]]] -> [[Int]]
- Camfort.Specification.Stencils.Model: dimensionality :: Model spec => spec -> Int
- Camfort.Specification.Stencils.Model: dimensions :: Model spec => spec -> [Int]
- Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Model (Camfort.Specification.Stencils.Syntax.Approximation Camfort.Specification.Stencils.Syntax.Spatial)
- Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Model (Camfort.Specification.Stencils.Syntax.Multiplicity (Camfort.Specification.Stencils.Syntax.Approximation Camfort.Specification.Stencils.Syntax.Spatial))
- Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Model Camfort.Specification.Stencils.Syntax.Region
- Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Model Camfort.Specification.Stencils.Syntax.RegionProd
- Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Model Camfort.Specification.Stencils.Syntax.RegionSum
- Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Model Camfort.Specification.Stencils.Syntax.Spatial
- Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Model Camfort.Specification.Stencils.Syntax.Specification
- Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Model a => Camfort.Specification.Stencils.Model.Model (GHC.Base.Maybe a)
- Camfort.Specification.Stencils.Model: maximum1 :: (Ord t, Num t) => [t] -> t
- Camfort.Specification.Stencils.Model: mkModel :: (Model spec, ?globalDimensionality :: Int) => spec -> Domain spec
- Camfort.Specification.Stencils.Model: mkSingleEntryNeg :: Int -> Int -> Int -> [Int]
- Camfort.Specification.Stencils.Model: model :: Multiplicity (Approximation Spatial) -> Int -> Multiplicity (Approximation (Set [Int]))
- Camfort.Specification.Stencils.Model: pairwisePerm :: [Int] -> [Int] -> [[Int]]
- Camfort.Specification.Stencils.Model: tensor :: Int -> [[Int]] -> [[Int]] -> Set [Int]
- Camfort.Specification.Stencils.Syntax: Bound :: (Maybe a) -> (Maybe a) -> Approximation a
- Camfort.Specification.Stencils.Syntax: Exact :: a -> Approximation a
- Camfort.Specification.Stencils.Syntax: Multiple :: a -> Multiplicity a
- Camfort.Specification.Stencils.Syntax: Single :: a -> Multiplicity a
- Camfort.Specification.Stencils.Syntax: absorbReflexive :: [Region] -> [Region] -> Maybe ([Region], [Region])
- Camfort.Specification.Stencils.Syntax: absorbReflexive' :: [Region] -> [Region] -> Maybe ([Region], [t])
- Camfort.Specification.Stencils.Syntax: data Approximation a
- Camfort.Specification.Stencils.Syntax: data Multiplicity a
- Camfort.Specification.Stencils.Syntax: distAndOverlaps :: [Region] -> [Region] -> Maybe [Region]
- Camfort.Specification.Stencils.Syntax: distAndOverlaps' :: [Region] -> [Region] -> Maybe [Region]
- Camfort.Specification.Stencils.Syntax: fromExact :: Approximation a -> a
- Camfort.Specification.Stencils.Syntax: fromMult :: Multiplicity a -> a
- Camfort.Specification.Stencils.Syntax: instance Camfort.Helpers.PartialMonoid Camfort.Specification.Stencils.Syntax.RegionProd
- Camfort.Specification.Stencils.Syntax: instance Camfort.Specification.Stencils.Syntax.RegionRig (Camfort.Specification.Stencils.Syntax.Approximation Camfort.Specification.Stencils.Syntax.Spatial)
- Camfort.Specification.Stencils.Syntax: instance Data.Data.Data a => Data.Data.Data (Camfort.Specification.Stencils.Syntax.Approximation a)
- Camfort.Specification.Stencils.Syntax: instance Data.Data.Data a => Data.Data.Data (Camfort.Specification.Stencils.Syntax.Multiplicity a)
- Camfort.Specification.Stencils.Syntax: instance GHC.Base.Functor Camfort.Specification.Stencils.Syntax.Approximation
- Camfort.Specification.Stencils.Syntax: instance GHC.Base.Functor Camfort.Specification.Stencils.Syntax.Multiplicity
- Camfort.Specification.Stencils.Syntax: instance GHC.Classes.Eq a => GHC.Classes.Eq (Camfort.Specification.Stencils.Syntax.Approximation a)
- Camfort.Specification.Stencils.Syntax: instance GHC.Classes.Eq a => GHC.Classes.Eq (Camfort.Specification.Stencils.Syntax.Multiplicity a)
- Camfort.Specification.Stencils.Syntax: instance GHC.Show.Show (Camfort.Specification.Stencils.Syntax.Approximation Camfort.Specification.Stencils.Syntax.Spatial)
- Camfort.Specification.Stencils.Syntax: instance GHC.Show.Show (Camfort.Specification.Stencils.Syntax.Multiplicity (Camfort.Specification.Stencils.Syntax.Approximation Camfort.Specification.Stencils.Syntax.Spatial))
- Camfort.Specification.Stencils.Syntax: instance GHC.Show.Show a => GHC.Show.Show (Camfort.Specification.Stencils.Syntax.Approximation a)
- Camfort.Specification.Stencils.Syntax: instance GHC.Show.Show a => GHC.Show.Show (Camfort.Specification.Stencils.Syntax.Multiplicity a)
- Camfort.Specification.Stencils.Syntax: lowerBound :: a -> Approximation a
- Camfort.Specification.Stencils.Syntax: upperBound :: a -> Approximation a
- Camfort.Specification.Units.Monad: instance GHC.Read.Read Camfort.Specification.Units.Monad.UnitOpts
+ Camfort.Analysis.CommentAnnotator: linkMultiplePUs :: Linkable a => [ProgramUnit a] -> [ProgramUnit a] -> ([ProgramUnit a], [ProgramUnit a])
+ Camfort.Analysis.CommentAnnotator: linkPU :: Linkable a => a -> ProgramUnit a -> a
+ Camfort.Functionality: FVersion :: String -> Flag
+ Camfort.Functionality: IncludeDir :: String -> Flag
+ Camfort.Functionality: RefactorInPlace :: Flag
+ Camfort.Functionality: datatypes :: [Char] -> [Filename] -> FileOrDir -> t -> IO ()
+ Camfort.Functionality: getExcludedFiles :: Options -> [String]
+ Camfort.Functionality: getModFiles :: [Flag] -> IO ModFiles
+ Camfort.Functionality: isModFile :: [Char] -> Bool
+ Camfort.Functionality: unitsCompile :: [Char] -> [Filename] -> FileOrDir -> [Flag] -> IO ()
+ Camfort.Helpers: Reverse :: f a -> Reverse f a
+ Camfort.Helpers: [unwrapReverse] :: Reverse f a -> f a
+ Camfort.Helpers: data Reverse f a
+ Camfort.Helpers: descendBiReverseM :: (Data from, Data to, Monad m, Biplate from to) => (to -> m to) -> from -> m from
+ Camfort.Helpers: descendReverseM :: (Data on, Monad m, Uniplate on) => (on -> m on) -> on -> m on
+ Camfort.Helpers: instance Data.Foldable.Foldable (Camfort.Helpers.Reverse Data.Generics.Str.Str)
+ Camfort.Helpers: instance Data.Traversable.Traversable (Camfort.Helpers.Reverse Data.Generics.Str.Str)
+ Camfort.Helpers: instance GHC.Base.Functor (Camfort.Helpers.Reverse Data.Generics.Str.Str)
+ Camfort.Helpers.Vec: (!!) :: Vec n a -> Int -> a
+ Camfort.Helpers.Vec: [ExistsEqT] :: EqT (t m) n -> ExistsEqT t n
+ Camfort.Helpers.Vec: [ReflEq] :: EqT a a
+ Camfort.Helpers.Vec: [VL] :: [Vec n a] -> VecList a
+ Camfort.Helpers.Vec: [VecBox] :: Vec n a -> VecBox a
+ Camfort.Helpers.Vec: applyListOp :: ([a] -> [a]) -> Vec n a -> Vec n a
+ Camfort.Helpers.Vec: data EqT a b
+ Camfort.Helpers.Vec: data ExistsEqT t n
+ Camfort.Helpers.Vec: data VecBox a
+ Camfort.Helpers.Vec: data VecList a
+ Camfort.Helpers.Vec: findIndex :: (a -> Bool) -> Vec n a -> Maybe Int
+ Camfort.Helpers.Vec: fromList :: [a] -> VecBox a
+ Camfort.Helpers.Vec: fromLists :: forall a. [[a]] -> VecList a
+ Camfort.Helpers.Vec: hasSize :: Vec m a -> Natural n -> Maybe (EqT m n)
+ Camfort.Helpers.Vec: instance Data.Foldable.Foldable (Camfort.Helpers.Vec.Vec n)
+ Camfort.Helpers.Vec: length :: Vec n a -> Int
+ Camfort.Helpers.Vec: lengthN :: Vec n a -> Natural n
+ Camfort.Helpers.Vec: proveEqSize :: Vec n a -> Vec m b -> Maybe (EqT m n)
+ Camfort.Helpers.Vec: proveNonEmpty :: Vec n a -> Maybe (ExistsEqT S n)
+ Camfort.Helpers.Vec: replace :: Int -> a -> Vec n a -> Vec n a
+ Camfort.Helpers.Vec: toList :: Vec n a -> [a]
+ Camfort.Helpers.Vec: zip :: Vec n a -> Vec n b -> Vec n (a, b)
+ Camfort.Helpers.Vec: zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c
+ Camfort.Input: doAnalysisReportWithModFiles :: ([(Filename, ProgramFile A)] -> r) -> (r -> IO out) -> FileOrDir -> [Filename] -> ModFiles -> IO out
+ Camfort.Input: doCreateBinary :: ([FileProgram] -> (String, [(Filename, ByteString)])) -> FileOrDir -> [Filename] -> FileOrDir -> ModFiles -> IO String
+ Camfort.Input: doRefactorAndCreateBinary :: ([FileProgram] -> (String, [FileProgram], [(Filename, ByteString)])) -> FileOrDir -> [Filename] -> FileOrDir -> IO String
+ Camfort.Input: doRefactorWithModFiles :: ([(Filename, ProgramFile A)] -> (String, [(Filename, ProgramFile A)])) -> FileOrDir -> [Filename] -> FileOrDir -> ModFiles -> IO String
+ Camfort.Input: mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
+ Camfort.Input: rGetDirContents' :: FileOrDir -> IO [String]
+ Camfort.Input: readParseSrcDirWithModFiles :: FileOrDir -> [Filename] -> ModFiles -> IO [(Filename, SourceText, ProgramFile A)]
+ Camfort.Input: readParseSrcFileWithModFiles :: ModFiles -> Filename -> IO (Maybe (Filename, SourceText, ProgramFile A))
+ Camfort.Input: type FileProgram = (Filename, ProgramFile A)
+ Camfort.Output: refactorProgramUnits :: FortranVersion -> SourceText -> ProgramUnit Annotation -> StateT Position (State Int) (SourceText, Bool)
+ Camfort.Output: refactoringsForBlocks :: FortranVersion -> SourceText -> Block Annotation -> StateT Position Identity (SourceText, Bool)
+ Camfort.Output: refactoringsForProgramUnits :: FortranVersion -> SourceText -> ProgramUnit Annotation -> StateT Position Identity (SourceText, Bool)
+ Camfort.Specification.Stencils.Consistency: Consistent :: ConsistencyResult
+ Camfort.Specification.Stencils.Consistency: Inconsistent :: String -> ConsistencyResult
+ Camfort.Specification.Stencils.Consistency: consistent :: forall n. Specification -> Multiplicity (UnionNF n Offsets) -> ConsistencyResult
+ Camfort.Specification.Stencils.Consistency: data ConsistencyResult
+ Camfort.Specification.Stencils.Consistency: instance GHC.Classes.Eq Camfort.Specification.Stencils.Consistency.ConsistencyResult
+ Camfort.Specification.Stencils.Consistency: instance GHC.Show.Show Camfort.Specification.Stencils.Consistency.ConsistencyResult
+ Camfort.Specification.Stencils.DenotationalSemantics: intervalsToRegions :: UnionNF (S n) (Interval Standard) -> Either String Spatial
+ Camfort.Specification.Stencils.DenotationalSemantics: regionsToIntervals :: forall n. Natural n -> Spatial -> Either String (UnionNF n (Interval Standard))
+ Camfort.Specification.Stencils.InferenceBackend: coalesce :: Span (Vec n Int) -> Span (Vec n Int) -> Maybe (Span (Vec n Int))
+ Camfort.Specification.Stencils.InferenceBackend: coalesceContiguous :: [Span (Vec n Int)] -> [Span (Vec n Int)]
+ Camfort.Specification.Stencils.InferenceBackend: sequenceMaybes :: Eq a => [Maybe a] -> Maybe [a]
+ Camfort.Specification.Stencils.InferenceBackend: spansToApproxSpatial :: [Span (Vec (S n) Int)] -> Either String (Approximation Spatial)
+ Camfort.Specification.Stencils.InferenceFrontend: [visitedNodes] :: InferState -> [Int]
+ Camfort.Specification.Stencils.InferenceFrontend: assocsSequence :: Monad m => Map k (m (Maybe a)) -> m [(k, a)]
+ Camfort.Specification.Stencils.InferenceFrontend: filterOutFuns :: Ord a1 => Map a1 a1 -> Map a1 a -> Map a1 a
+ Camfort.Specification.Stencils.InferenceFrontend: subscriptsOnRhs :: Params => NameMap -> [Block (Analysis A)] -> (Map Variable [[Index (Analysis A)]], [Int])
+ Camfort.Specification.Stencils.Model: Arbitrary :: Bound
+ Camfort.Specification.Stencils.Model: Bound :: (Maybe a) -> (Maybe a) -> Approximation a
+ Camfort.Specification.Stencils.Model: Exact :: a -> Approximation a
+ Camfort.Specification.Stencils.Model: Mult :: a -> Multiplicity a
+ Camfort.Specification.Stencils.Model: Offsets :: (Set Int64) -> Offsets
+ Camfort.Specification.Stencils.Model: Once :: a -> Multiplicity a
+ Camfort.Specification.Stencils.Model: SetOfIntegers :: Offsets
+ Camfort.Specification.Stencils.Model: Standard :: Bound
+ Camfort.Specification.Stencils.Model: [IntervArbitrary] :: Int -> Int -> Interval Arbitrary
+ Camfort.Specification.Stencils.Model: [IntervHoled] :: Int64 -> Int64 -> Bool -> Interval Standard
+ Camfort.Specification.Stencils.Model: [IntervInfiniteArbitrary] :: Interval Arbitrary
+ Camfort.Specification.Stencils.Model: [IntervInfinite] :: Interval Standard
+ Camfort.Specification.Stencils.Model: approxVec :: forall n. Vec n (Interval Arbitrary) -> Approximation (Vec n (Interval Standard))
+ Camfort.Specification.Stencils.Model: class Peelable a where type CoreTyp a where {
+ Camfort.Specification.Stencils.Model: data Approximation a
+ Camfort.Specification.Stencils.Model: data Bound
+ Camfort.Specification.Stencils.Model: data Interval a
+ Camfort.Specification.Stencils.Model: data Multiplicity a
+ Camfort.Specification.Stencils.Model: data Offsets
+ Camfort.Specification.Stencils.Model: fromExact :: Approximation a -> a
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.BoundedJoinSemiLattice (Camfort.Specification.Stencils.Model.Interval 'Camfort.Specification.Stencils.Model.Standard)
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.BoundedJoinSemiLattice Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.BoundedLattice (Camfort.Specification.Stencils.Model.Interval 'Camfort.Specification.Stencils.Model.Standard)
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.BoundedLattice Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.BoundedLattice a => Algebra.Lattice.Lattice (Camfort.Specification.Stencils.Model.UnionNF n a)
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.BoundedLattice a => Algebra.Lattice.MeetSemiLattice (Camfort.Specification.Stencils.Model.UnionNF n a)
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.BoundedMeetSemiLattice (Camfort.Specification.Stencils.Model.Interval 'Camfort.Specification.Stencils.Model.Standard)
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.BoundedMeetSemiLattice Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.JoinSemiLattice (Camfort.Specification.Stencils.Model.Interval 'Camfort.Specification.Stencils.Model.Standard)
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.JoinSemiLattice (Camfort.Specification.Stencils.Model.UnionNF n a)
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.JoinSemiLattice Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.Lattice (Camfort.Specification.Stencils.Model.Interval 'Camfort.Specification.Stencils.Model.Standard)
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.Lattice Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.MeetSemiLattice (Camfort.Specification.Stencils.Model.Interval 'Camfort.Specification.Stencils.Model.Standard)
+ Camfort.Specification.Stencils.Model: instance Algebra.Lattice.MeetSemiLattice Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Container (Camfort.Specification.Stencils.Model.Interval 'Camfort.Specification.Stencils.Model.Standard)
+ Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Container Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Container a => Camfort.Specification.Stencils.Model.Container (Camfort.Specification.Stencils.Model.UnionNF n a)
+ Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Peelable (Camfort.Specification.Stencils.Model.Multiplicity a)
+ Camfort.Specification.Stencils.Model: instance Data.Data.Data a => Data.Data.Data (Camfort.Specification.Stencils.Model.Approximation a)
+ Camfort.Specification.Stencils.Model: instance Data.Data.Data a => Data.Data.Data (Camfort.Specification.Stencils.Model.Multiplicity a)
+ Camfort.Specification.Stencils.Model: instance Data.Foldable.Foldable Camfort.Specification.Stencils.Model.Approximation
+ Camfort.Specification.Stencils.Model: instance Data.Foldable.Foldable Camfort.Specification.Stencils.Model.Multiplicity
+ Camfort.Specification.Stencils.Model: instance Data.PartialOrd.PartialOrd (Camfort.Specification.Stencils.Model.Interval 'Camfort.Specification.Stencils.Model.Standard)
+ Camfort.Specification.Stencils.Model: instance Data.PartialOrd.PartialOrd Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance Data.PartialOrd.PartialOrd a => Data.PartialOrd.PartialOrd (Camfort.Helpers.Vec.Vec n a)
+ Camfort.Specification.Stencils.Model: instance Data.Traversable.Traversable Camfort.Specification.Stencils.Model.Approximation
+ Camfort.Specification.Stencils.Model: instance Data.Traversable.Traversable Camfort.Specification.Stencils.Model.Multiplicity
+ Camfort.Specification.Stencils.Model: instance GHC.Base.Functor Camfort.Specification.Stencils.Model.Approximation
+ Camfort.Specification.Stencils.Model: instance GHC.Base.Functor Camfort.Specification.Stencils.Model.Multiplicity
+ Camfort.Specification.Stencils.Model: instance GHC.Classes.Eq (Camfort.Specification.Stencils.Model.Interval a)
+ Camfort.Specification.Stencils.Model: instance GHC.Classes.Eq Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance GHC.Classes.Eq a => GHC.Classes.Eq (Camfort.Specification.Stencils.Model.Approximation a)
+ Camfort.Specification.Stencils.Model: instance GHC.Classes.Eq a => GHC.Classes.Eq (Camfort.Specification.Stencils.Model.Multiplicity a)
+ Camfort.Specification.Stencils.Model: instance GHC.Classes.Ord Camfort.Specification.Stencils.Model.Offsets
+ Camfort.Specification.Stencils.Model: instance GHC.Show.Show (Camfort.Specification.Stencils.Model.Interval 'Camfort.Specification.Stencils.Model.Standard)
+ Camfort.Specification.Stencils.Model: instance GHC.Show.Show a => GHC.Show.Show (Camfort.Specification.Stencils.Model.Approximation a)
+ Camfort.Specification.Stencils.Model: instance GHC.Show.Show a => GHC.Show.Show (Camfort.Specification.Stencils.Model.Multiplicity a)
+ Camfort.Specification.Stencils.Model: lowerBound :: Approximation a -> a
+ Camfort.Specification.Stencils.Model: maximas :: [Vec n (Interval Standard)] -> [Vec n (Interval Standard)]
+ Camfort.Specification.Stencils.Model: optimise :: UnionNF n (Interval Standard) -> UnionNF n (Interval Standard)
+ Camfort.Specification.Stencils.Model: peel :: Peelable a => a -> CoreTyp a
+ Camfort.Specification.Stencils.Model: type UnionNF n a = NonEmpty (Vec n a)
+ Camfort.Specification.Stencils.Model: unfCompare :: forall a b n. (Container a, Container b, MemberTyp a ~ Int64, MemberTyp b ~ Int64, CompTyp a ~ SInt64, CompTyp b ~ SInt64) => UnionNF n a -> UnionNF n b -> Ordering
+ Camfort.Specification.Stencils.Model: upperBound :: Approximation a -> a
+ Camfort.Specification.Stencils.Model: vecLength :: UnionNF n a -> Natural n
+ Camfort.Specification.Stencils.Syntax: instance Camfort.Specification.Stencils.Syntax.RegionRig (Camfort.Specification.Stencils.Model.Approximation Camfort.Specification.Stencils.Syntax.Spatial)
+ Camfort.Specification.Stencils.Syntax: instance GHC.Show.Show (Camfort.Specification.Stencils.Model.Approximation Camfort.Specification.Stencils.Syntax.Spatial)
+ Camfort.Specification.Stencils.Syntax: instance GHC.Show.Show (Camfort.Specification.Stencils.Model.Multiplicity (Camfort.Specification.Stencils.Model.Approximation Camfort.Specification.Stencils.Syntax.Spatial))
+ Camfort.Specification.Units: chooseImplicitNames :: [(VV, UnitInfo)] -> [(VV, UnitInfo)]
+ Camfort.Specification.Units: compileUnits :: UnitOpts -> [FileProgram] -> (String, [(Filename, ByteString)])
+ Camfort.Specification.Units: instance Data.Data.Data Camfort.Specification.Units.ExpInfo
+ Camfort.Specification.Units: instance GHC.Classes.Eq Camfort.Specification.Units.ExpInfo
+ Camfort.Specification.Units: instance GHC.Classes.Ord Camfort.Specification.Units.ExpInfo
+ Camfort.Specification.Units: instance GHC.Generics.Generic Camfort.Specification.Units.ExpInfo
+ Camfort.Specification.Units: instance GHC.Show.Show Camfort.Specification.Units.ExpInfo
+ Camfort.Specification.Units.Environment: UnitParamEAPAbs :: VV -> UnitInfo
+ Camfort.Specification.Units.Environment: UnitParamEAPUse :: (VV, Int) -> UnitInfo
+ Camfort.Specification.Units.Environment: UnitRecord :: [(String, UnitInfo)] -> UnitInfo
+ Camfort.Specification.Units.Environment: [unitPU] :: UnitAnnotation a -> Maybe (ProgramUnit (Analysis (UnitAnnotation a)))
+ Camfort.Specification.Units.Environment: instance Data.Binary.Class.Binary Camfort.Specification.Units.Environment.Constraint
+ Camfort.Specification.Units.Environment: instance Data.Binary.Class.Binary Camfort.Specification.Units.Environment.UnitInfo
+ Camfort.Specification.Units.Environment: instance GHC.Generics.Generic Camfort.Specification.Units.Environment.Constraint
+ Camfort.Specification.Units.Environment: instance GHC.Generics.Generic Camfort.Specification.Units.Environment.UnitInfo
+ Camfort.Specification.Units.Environment: isResolvedUnit :: UnitInfo -> Bool
+ Camfort.Specification.Units.Environment: isUnresolvedUnit :: UnitInfo -> Bool
+ Camfort.Specification.Units.Environment: isVarUnit :: UnitInfo -> Bool
+ Camfort.Specification.Units.InferenceBackend: constraintsToMatrices :: Constraints -> (Matrix Double, Matrix Double, [Int], Array Int UnitInfo, Array Int UnitInfo)
+ Camfort.Specification.Units.InferenceBackend: genUnitAssignments :: [Constraint] -> [([UnitInfo], UnitInfo)]
+ Camfort.Specification.Units.InferenceFrontend: puName :: ProgramUnit UA -> Name
+ Camfort.Specification.Units.InferenceFrontend: puSrcName :: ProgramUnit UA -> Name
+ Camfort.Specification.Units.InferenceFrontend: runCompileUnits :: UnitSolver CompiledUnits
+ Camfort.Specification.Units.Monad: CompiledUnits :: TemplateMap -> NameParamMap -> CompiledUnits
+ Camfort.Specification.Units.Monad: NPKParam :: Name -> Int -> NameParamKey
+ Camfort.Specification.Units.Monad: NPKVariable :: VV -> NameParamKey
+ Camfort.Specification.Units.Monad: [cuNameParamMap] :: CompiledUnits -> NameParamMap
+ Camfort.Specification.Units.Monad: [cuTemplateMap] :: CompiledUnits -> TemplateMap
+ Camfort.Specification.Units.Monad: [uoModFiles] :: UnitOpts -> Map String ModFile
+ Camfort.Specification.Units.Monad: [usNameParamMap] :: UnitState -> NameParamMap
+ Camfort.Specification.Units.Monad: data CompiledUnits
+ Camfort.Specification.Units.Monad: data NameParamKey
+ Camfort.Specification.Units.Monad: emptyCompiledUnits :: CompiledUnits
+ Camfort.Specification.Units.Monad: instance Data.Binary.Class.Binary Camfort.Specification.Units.Monad.CompiledUnits
+ Camfort.Specification.Units.Monad: instance Data.Binary.Class.Binary Camfort.Specification.Units.Monad.NameParamKey
+ Camfort.Specification.Units.Monad: instance Data.Data.Data Camfort.Specification.Units.Monad.CompiledUnits
+ Camfort.Specification.Units.Monad: instance Data.Data.Data Camfort.Specification.Units.Monad.NameParamKey
+ Camfort.Specification.Units.Monad: instance GHC.Classes.Eq Camfort.Specification.Units.Monad.CompiledUnits
+ Camfort.Specification.Units.Monad: instance GHC.Classes.Eq Camfort.Specification.Units.Monad.NameParamKey
+ Camfort.Specification.Units.Monad: instance GHC.Classes.Ord Camfort.Specification.Units.Monad.CompiledUnits
+ Camfort.Specification.Units.Monad: instance GHC.Classes.Ord Camfort.Specification.Units.Monad.NameParamKey
+ Camfort.Specification.Units.Monad: instance GHC.Generics.Generic Camfort.Specification.Units.Monad.CompiledUnits
+ Camfort.Specification.Units.Monad: instance GHC.Generics.Generic Camfort.Specification.Units.Monad.NameParamKey
+ Camfort.Specification.Units.Monad: instance GHC.Show.Show Camfort.Specification.Units.Monad.CompiledUnits
+ Camfort.Specification.Units.Monad: instance GHC.Show.Show Camfort.Specification.Units.Monad.NameParamKey
+ Camfort.Specification.Units.Monad: modifyNameParamMap :: (NameParamMap -> NameParamMap) -> UnitSolver ()
+ Camfort.Specification.Units.Monad: type NameParamMap = Map NameParamKey [UnitInfo]
+ Camfort.Specification.Units.Parser: UnitRecord :: [(String, UnitOfMeasure)] -> UnitOfMeasure
+ Camfort.Transformation.DataTypeIntroduction: analysePerPF :: (Filename, ProgramFile A) -> InOutMap (Set Name)
+ Camfort.Transformation.DataTypeIntroduction: buildInterferenceGraph :: [(Filename, ProgramFile A)] -> String
+ Camfort.Transformation.DataTypeIntroduction: dataTypeIntro :: [(Filename, ProgramFile A)] -> (Report, [(Filename, ProgramFile A)])
+ Camfort.Transformation.DataTypeIntroduction: perStmt :: Annotated f => IntMap (t1, t) -> f (Analysis a) -> a1
+ Camfort.Transformation.DataTypeIntroduction: type IGraphs = Map Name (Gr Name Int)
- Camfort.Analysis.CommentAnnotator: class Linkable a where linkMultiple comments blocks = (map (fmap $ flip link (head blocks)) comments, blocks)
+ Camfort.Analysis.CommentAnnotator: class Linkable a where linkMultiple comments blocks = (map (fmap $ flip link (head blocks)) comments, blocks) linkMultiplePUs comments pus = (map (fmap $ flip linkPU (head pus)) comments, pus)
- Camfort.Functionality: optsToUnitOpts :: [Flag] -> UnitOpts
+ Camfort.Functionality: optsToUnitOpts :: [Flag] -> IO UnitOpts
- Camfort.Input: callAndSummarise :: (Monoid a, Foldable t) => (t1 -> t3 -> (a, a1)) -> t (t1, t2, t3) -> (a, [a1])
+ Camfort.Input: callAndSummarise :: (Monoid a1, Foldable t1) => (t3 -> t2 -> (a1, a)) -> t1 (t3, t, t2) -> (a1, [a])
- Camfort.Input: readParseSrcFile :: Filename -> IO (Filename, SourceText, ProgramFile A)
+ Camfort.Input: readParseSrcFile :: Filename -> IO (Maybe (Filename, SourceText, ProgramFile A))
- Camfort.Reprint: takeBounds' :: (Ord t1, Num t1, Num t, Eq t) => ((t1, t), (t1, t)) -> ByteString -> ByteString -> (ByteString, ByteString)
+ Camfort.Reprint: takeBounds' :: (Num t, Num t1, Ord t1, Eq t) => ((t1, t), (t1, t)) -> ByteString -> ByteString -> (ByteString, ByteString)
- Camfort.Specification.Stencils.InferenceBackend: inferCore :: (IsNatural n, Permutable n) => [Vec n Int] -> Approximation Spatial
+ Camfort.Specification.Stencils.InferenceBackend: inferCore :: [Vec n Int] -> Approximation Spatial
- Camfort.Specification.Stencils.InferenceBackend: inferMinimalVectorRegions :: (Permutable n) => [Vec n Int] -> [Span (Vec n Int)]
+ Camfort.Specification.Stencils.InferenceBackend: inferMinimalVectorRegions :: [Vec n Int] -> [Span (Vec n Int)]
- Camfort.Specification.Stencils.InferenceBackend: mkTrivialSpan :: t -> (t, t)
+ Camfort.Specification.Stencils.InferenceBackend: mkTrivialSpan :: Vec n Int -> Span (Vec n Int)
- Camfort.Specification.Stencils.InferenceFrontend: IS :: InductionVarMapByASTBlock -> [(SrcSpan, Variable)] -> InferState
+ Camfort.Specification.Stencils.InferenceFrontend: IS :: InductionVarMapByASTBlock -> [(SrcSpan, Variable)] -> [Int] -> InferState
- Camfort.Specification.Stencils.InferenceFrontend: genSpecifications :: Params => InductionVarMapByASTBlock -> [Neighbour] -> [Block (Analysis A)] -> Writer EvalLog [([Variable], Specification)]
+ Camfort.Specification.Stencils.InferenceFrontend: genSpecifications :: Params => InductionVarMapByASTBlock -> [Neighbour] -> [Block (Analysis A)] -> Writer EvalLog ([([Variable], Specification)], [Int])
- Camfort.Specification.Stencils.Model: type family Domain spec;
+ Camfort.Specification.Stencils.Model: type family CoreTyp a;
- Camfort.Specification.Stencils.Syntax: showRegion :: (Show a1, Show a) => [Char] -> a -> a1 -> Bool -> [Char]
+ Camfort.Specification.Stencils.Syntax: showRegion :: (Show a, Show a1) => [Char] -> a1 -> a -> Bool -> [Char]
- Camfort.Specification.Units.Environment: UnitAnnotation :: a -> Maybe UnitStatement -> Maybe Constraint -> Maybe UnitInfo -> Maybe (Block (Analysis (UnitAnnotation a))) -> UnitAnnotation a
+ Camfort.Specification.Units.Environment: UnitAnnotation :: a -> Maybe UnitStatement -> Maybe Constraint -> Maybe UnitInfo -> Maybe (Block (Analysis (UnitAnnotation a))) -> Maybe (ProgramUnit (Analysis (UnitAnnotation a))) -> UnitAnnotation a
- Camfort.Specification.Units.Environment: UnitParamVarAbs :: (String, String) -> UnitInfo
+ Camfort.Specification.Units.Environment: UnitParamVarAbs :: (String, VV) -> UnitInfo
- Camfort.Specification.Units.Environment: UnitParamVarUse :: (String, String, Int) -> UnitInfo
+ Camfort.Specification.Units.Environment: UnitParamVarUse :: (String, VV, Int) -> UnitInfo
- Camfort.Specification.Units.Monad: UnitOpts :: Bool -> LiteralsOpt -> NameMap -> UnitOpts
+ Camfort.Specification.Units.Monad: UnitOpts :: Bool -> LiteralsOpt -> NameMap -> Map String ModFile -> UnitOpts
- Camfort.Specification.Units.Monad: UnitState :: ProgramFile UA -> VarUnitMap -> GivenVarSet -> UnitAliasMap -> TemplateMap -> Int -> Int -> CallIdMap -> Constraints -> UnitState
+ Camfort.Specification.Units.Monad: UnitState :: ProgramFile UA -> VarUnitMap -> GivenVarSet -> UnitAliasMap -> TemplateMap -> NameParamMap -> Int -> Int -> CallIdMap -> Constraints -> UnitState
- Camfort.Transformation.EquivalenceElim: equalTypes :: Eq b => Map Name b -> Expression a -> Expression a1 -> Maybe b
+ Camfort.Transformation.EquivalenceElim: equalTypes :: Eq b => Map Name b -> Expression a1 -> Expression a -> Maybe b
Files
- camfort.cabal +27/−7
- dist/build/Camfort/Specification/Stencils/Grammar.hs +0/−980
- dist/build/Camfort/Specification/Units/Parser.hs +0/−766
- dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs +0/−980
- dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs +0/−766
- src/Camfort/Analysis/Annotations.hs +5/−0
- src/Camfort/Analysis/CommentAnnotator.hs +35/−9
- src/Camfort/Functionality.hs +81/−32
- src/Camfort/Helpers.hs +31/−1
- src/Camfort/Helpers/Vec.hs +114/−26
- src/Camfort/Input.hs +124/−6
- src/Camfort/Output.hs +35/−6
- src/Camfort/Specification/Stencils.hs +2/−15
- src/Camfort/Specification/Stencils/Annotation.hs +1/−2
- src/Camfort/Specification/Stencils/CheckBackend.hs +2/−30
- src/Camfort/Specification/Stencils/CheckFrontend.hs +50/−25
- src/Camfort/Specification/Stencils/Consistency.hs +76/−0
- src/Camfort/Specification/Stencils/DenotationalSemantics.hs +95/−0
- src/Camfort/Specification/Stencils/Grammar.hs +0/−1275
- src/Camfort/Specification/Stencils/Grammar.y +4/−4
- src/Camfort/Specification/Stencils/InferenceBackend.hs +101/−259
- src/Camfort/Specification/Stencils/InferenceFrontend.hs +138/−96
- src/Camfort/Specification/Stencils/Model.hs +336/−151
- src/Camfort/Specification/Stencils/Syntax.hs +23/−183
- src/Camfort/Specification/Stencils/Synthesis.hs +1/−15
- src/Camfort/Specification/Units.hs +204/−49
- src/Camfort/Specification/Units/Environment.hs +97/−51
- src/Camfort/Specification/Units/InferenceBackend.hs +103/−44
- src/Camfort/Specification/Units/InferenceFrontend.hs +452/−86
- src/Camfort/Specification/Units/Monad.hs +59/−22
- src/Camfort/Specification/Units/Parser.y +28/−15
- src/Camfort/Specification/Units/Synthesis.hs +51/−9
- src/Camfort/Transformation/CommonBlockElim.hs +4/−3
- src/Camfort/Transformation/DataTypeIntroduction.hs +104/−0
- src/Main.hs +31/−19
- tests/Camfort/Analysis/CommentAnnotatorSpec.hs +23/−23
- tests/Camfort/Helpers/VecSpec.hs +0/−21
- tests/Camfort/Specification/Stencils/CheckSpec.hs +9/−8
- tests/Camfort/Specification/Stencils/ConsistencySpec.hs +37/−0
- tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs +41/−0
- tests/Camfort/Specification/Stencils/GrammarSpec.hs +16/−16
- tests/Camfort/Specification/Stencils/InferenceBackendSpec.hs +32/−0
- tests/Camfort/Specification/Stencils/ModelSpec.hs +132/−198
- tests/Camfort/Specification/StencilsSpec.hs +69/−120
- tests/Camfort/Specification/UnitsSpec.hs +188/−17
- tests/fixtures/Specification/Stencils/example2.f +2/−2
camfort.cabal view
@@ -1,5 +1,5 @@ name: camfort-version: 0.901+version: 0.902 synopsis: CamFort - Cambridge Fortran infrastructure description: CamFort is a tool for the analysis, transformation, verification of Fortran code. @@ -34,6 +34,8 @@ Camfort.Specification.Stencils.Annotation Camfort.Specification.Stencils.CheckBackend Camfort.Specification.Stencils.CheckFrontend+ Camfort.Specification.Stencils.Consistency+ Camfort.Specification.Stencils.DenotationalSemantics Camfort.Specification.Stencils.InferenceBackend Camfort.Specification.Stencils.InferenceFrontend Camfort.Specification.Stencils.Model@@ -50,6 +52,7 @@ Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim Camfort.Transformation.DeadCode+ Camfort.Transformation.DataTypeIntroduction Camfort.Transformation.EquivalenceElim Camfort.Helpers Camfort.Helpers.Syntax@@ -76,10 +79,14 @@ transformers >= 0.4, GenericPretty >= 1.2, QuickCheck >= 2.8,- fortran-src >= 0.1.0.4,+ fortran-src == 0.1.0.6, filepath, fgl >= 5.5,- bytestring >= 0.10+ bytestring >= 0.10,+ binary >= 0.8.3.0,+ lattices >= 1.5,+ sbv >= 5.14,+ partial-order >= 0.1.2 default-language: Haskell2010 library@@ -91,6 +98,8 @@ Camfort.Specification.Stencils.Annotation Camfort.Specification.Stencils.CheckBackend Camfort.Specification.Stencils.CheckFrontend+ Camfort.Specification.Stencils.Consistency+ Camfort.Specification.Stencils.DenotationalSemantics Camfort.Specification.Stencils.InferenceBackend Camfort.Specification.Stencils.InferenceFrontend Camfort.Specification.Stencils.Model@@ -107,6 +116,7 @@ Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim Camfort.Transformation.DeadCode+ Camfort.Transformation.DataTypeIntroduction Camfort.Transformation.EquivalenceElim Camfort.Helpers Camfort.Helpers.Syntax@@ -131,10 +141,14 @@ transformers >= 0.4, vector >= 0.1, GenericPretty >= 1.2,- fortran-src >= 0.1.0.4,+ fortran-src == 0.1.0.6, filepath, bytestring >= 0.10,- fgl >= 5.5+ fgl >= 5.5,+ binary >= 0.8.3.0,+ lattices >= 1.5,+ sbv >= 5.14,+ partial-order >= 0.1.2 default-language: Haskell2010 test-suite spec@@ -142,9 +156,11 @@ main-is: Spec.hs hs-source-dirs: tests other-modules: Camfort.Analysis.CommentAnnotatorSpec- Camfort.Helpers.VecSpec Camfort.Specification.Stencils.CheckSpec+ Camfort.Specification.Stencils.ConsistencySpec+ Camfort.Specification.Stencils.DenotationalSemanticsSpec Camfort.Specification.Stencils.GrammarSpec+ Camfort.Specification.Stencils.InferenceBackendSpec Camfort.Specification.Stencils.ModelSpec Camfort.Specification.StencilsSpec Camfort.Specification.UnitsSpec@@ -156,12 +172,16 @@ directory >= 1.2, hspec >= 2.2, QuickCheck >= 2.8,- fortran-src >= 0.1.0.4,+ fortran-src == 0.1.0.6, uniplate >= 1.6.10, mtl >= 2.1, bytestring >= 0.10, array >= 0.4, hmatrix >= 0.15, text >= 0.11.2.3,+ binary >= 0.8.3.0,+ lattices >= 1.5,+ sbv >= 5.14,+ partial-order >= 0.1.2, camfort default-language: Haskell2010
− dist/build/Camfort/Specification/Stencils/Grammar.hs
@@ -1,980 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}--- -*- Mode: Haskell -*--{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}-module Camfort.Specification.Stencils.Grammar-( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where--import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace)-import Data.List (intersect, sort, isPrefixOf)-import Data.Data-import 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 "<built-in>" #-}-{-# LINE 19 "<built-in>" #-}-{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-}-------------------{-# LINE 20 "<built-in>" #-}-{-# 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.-
− dist/build/Camfort/Specification/Units/Parser.hs
@@ -1,766 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}--- -*- Mode: Haskell -*---{-# LANGUAGE DeriveDataTypeable #-}-module Camfort.Specification.Units.Parser ( unitParser- , UnitStatement(..)- , UnitOfMeasure(..)- , UnitPower(..)- ) where--import Camfort.Analysis.CommentAnnotator-import Data.Data-import Data.List-import Data.Char (isLetter, isNumber, isAlphaNum, toLower)-import qualified Data.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 "<built-in>" #-}-{-# LINE 19 "<built-in>" #-}-{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-}-------------------{-# LINE 20 "<built-in>" #-}-{-# 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.-
− dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs
@@ -1,980 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}--- -*- Mode: Haskell -*--{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}-module Camfort.Specification.Stencils.Grammar-( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where--import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace)-import Data.List (intersect, sort, isPrefixOf)-import Data.Data-import 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 "<built-in>" #-}-{-# LINE 19 "<built-in>" #-}-{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-}-------------------{-# LINE 20 "<built-in>" #-}-{-# 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.-
− dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs
@@ -1,766 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}--- -*- Mode: Haskell -*---{-# LANGUAGE DeriveDataTypeable #-}-module Camfort.Specification.Units.Parser ( unitParser- , UnitStatement(..)- , UnitOfMeasure(..)- , UnitPower(..)- ) where--import Camfort.Analysis.CommentAnnotator-import Data.Data-import Data.List-import Data.Char (isLetter, isNumber, isAlphaNum, toLower)-import qualified Data.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 "<built-in>" #-}-{-# LINE 19 "<built-in>" #-}-{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-}-------------------{-# LINE 20 "<built-in>" #-}-{-# 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.-
src/Camfort/Analysis/Annotations.hs view
@@ -86,6 +86,11 @@ link ann (b@(F.BlStatement _ _ _ F.StDeclaration {})) = onPrev (\ ann -> ann { unitBlock = Just b }) ann link ann b = ann+ linkPU ann (pu@(F.PUFunction {})) =+ onPrev (\ ann -> ann { unitPU = Just pu }) ann+ linkPU ann (pu@(F.PUSubroutine {})) =+ onPrev (\ ann -> ann { unitPU = Just pu }) ann+ linkPU ann b = ann -- Helpers for transforming the 'previous' annotation onPrev :: (a -> a) -> FA.Analysis a -> FA.Analysis a
src/Camfort/Analysis/CommentAnnotator.hs view
@@ -52,22 +52,28 @@ -> ProgramFile a -> Logger (ProgramFile a) annotateComments parse pf = do- pf' <- transformBiM (writeAST parse) pf- return $ descendBi linkBlocks pf'+ pf' <- transformBiM (writeASTProgramUnits parse) =<< transformBiM (writeASTBlocks parse) pf+ return . descendBi linkProgramUnits $ descendBi linkBlocks pf' where- writeAST :: (Data a, ASTEmbeddable a ast)- => AnnotationParser ast -> Block a -> Logger (Block a)- writeAST parse b@(BlComment a srcSpan comment) =+ writeASTBlocks :: (Data a, ASTEmbeddable a ast) => AnnotationParser ast -> Block a -> Logger (Block a)+ writeASTBlocks parse b@(BlComment a srcSpan (Comment comment)) = case parse comment of Right ast -> return $ setAnnotation (annotateWithAST a ast) b Left NotAnnotation -> return b Left (ProbablyAnnotation err) -> parserWarn srcSpan err >> return b- writeAST _ b = return b+ writeASTBlocks _ b = return b + writeASTProgramUnits :: (Data a, ASTEmbeddable a ast) => AnnotationParser ast -> ProgramUnit a -> Logger (ProgramUnit a)+ writeASTProgramUnits parse pu@(PUComment a srcSpan (Comment comment)) =+ case parse comment of+ Right ast -> return $ setAnnotation (annotateWithAST a ast) pu+ Left NotAnnotation -> return pu+ Left (ProbablyAnnotation err) -> parserWarn srcSpan err >> return pu+ writeASTProgramUnits _ pu = return pu+ {-| Link all comment blocks to first non-comment block in the list. |-} linkBlocks :: (Data a, Linkable a) => [ Block a ] -> [ Block a ] linkBlocks [ ] = [ ]- --linkBlocks [ x ] = [ x ] linkBlocks blocks@(b:bs) | BlComment{} <- b = let (comments, rest) = span isComment blocks@@ -78,13 +84,29 @@ | otherwise = (descendBi linkBlocks b) : linkBlocks bs where isComment BlComment{} = True- isComment _ = False+ isComment _ = False + {-| Link all comment 'program units' to first non-comment program unit in the list. |-}+ linkProgramUnits :: (Data a, Linkable a) => [ ProgramUnit a ] -> [ ProgramUnit a ]+ linkProgramUnits [ ] = [ ]+ linkProgramUnits programUnits@(pu:pus)+ | PUComment{} <- pu =+ let (comments, rest) = span isComment programUnits+ in if null rest -- Does the group of blocks end with comments+ then comments+ else let (procPUs, unprocPUs) = linkMultiplePUs comments rest+ in procPUs ++ linkProgramUnits unprocPUs+ | otherwise = (descendBi linkProgramUnits pu) : linkProgramUnits pus+ where+ isComment PUComment{} = True+ isComment _ = False+ class ASTEmbeddable a ast where annotateWithAST :: a -> ast -> a class Linkable a where- link :: a -> Block a -> a+ link :: a -> Block a -> a+ linkPU :: a -> ProgramUnit a -> a -- Given a list of comments and a list of non-comment blocks which occur -- afterward in the code, then link them together (either forward or backward)@@ -96,6 +118,10 @@ linkMultiple :: [Block a] -> [Block a] -> ([Block a], [Block a]) linkMultiple comments blocks = (map (fmap $ flip link (head blocks)) comments, blocks)++ linkMultiplePUs :: [ProgramUnit a] -> [ProgramUnit a] -> ([ProgramUnit a], [ProgramUnit a])+ linkMultiplePUs comments pus = -- trace (show (map (fmap (const ())) comments, (map (fmap (const ())) pus))) $+ (map (fmap $ flip linkPU (head pus)) comments, pus) parserWarn :: SrcSpan -> String -> Logger () parserWarn srcSpan err = tell [ "Error " ++ show srcSpan ++ ": " ++ err ]
src/Camfort/Functionality.hs view
@@ -24,49 +24,43 @@ module Camfort.Functionality where -import System.Console.GetOpt-import System.Directory-import System.Environment import System.FilePath-import System.IO+import Control.Monad -import Data.Monoid import Data.Generics.Uniplate.Operations import Data.Data-import Data.List (foldl', intercalate)-import qualified Debug.Trace as D+import Data.Binary+import Data.Text (pack, unpack, split) -import Camfort.Analysis.Annotations import Camfort.Analysis.Simple+import Camfort.Transformation.DataTypeIntroduction import Camfort.Transformation.DeadCode import Camfort.Transformation.CommonBlockElim import Camfort.Transformation.EquivalenceElim import qualified Camfort.Specification.Units as LU-import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad -import Camfort.Helpers.Syntax import Camfort.Helpers-import Camfort.Output import Camfort.Input import qualified Language.Fortran.Parser.Any as FP-import qualified Language.Fortran.AST as F-import Language.Fortran.Analysis.Renaming- (renameAndStrip, analyseRenames, unrename, NameMap)-import Language.Fortran.Analysis(initAnalysis)+import Language.Fortran.Util.ModFile import qualified Camfort.Specification.Stencils as Stencils+import qualified Data.Map.Strict as M -- CamFort optional flags data Flag = Version | Input String | Output String | Excludes String+ | IncludeDir String | Literals LiteralsOpt | StencilInferMode Stencils.InferMode | Doxygen | Ford+ | FVersion String+ | RefactorInPlace | Debug deriving (Data, Show, Eq) type Options = [Flag]@@ -75,8 +69,12 @@ instance Default String where defaultValue = "" getExcludes :: Options -> String-getExcludes = getOption+getExcludes opts = head ([ e | Excludes e <- universeBi opts ] ++ [""]) +-- Separates the comma-separated filenames+getExcludedFiles :: Options -> [String]+getExcludedFiles = map unpack . split (==',') . pack . getExcludes+ -- * Wrappers on all of the features ast d excludes _ _ = do xs <- readParseSrcDir d excludes@@ -94,7 +92,6 @@ common inSrc excludes outSrc _ = do putStrLn $ "Refactoring common blocks in '" ++ inSrc ++ "'" isDir <- isDirectory inSrc- let dir = if isDir then inSrc ++ "/" else "" let rfun = commonElimToModules (takeDirectory outSrc ++ "/") report <- doRefactorAndCreate rfun inSrc excludes outSrc putStrLn report@@ -104,38 +101,90 @@ report <- doRefactor (mapM refactorEquivalences) inSrc excludes outSrc putStrLn report +datatypes inSrc excludes outSrc _ = do+ putStrLn $ "Introducing derived data types in '" ++ inSrc ++ "'"+ report <- doRefactor dataTypeIntro inSrc excludes outSrc+ putStrLn report+ {- Units feature -}-optsToUnitOpts :: [Flag] -> UnitOpts-optsToUnitOpts = foldl' (\ o f -> case f of Literals m -> o { uoLiterals = m }- Debug -> o { uoDebug = True }- _ -> o) unitOpts0+optsToUnitOpts :: [Flag] -> IO UnitOpts+optsToUnitOpts = foldM (\ o f -> do+ case f of+ Literals m -> return $ o { uoLiterals = m }+ Debug -> return $ o { uoDebug = True }+ IncludeDir d -> do+ -- Figure out the camfort mod files and parse them.+ modFileNames <- filter isModFile `fmap` rGetDirContents' d+ assocList <- forM modFileNames $ \ modFileName -> do+ eResult <- decodeFileOrFail (d ++ "/" ++ modFileName) -- FIXME, directory manipulation+ case eResult of+ Left (offset, msg) -> do+ putStrLn $ modFileName ++ ": Error at offset " ++ show offset ++ ": " ++ msg+ return (modFileName, emptyModFile)+ Right modFile -> do+ putStrLn $ modFileName ++ ": successfully parsed precompiled file."+ return (modFileName, modFile)+ return $ o { uoModFiles = M.fromList assocList `M.union` uoModFiles o }+ _ -> return o+ ) unitOpts0 -unitsCheck inSrc excludes outSrc opt = do+getModFiles :: [Flag] -> IO ModFiles+getModFiles = foldM (\ modFiles f -> do+ case f of+ IncludeDir d -> do+ -- Figure out the camfort mod files and parse them.+ modFileNames <- filter isModFile `fmap` rGetDirContents' d+ addedModFiles <- forM modFileNames $ \ modFileName -> do+ eResult <- decodeFileOrFail (d ++ "/" ++ modFileName) -- FIXME, directory manipulation+ case eResult of+ Left (offset, msg) -> do+ putStrLn $ modFileName ++ ": Error at offset " ++ show offset ++ ": " ++ msg+ return emptyModFile+ Right modFile -> do+ putStrLn $ modFileName ++ ": successfully parsed precompiled file."+ return modFile+ return $ addedModFiles ++ modFiles+ _ -> return modFiles+ ) emptyModFiles++isModFile = (== modFileSuffix) . fileExt++unitsCheck inSrc excludes _ opt = do putStrLn $ "Checking units for '" ++ inSrc ++ "'"- let rfun = concatMap (LU.checkUnits (optsToUnitOpts opt))- doAnalysisReport rfun putStrLn inSrc excludes+ uo <- optsToUnitOpts opt+ let rfun = concatMap (LU.checkUnits uo)+ doAnalysisReportWithModFiles rfun putStrLn inSrc excludes =<< getModFiles opt -unitsInfer inSrc excludes outSrc opt = do+unitsInfer inSrc excludes _ opt = do putStrLn $ "Inferring units for '" ++ inSrc ++ "'"- let rfun = concatMap (LU.inferUnits (optsToUnitOpts opt))- doAnalysisReport rfun putStrLn inSrc excludes+ uo <- optsToUnitOpts opt+ let rfun = concatMap (LU.inferUnits uo)+ doAnalysisReportWithModFiles rfun putStrLn inSrc excludes =<< getModFiles opt +unitsCompile inSrc excludes outSrc opt = do+ putStrLn $ "Compiling units for '" ++ inSrc ++ "'"+ uo <- optsToUnitOpts opt+ let rfun = LU.compileUnits uo+ putStrLn =<< doCreateBinary rfun inSrc excludes outSrc =<< getModFiles opt+ unitsSynth inSrc excludes outSrc opt = do putStrLn $ "Synthesising units for '" ++ inSrc ++ "'" let marker | Doxygen `elem` opt = '<' | Ford `elem` opt = '!' | otherwise = '='+ uo <- optsToUnitOpts opt let rfun =- mapM (LU.synthesiseUnits (optsToUnitOpts opt) marker)- report <- doRefactor rfun inSrc excludes outSrc+ mapM (LU.synthesiseUnits uo marker)+ report <- doRefactorWithModFiles rfun inSrc excludes outSrc =<< getModFiles opt putStrLn report -unitsCriticals inSrc excludes outSrc opt = do+unitsCriticals inSrc excludes _ opt = do putStrLn $ "Suggesting variables to annotate with unit specifications in '" ++ inSrc ++ "'"- let rfun = mapM (LU.inferCriticalVariables (optsToUnitOpts opt))- doAnalysisReport rfun (putStrLn . fst) inSrc excludes+ uo <- optsToUnitOpts opt+ let rfun = mapM (LU.inferCriticalVariables uo)+ doAnalysisReportWithModFiles rfun (putStrLn . fst) inSrc excludes =<< getModFiles opt {- Stencils feature -} stencilsCheck inSrc excludes _ _ = do
src/Camfort/Helpers.hs view
@@ -17,6 +17,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} module Camfort.Helpers where@@ -24,8 +25,8 @@ import GHC.Generics import Data.Generics.Zipper import Data.Generics.Aliases-import Data.Generics.Str import Data.Generics.Uniplate.Operations+import qualified Data.Generics.Str as Str import Data.Data import Data.Maybe import Data.Monoid@@ -179,3 +180,32 @@ zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a) zfmap f x = zeverywhere (mkT f) x++-- Data-generic generic descend but processes children in reverse order+-- (good for backwards analysis)+data Reverse f a = Reverse { unwrapReverse :: f a }++instance Functor (Reverse Str.Str) where+ fmap f (Reverse s) = Reverse (fmap f s)++instance Foldable (Reverse Str.Str) where+ foldMap f (Reverse x) = foldMap f x++instance Traversable (Reverse Str.Str) where+ traverse f (Reverse Str.Zero) = pure $ Reverse Str.Zero+ traverse f (Reverse (Str.One x)) = (Reverse . Str.One) <$> f x+ traverse f (Reverse (Str.Two x y)) = (\y x -> Reverse $ Str.Two x y)+ <$> (fmap unwrapReverse . traverse f . Reverse $ y)+ <*> (fmap unwrapReverse . traverse f . Reverse $ x)+++-- Custom version of descend that process tree in reverse order+descendReverseM :: (Data on, Monad m, Uniplate on) => (on -> m on) -> on -> m on+descendReverseM f x =+ liftM generate . fmap unwrapReverse . traverse f . Reverse $ current+ where (current, generate) = uniplate x++descendBiReverseM :: (Data from, Data to, Monad m, Biplate from to) => (to -> m to) -> from -> m from+descendBiReverseM f x =+ liftM generate . fmap unwrapReverse . traverse f . Reverse $ current+ where (current, generate) = biplate x
src/Camfort/Helpers/Vec.hs view
@@ -23,11 +23,16 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} module Camfort.Helpers.Vec where -import Data.Data+import Prelude hiding (length, zipWith, take, drop, (!!)) +import Data.Proxy++import Unsafe.Coerce+ data Nat = Z | S Nat -- Indexed natural number type@@ -49,6 +54,7 @@ class IsNatural (n :: Nat) where fromNat :: Proxy n -> Int+ instance IsNatural Z where fromNat Proxy = 0 instance IsNatural n => IsNatural (S n) where@@ -59,41 +65,123 @@ Nil :: Vec Z a Cons :: a -> Vec n a -> Vec (S n) a -lengthV :: Vec n a -> Int-lengthV Nil = 0-lengthV (Cons x xs) = 1 + lengthV xs+length :: Vec n a -> Int+length Nil = 0+length (Cons x xs) = 1 + length xs -vmap :: (a -> b) -> Vec n a -> Vec n b-vmap f Nil = Nil-vmap f (Cons x xs) = Cons (f x) (vmap f xs)+lengthN :: Vec n a -> Natural n+lengthN Nil = Zero+lengthN (Cons x xs) = Succ $ lengthN xs instance Functor (Vec n) where- fmap = vmap+ fmap f Nil = Nil+ fmap f (Cons x xs) = Cons (f x) (fmap f xs)+ deriving instance Eq a => Eq (Vec n a)+ instance Ord a => Ord (Vec n a) where Nil <= _ = True (Cons x xs) <= (Cons y ys) | xs == ys = x <= y | otherwise = xs <= ys instance Show a => Show (Vec n a) where- show = showV+ show xs = "<" ++ showV xs ++ ">"+ where+ showV :: forall n a . Show a => Vec n a -> String+ showV Nil = ""+ showV (Cons x Nil) = show x+ showV (Cons x xs) = show x ++ "," ++ showV xs -showV :: Show a => Vec n a -> String-showV xs = "<" ++ showV' xs ++ ">"+instance Foldable (Vec n) where+ foldr _ acc Nil = acc+ foldr f acc (Cons x xs) = foldr f (f x acc) xs++zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c+zipWith f Nil Nil = Nil+zipWith f (Cons x xs) (Cons y ys) = Cons (f x y) (zipWith f xs ys)++zip :: Vec n a -> Vec n b -> Vec n (a,b)+zip = zipWith (,)++findIndex :: (a -> Bool) -> Vec n a -> Maybe Int+findIndex = go 0 where- showV' :: Show a => Vec n a -> String- showV' Nil = ""- showV' (Cons x Nil) = show x- showV' (Cons x xs) = show x ++ "," ++ showV' xs+ go :: Int -> (a -> Bool) -> Vec n a -> Maybe Int+ go _ _ Nil = Nothing+ go acc p (Cons x xs)+ | p x = Just acc+ | otherwise = go (acc + 1) p xs -type family Max (n :: Nat) (m :: Nat) :: Nat where- Max Z Z = Z- Max Z m = m- Max m Z = m- Max (S n) (S m) = S (Max n m)+(!!) :: Vec n a -> Int -> a+Cons x v' !! 0 = x+Cons _ v' !! n = v' !! (n - 1) -zipVec :: Vec m Int -> Vec n Int -> (Vec (Max n m) Int, Vec (Max n m) Int)-zipVec Nil Nil = (Nil, Nil)-zipVec Nil xs = (fmap (const 0) xs, xs)-zipVec xs Nil = (xs, fmap (const 0) xs)-zipVec (Cons x xs) (Cons y ys)- = (Cons x xs', Cons y ys') where (xs', ys') = zipVec xs ys+replace :: Int -> a -> Vec n a -> Vec n a+replace 0 a (Cons x xs) = Cons a xs+replace n a (Cons x xs) = Cons x (replace (n-1) a xs)+replace _ _ Nil = error "Found asymmetry is beyond the limits."++-- Equality type+data EqT a b where+ ReflEq :: EqT a a++data ExistsEqT t n where+ ExistsEqT :: EqT (t m) n -> ExistsEqT t n++-- Lists existentially quanitify over a vector's size : Exists n . Vec n a+data VecBox a where+ VecBox :: Vec n a -> VecBox a++fromList :: [a] -> VecBox a+fromList = foldr (\x (VecBox xs) -> VecBox (Cons x xs)) (VecBox Nil)++toList :: Vec n a -> [ a ]+toList Nil = [ ]+toList (Cons x xs) = x : toList xs++-- | Apply length preserving list operation.+applyListOp :: ([ a ] -> [ a ]) -> Vec n a -> Vec n a+applyListOp f v =+ case fromList . f . toList $ v of+ VecBox v' ->+ case proveEqSize v v' of+ Just ReflEq -> v'+ Nothing -> error "List operation was not length preserving."++proveEqSize :: Vec n a -> Vec m b -> Maybe (EqT m n)+proveEqSize Nil Nil = return ReflEq+proveEqSize (Cons _ xs) (Cons _ ys) = do+ ReflEq <- proveEqSize xs ys+ return ReflEq+proveEqSize _ _ = Nothing++proveNonEmpty :: Vec n a -> Maybe (ExistsEqT S n)+proveNonEmpty v =+ case v of+ Nil -> Nothing+ (Cons x xs) -> Just $ ExistsEqT ReflEq++hasSize :: Vec m a -> Natural n -> Maybe (EqT m n)+hasSize Nil Zero = return ReflEq+hasSize (Cons _ xs) (Succ n) = do+ ReflEq <- xs `hasSize` n+ return ReflEq+hasSize _ _ = Nothing++{- Vector list repreentation where the size 'n' is existential quantified -}+data VecList a where VL :: [Vec n a] -> VecList a++-- pre-condition: the input is a 'rectangular' list of lists (i.e. all internal+-- lists have the same size)+fromLists :: forall a . [[a]] -> VecList a+fromLists [] = VL ([] :: [Vec Z a])+fromLists (xs:xss) = consList (fromList xs) (fromLists xss)+ where+ consList :: VecBox a -> VecList a -> VecList a+ consList (VecBox vec) (VL []) = VL [vec]+ consList (VecBox vec) (VL xs) = -- Force the pre-condition equality+ case preCondition vec xs of+ ReflEq -> VL (vec : xs)+ where -- At the moment the pre-condition is 'assumed', and therefore+ -- force used unsafeCoerce: TODO, rewrite+ preCondition :: forall n n1 a . Vec n a -> [Vec n1 a] -> EqT n n1+ preCondition xs x = unsafeCoerce ReflEq
src/Camfort/Input.hs view
@@ -14,7 +14,7 @@ limitations under the License. -} -{-+{-2 Handles input of code base (files and directories) and passing them into the core functionality@@ -32,9 +32,12 @@ import qualified Language.Fortran.Parser.Any as FP import qualified Language.Fortran.AST as F+import Language.Fortran.Util.ModFile import qualified Data.ByteString.Char8 as B import Data.Data+import Data.Char (toUpper)+import Data.Maybe import Data.Generics.Uniplate.Operations import Data.List (foldl', nub, (\\), elemIndices, intercalate) import Data.Monoid@@ -92,6 +95,23 @@ sFun report ---- +doAnalysisReportWithModFiles :: ([(Filename, F.ProgramFile A)] -> r)+ -> (r -> IO out)+ -> FileOrDir+ -> [Filename]+ -> ModFiles+ -> IO out+doAnalysisReportWithModFiles rFun sFun inSrc excludes mods = do+ if excludes /= [] && excludes /= [""]+ then putStrLn $ "Excluding " ++ intercalate "," excludes+ ++ " from " ++ inSrc ++ "/"+ else return ()+ ps <- readParseSrcDirWithModFiles inSrc excludes mods+----+ let report = rFun (map (\(f, inp, ast) -> (f, ast)) ps)+ sFun report+----+ {-| Performs a refactoring provided by its first parameter, on the directory of the second, excluding files listed by third, output to the directory specified by the fourth parameter -}@@ -112,6 +132,23 @@ outputFiles inSrc outSrc outputs return report +doRefactorWithModFiles :: ([(Filename, F.ProgramFile A)] -> (String, [(Filename, F.ProgramFile A)]))+ -> FileOrDir+ -> [Filename]+ -> FileOrDir+ -> ModFiles+ -> IO String+doRefactorWithModFiles rFun inSrc excludes outSrc mods = do+ if excludes /= [] && excludes /= [""]+ then putStrLn $ "Excluding " ++ intercalate "," excludes+ ++ " from " ++ inSrc ++ "/"+ else return ()+ ps <- readParseSrcDirWithModFiles inSrc excludes mods+ let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)+ let outputs = reassociateSourceText ps ps'+ outputFiles inSrc outSrc outputs+ return report+ -- For refactorings which create some files too -- i.e., for refactoring functions that return a -- pair of lists of filename/program file pairs is@@ -132,6 +169,40 @@ outputFiles inSrc outSrc outputs' return report +-- For refactorings which create some files too+-- i.e., for refactoring functions that return a+-- pair of lists of filename/program file pairs is+type FileProgram = (Filename, F.ProgramFile A)+doRefactorAndCreateBinary :: ([FileProgram] -> (String, [FileProgram], [(Filename, B.ByteString)]))+ -> FileOrDir -> [Filename] -> FileOrDir -> IO String+doRefactorAndCreateBinary rFun inSrc excludes outSrc = do+ if excludes /= [] && excludes /= [""]+ then putStrLn $ "Excluding " ++ intercalate "," excludes+ ++ " from " ++ inSrc ++ "/"+ else return ()+ ps <- readParseSrcDir inSrc excludes+ let (report, ps', bins) = rFun (map (\ (f, inp, ast) -> (f, ast)) ps)+ let outputs = reassociateSourceText ps ps'+ outputFiles inSrc outSrc outputs+ outputFiles inSrc outSrc bins+ return report++doCreateBinary :: ([FileProgram] -> (String, [(Filename, B.ByteString)]))+ -> FileOrDir+ -> [Filename]+ -> FileOrDir+ -> ModFiles+ -> IO String+doCreateBinary rFun inSrc excludes outSrc mods = do+ if excludes /= [] && excludes /= [""]+ then putStrLn $ "Excluding " ++ intercalate "," excludes+ ++ " from " ++ inSrc ++ "/"+ else return ()+ ps <- readParseSrcDirWithModFiles inSrc excludes mods+ let (report, bins) = rFun (map (\ (f, inp, ast) -> (f, ast)) ps)+ outputFiles inSrc outSrc bins+ return report+ reassociateSourceText :: [(Filename, SourceText, a)] -> [(Filename, F.ProgramFile Annotation)] -> [(Filename, SourceText, F.ProgramFile Annotation)]@@ -155,14 +226,46 @@ let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes' else return [inp]- mapM readParseSrcFile files+ mapMaybeM readParseSrcFile files +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+mapMaybeM f = fmap catMaybes . (mapM f)++readParseSrcDirWithModFiles :: FileOrDir+ -> [Filename]+ -> ModFiles+ -> IO [(Filename, SourceText, F.ProgramFile A)]+readParseSrcDirWithModFiles inp excludes mods = do+ isdir <- isDirectory inp+ files <- if isdir+ then do+ files <- rGetDirContents inp+ -- Compute alternate list of excludes with the+ -- the directory appended+ let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes+ return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes'+ else return [inp]+ mapMaybeM (readParseSrcFileWithModFiles mods) files+ {-| Read a specific file, and parse it -}-readParseSrcFile :: Filename -> IO (Filename, SourceText, F.ProgramFile A)+readParseSrcFile :: Filename+ -> IO (Maybe (Filename, SourceText, F.ProgramFile A)) readParseSrcFile f = do inp <- flexReadFile f- let ast = FP.fortranParser inp f- return (f, inp, fmap (const unitAnnotation) ast)+ let result = FP.fortranParserWithModFiles [] inp f+ case result of+ Right ast -> return $ Just (f, inp, fmap (const unitAnnotation) ast)+ Left error -> (putStrLn $ show error) >> return Nothing++readParseSrcFileWithModFiles :: ModFiles+ -> Filename+ -> IO (Maybe (Filename, SourceText, F.ProgramFile A))+readParseSrcFileWithModFiles mods f = do+ inp <- flexReadFile f+ let result = FP.fortranParserWithModFiles mods inp f+ case result of+ Right ast -> return $ Just (f, inp, fmap (const unitAnnotation) ast)+ Left error -> (putStrLn $ show error) >> return Nothing ---- rGetDirContents :: FileOrDir -> IO [String]@@ -181,8 +284,23 @@ then return (x : xs') else return xs' +-- A version that lists all files, not just Fortran ones+rGetDirContents' :: FileOrDir -> IO [String]+rGetDirContents' d = do+ ds <- getDirectoryContents d+ fmap concat . mapM f $ ds \\ [".", ".."] -- remove '.' and '..' entries+ where+ f x = do+ g <- doesDirectoryExist (d ++ "/" ++ x)+ if g then do+ x' <- rGetDirContents (d ++ "/" ++ x)+ return $ map (\ y -> x ++ "/" ++ y) x'+ else return [x]+ {-| predicate on which fileextensions are Fortran files -}-isFortran x = fileExt x `elem` [".f", ".f90", ".f77", ".cmn", ".inc"]+isFortran x = fileExt x `elem` (exts ++ extsUpper)+ where exts = [".f", ".f90", ".f77", ".cmn", ".inc"]+ extsUpper = map (map toUpper) exts {-| extract a filename's extension -} fileExt x = let ix = elemIndices '.' x
src/Camfort/Output.hs view
@@ -105,11 +105,11 @@ instance OutputFiles (Filename, SourceText) where mkOutputText _ (_, output) = output outputFile (f, _) = f- isNewFile (_, inp) = B.null inp+ isNewFile _ = True -- When there is a file to be reprinted (for refactoring) instance OutputFiles (Filename, SourceText, F.ProgramFile Annotation) where- mkOutputText f' (f, input, ast@(F.ProgramFile (F.MetaInfo version) _ _)) =+ mkOutputText f' (f, input, ast@(F.ProgramFile (F.MetaInfo version _) _)) = -- If we are create a file, call the pretty printer directly if B.null input then B.pack $ PP.pprintAndRender version ast (Just 0)@@ -125,19 +125,48 @@ refactoring :: Typeable a => FPM.FortranVersion -> a -> SourceText -> StateT FU.Position Identity (SourceText, Bool)-refactoring v z inp = catchAll inp `extQ` refactorings inp $ z+refactoring v z inp = ((catchAll inp `extQ` refactoringsForProgramUnits v inp) `extQ` refactoringsForBlocks v inp) $ z where catchAll :: SourceText -> a -> StateT FU.Position Identity (SourceText, Bool) catchAll _ _ = return (B.empty, False)- refactorings inp z =- mapStateT (\n -> Identity $ n `evalState` 0) (refactorBlocks v inp z) +refactoringsForProgramUnits :: FPM.FortranVersion+ -> SourceText+ -> F.ProgramUnit Annotation+ -> StateT FU.Position Identity (SourceText, Bool)+refactoringsForProgramUnits v inp z =+ mapStateT (\n -> Identity $ n `evalState` 0) (refactorProgramUnits v inp z)++refactorProgramUnits :: FPM.FortranVersion+ -> SourceText+ -> F.ProgramUnit Annotation+ -> StateT FU.Position (State Int) (SourceText, Bool)+-- Output comments+refactorProgramUnits v inp e@(F.PUComment ann span (F.Comment comment)) = do+ cursor <- get+ if pRefactored ann+ then let (FU.SrcSpan lb ub) = span+ lb' = leftOne lb+ (p0, _) = takeBounds (cursor, lb') inp+ nl = if null comment then B.empty else B.pack "\n"+ in (put ub >> return (B.concat [p0, B.pack comment, nl], True))+ else return (B.empty, False)+ where leftOne (FU.Position f c l) = FU.Position f (c-1) (l-1)+refactorProgramUnits _ _ _ = return (B.empty, False)++refactoringsForBlocks :: FPM.FortranVersion+ -> SourceText+ -> F.Block Annotation+ -> StateT FU.Position Identity (SourceText, Bool)+refactoringsForBlocks v inp z =+ mapStateT (\n -> Identity $ n `evalState` 0) (refactorBlocks v inp z)+ refactorBlocks :: FPM.FortranVersion -> SourceText -> F.Block Annotation -> StateT FU.Position (State Int) (SourceText, Bool) -- Output comments-refactorBlocks v inp e@(F.BlComment ann span comment) = do+refactorBlocks v inp e@(F.BlComment ann span (F.Comment comment)) = do cursor <- get if pRefactored ann then let (FU.SrcSpan lb ub) = span
src/Camfort/Specification/Stencils.hs view
@@ -17,31 +17,18 @@ module Camfort.Specification.Stencils (InferMode, infer, check, synth) where -import Control.Monad.State.Lazy-import Control.Monad.Writer hiding (Product)--import qualified Camfort.Specification.Stencils.Grammar as Gram import Camfort.Specification.Stencils.CheckFrontend hiding (LogLine) import Camfort.Specification.Stencils.InferenceFrontend-import Camfort.Specification.Stencils.Syntax import Camfort.Specification.Stencils.Synthesis-import Camfort.Analysis.CommentAnnotator import Camfort.Analysis.Annotations -- These two are redefined here for ForPar ASTs-import Camfort.Helpers hiding (lineCol, spanLineCol)+import Camfort.Helpers import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Types as FAT import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.BBlocks as FAB-import qualified Language.Fortran.Analysis.DataFlow as FAD-import qualified Language.Fortran.Util.Position as FU -import Data.Generics.Uniplate.Operations-import Data.Data-import qualified Data.Map as M-import Data.Maybe import Data.List --------------------------------------------------@@ -84,7 +71,7 @@ synthPF :: InferMode -> Char -> Filename -> F.ProgramFile Annotation -> (String, F.ProgramFile Annotation)-synthPF mode marker filename pf =+synthPF _ marker _ pf = -- Append filename to any outputs ("", fmap FA.prevAnnotation pf'') where
src/Camfort/Specification/Stencils/Annotation.hs view
@@ -21,12 +21,10 @@ import Camfort.Analysis.Annotations import Camfort.Analysis.CommentAnnotator-import Camfort.Specification.Stencils.Syntax import qualified Camfort.Specification.Stencils.Grammar as Gram import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import Debug.Trace {- *** Routines for associating annotations to ASTs -} @@ -41,3 +39,4 @@ link ann (b@(F.BlStatement _ _ _ (F.StExpressionAssign {}))) = onPrev (\ann -> ann { stencilBlock = Just b }) ann link ann b = ann+ linkPU ann pu = ann
src/Camfort/Specification/Stencils/CheckBackend.hs view
@@ -14,44 +14,16 @@ limitations under the License. -} -{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} module Camfort.Specification.Stencils.CheckBackend where -import Data.Data-import Data.Maybe-import Data.List-import Data.Generics.Uniplate.Operations-import Control.Monad.State.Lazy-import Control.Monad.Reader-import Control.Monad.Writer hiding (Product,Sum)--import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.Syntax import Camfort.Specification.Stencils.Model import qualified Camfort.Specification.Stencils.Grammar as SYN -import Camfort.Analysis.Annotations-import Camfort.Helpers.Vec--- These two are redefined here for ForPar ASTs-import Camfort.Helpers hiding (lineCol, spanLineCol)--import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Types as FAT-import qualified Language.Fortran.Analysis.Renaming as FAR-import qualified Language.Fortran.Analysis.BBlocks as FAB-import qualified Language.Fortran.Analysis.DataFlow as FAD--import Language.Fortran.Util.Position-import qualified Data.Map as M-import Data.Set hiding (map)- type ErrorMsg = String -- Class for functions converting from Grammar parse@@ -81,8 +53,8 @@ Just SYN.AtLeast -> Bound (Just s') Nothing Nothing -> Exact s' where- addLinearity Linear appr = Single appr- addLinearity NonLinear appr = Multiple appr+ addLinearity Linear appr = Once appr+ addLinearity NonLinear appr = Mult appr -- Convert region definitions into the DNF-form used internally instance SynToAst SYN.Region RegionSum where
src/Camfort/Specification/Stencils/CheckFrontend.hs view
@@ -14,9 +14,9 @@ limitations under the License. -} -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-} module Camfort.Specification.Stencils.CheckFrontend where @@ -25,17 +25,15 @@ import Control.Monad.State.Strict import Control.Monad.Writer.Strict hiding (Product) +import qualified Camfort.Helpers.Vec as V import Camfort.Specification.Stencils.CheckBackend+import qualified Camfort.Specification.Stencils.Consistency as C import qualified Camfort.Specification.Stencils.Grammar as Gram-import Camfort.Specification.Stencils.Annotation import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.InferenceFrontend hiding (LogLine)-import Camfort.Specification.Stencils.InferenceBackend-import Camfort.Specification.Stencils.Synthesis import Camfort.Specification.Stencils.Syntax import Camfort.Analysis.Annotations import Camfort.Analysis.CommentAnnotator-import Camfort.Helpers import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA@@ -46,7 +44,9 @@ import qualified Data.Map as M import Data.Maybe-import Data.List+import Algebra.Lattice (joins1)+import Data.Int+import qualified Data.Set as S -- Entry point stencilChecking :: FAR.NameMap -> F.ProgramFile (FA.Analysis A) -> [String]@@ -76,7 +76,7 @@ let ?nameMap = nameMap in descendBiM perProgramUnitCheck pf' -- Format output- let a@(_, output) = evalState (runWriterT results) (([], Nothing), ivmap)+ let (_, output) = evalState (runWriterT results) (([], Nothing), ivmap) tell $ pprint output type LogLine = (FU.SrcSpan, String)@@ -109,16 +109,42 @@ checkOffsetsAgainstSpec :: [(Variable, Multiplicity [[Int]])] -> [(Variable, Specification)] -> Bool-checkOffsetsAgainstSpec offsetMaps =- all (\(var1, Specification mult)->- all (\(var2, offsets) ->- var1 /= var2 || noAllInfinity offsets `consistent` mult) offsetMaps)- where- noAllInfinity (Single a) =- Single $ filter (not . all (== absoluteRep)) a- noAllInfinity (Multiple a) =- Multiple $ filter (not . all (== absoluteRep)) a+checkOffsetsAgainstSpec offsetMaps specMaps =+ flip all specToVecList $+ \case+ (spec, Once (V.VL vs)) -> spec `C.consistent` (Once . toUNF) vs == C.Consistent+ (spec, Mult (V.VL vs)) -> spec `C.consistent` (Mult . toUNF) vs == C.Consistent+ where+ toUNF :: [ V.Vec n Int64 ] -> UnionNF n Offsets+ toUNF = joins1 . map (return . fmap intToSubscript) + -- This function generates the special offsets subspace, subscript,+ -- that either had one element or is the whole set.+ intToSubscript :: Int64 -> Offsets+ intToSubscript i+ | fromIntegral i == absoluteRep = SetOfIntegers+ | otherwise = Offsets . S.singleton $ i++ -- Convert list of list of indices into vectors and wrap them around+ -- existential so that we don't have to prove they are all of the same+ -- size.+ specToVecList :: [ (Specification, Multiplicity (V.VecList Int64)) ]+ specToVecList = map (second (fmap V.fromLists)) specToIxs++ specToIxs :: [ (Specification, Multiplicity [ [ Int64 ] ]) ]+ specToIxs = pairWithFst specMaps (map (second toInt64) offsetMaps)++ toInt64 :: Multiplicity [ [ Int ] ] -> Multiplicity [ [ Int64 ] ]+ toInt64 = fmap (map (map fromIntegral))++ -- Given two maps for each key in the first map generate a set of+ -- tuples matching the (val,val') where val and val' are corresponding+ -- values from each set.+ pairWithFst :: Eq a => [ (a, b) ] -> [ (a, c) ] -> [ (b, c) ]+ pairWithFst [] _ = []+ pairWithFst ((key, val):xs) ys =+ map ((val,) . snd) (filter ((key ==) . fst) ys) ++ pairWithFst xs ys+ -- Go into the program units first and record the module name when -- entering into a module perProgramUnitCheck :: (?nameMap :: FAR.NameMap, ?flowsGraph :: FAD.FlowsGraph A)@@ -139,7 +165,7 @@ -- Comment contains a specification and an Associated block (Just (Right (Right specDecls)), Just block) -> case block of- s@(F.BlStatement ann span' _ (F.StExpressionAssign _ _ lhs rhs)) ->+ s@(F.BlStatement _ span' _ (F.StExpressionAssign _ _ lhs _)) -> case isArraySubscript lhs of Just subs -> do -- Create list of relative indices@@ -151,8 +177,8 @@ let relOffsets = correctNames . fst . runWriter $ genOffsets ivmap lhsN [s] let multOffsets = map (\relOffset -> case relOffset of- (var, (True, offsets)) -> (var, Multiple offsets)- (var, (False, offsets)) -> (var, Single offsets)) relOffsets+ (var, (True, offsets)) -> (var, Mult offsets)+ (var, (False, offsets)) -> (var, Once offsets)) relOffsets let expandedDecls = concatMap (\(vars,spec) -> map (flip (,) spec) vars) specDecls -- Model and compare the current and specified stencil specs@@ -160,7 +186,7 @@ then tell [ (span, "Correct.") ] else do let correctNames2 = map (first (map realName))- let inferred = correctNames2 . fst . runWriter $ genSpecifications ivmap lhsN [s]+ let inferred = correctNames2 . fst . fst . runWriter $ genSpecifications ivmap lhsN [s] let sp = replicate 8 ' ' tell [ (span, "Not well specified.\n"@@ -172,13 +198,12 @@ return b' Nothing -> return b' - (F.BlDo ann span _ _ _ mDoSpec body _) ->- -- Stub, maybe collect stencils inside 'do' block- return b'+ -- Stub, maybe collect stencils inside 'do' block+ F.BlDo{} -> return b' _ -> return b' _ -> return b' -perBlockCheck b@(F.BlDo ann span _ _ _ mDoSpec body _) = do+perBlockCheck b@(F.BlDo _ _ _ _ _ _ body _) = do -- descend into the body of the do-statement mapM_ (descendBiM perBlockCheck) body -- Remove any induction variable from the state
+ src/Camfort/Specification/Stencils/Consistency.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Camfort.Specification.Stencils.Consistency ( consistent+ , ConsistencyResult(..) ) where++import qualified Camfort.Helpers.Vec as V+import Camfort.Specification.Stencils.DenotationalSemantics+import Camfort.Specification.Stencils.Model+import Camfort.Specification.Stencils.Syntax++data ConsistencyResult =+ Consistent+ | Inconsistent String+ deriving (Eq, Show)++-- | This function checks multiplicity consistency and then delegates the+-- spatial consistency to |consistent'| function.+consistent :: forall n .+ Specification+ -> Multiplicity (UnionNF n Offsets)+ -> ConsistencyResult+consistent (Specification mult) observedIxs =+ -- First do the linearity check+ case (specModel, observedIxs) of+ (Mult a, Mult b) -> a `consistent'` b+ (Once a, Once b) -> a `consistent'` b+ (Once _, Mult _) ->Inconsistent+ "Specification is readOnce, but there are repeated indices."+ (Mult _, Once _) -> Inconsistent+ "Specification lacks readOnce, but the indices are inuque."+ where+ specModel :: Multiplicity (Approximation (UnionNF n (Interval Standard)))+ specModel =+ case sequence $ (sequence . fmap (regionsToIntervals nOfDims)) <$> mult of+ Right model -> model+ Left msg -> error msg++ nOfDims :: V.Natural n+ nOfDims = vecLength . peel $ observedIxs++-- | This is the actual consistency check using set comparison supplied in+-- the model.+consistent' :: Approximation (UnionNF n (Interval Standard))+ -> UnionNF n Offsets+ -> ConsistencyResult+consistent' (Exact unf) ixs =+ case unfCompare unf ixs of+ EQ -> Consistent+ LT ->+ Inconsistent "The specification covers a smaller area than the indices."+ GT ->+ Inconsistent "The specification covers a larger area than the indices."+consistent' (Bound (Just unf) Nothing) ixs =+ case unfCompare unf ixs of+ EQ -> Consistent+ LT -> Consistent+ GT -> Inconsistent $+ "There are indices covered by the lower bound specification, but " +++ "could not observed in the indices."+consistent' (Bound Nothing (Just unf)) ixs =+ case unfCompare unf ixs of+ EQ -> Consistent+ GT -> Consistent+ LT -> Inconsistent+ "There are indices outside the upper bound specification."+consistent' (Bound lb ub) ixs =+ case (cLower, cUpper) of+ (Consistent, Consistent) -> Consistent+ (Consistent, inconsistent) -> inconsistent+ (inconsistent, Consistent) -> inconsistent+ (Inconsistent{}, Inconsistent{}) -> Inconsistent+ "Neither the lower nor ther upper bound conform with the indices."+ where+ cLower = Bound lb Nothing `consistent'` ixs+ cUpper = Bound Nothing ub `consistent'` ixs
+ src/Camfort/Specification/Stencils/DenotationalSemantics.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}++module Camfort.Specification.Stencils.DenotationalSemantics ( intervalsToRegions+ , regionsToIntervals ) where++import Algebra.Lattice+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup as SG++import qualified Camfort.Helpers.Vec as V+import Camfort.Specification.Stencils.Model+import Camfort.Specification.Stencils.Syntax++-- preconditions:+-- 1. If finite interval, all have "lower bound <= 0 <= upper bound";+-- 2. No dimensionality of 0; (insured by dep. type);+-- 3. All unioned interval lists are of equal length (insured by dep. type).+intervalsToRegions :: UnionNF (V.S n) (Interval Standard)+ -> Either String Spatial+intervalsToRegions as = do+ sums <- mapM toProd+ . maximas -- Final subsumption optimisation+ . NE.toList+ . SG.sconcat+ . fmap asymmetryElim+ $ as+ return . Spatial . Sum $ sums+ where+ asymmetryElim :: V.Vec n (Interval a) -> UnionNF n (Interval a)+ asymmetryElim ints+ | Just ix <- findAsymmetry ints =+ case ints V.!! ix of+ IntervHoled m n p ->+ asymmetryElim (V.replace ix (IntervHoled m 0 p) ints) SG.<>+ asymmetryElim (V.replace ix (IntervHoled 0 n p) ints)+ | otherwise = return ints+ findAsymmetry =+ V.findIndex $ \case+ (IntervHoled m n _) -> m /= 0 && n /= 0 && m /= -n+ _ -> False++ toProd :: V.Vec n (Interval Standard) -> Either String RegionProd+ toProd ints =+ fmap Product $ mapM convert+ . filter (isNonInf . fst)+ $ zip (V.toList ints) [0..]++ isNonInf :: Interval Standard -> Bool+ isNonInf IntervInfinite = False+ isNonInf _ = True++ convert :: (Interval Standard, Int) -> Either String Region+ convert (IntervHoled 0 0 False, _) =+ Left "Empty set cannot be realised as a region."+ convert (IntervHoled 0 0 True, ix) = return $ Centered 0 (ix + 1) True+ convert (IntervHoled 0 m p, ix) = return $ Forward (fromIntegral m) (ix + 1) p+ convert (IntervHoled m 0 p, ix) = return $ Backward (fromIntegral $ -m) (ix + 1) p+ convert (IntervHoled m n p, ix)+ | m == -n = return $ Centered (fromIntegral n) (ix + 1) p+ | otherwise = Left $+ "Impossible: the lower bound is not negation of upper bound. " +++ "Should have been separated before."+ convert _ = Left "Infinite interval cannot be realised as a region."++regionsToIntervals :: forall n .+ V.Natural n+ -> Spatial+ -> Either String (UnionNF n (Interval Standard))+regionsToIntervals nOfDims (Spatial (Sum prods))+ | null prods = Left "Empty region sum"+ | otherwise =+ fmap SG.sconcat . sequence . fmap convert . NE.fromList $ prods+ where+ convert :: RegionProd -> Either String (UnionNF n (Interval Standard))+ convert (Product rs)+ | null rs = Left "Empty region product"+ | otherwise = Right $ meets1 . map convert' $ rs++ convert' r = return $ proto nOfDims $+ case r of+ Forward dep dim p -> (dim-1, IntervHoled 0 (fromIntegral dep) p)+ Backward dep dim p -> (dim-1, IntervHoled (- fromIntegral dep) 0 p)+ Centered dep dim p -> (dim-1, IntervHoled (- fromIntegral dep) (fromIntegral dep) p)++ proto :: forall n .+ V.Natural n+ -> (Int, Interval Standard)+ -> V.Vec n (Interval Standard)+ proto V.Zero _ = V.Nil+ proto (V.Succ n) (i, interv) = V.Cons+ (if i == 0 then interv else IntervInfinite)+ (proto n (i-1, interv))
− src/Camfort/Specification/Stencils/Grammar.hs
@@ -1,1275 +0,0 @@-{-# OPTIONS_GHC -w #-}--- -*- Mode: Haskell -*--{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}-module Camfort.Specification.Stencils.Grammar-( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where--import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace)-import Data.List (intersect, sort, isPrefixOf)-import Data.Data--import Debug.Trace--import Camfort.Analysis.CommentAnnotator-import Camfort.Specification.Stencils.Syntax (showL)-import Control.Applicative(Applicative(..))-import Control.Monad (ap)---- parser produced by Happy Version 1.19.5--data HappyAbsSyn - = HappyTerminal (Token)- | HappyErrorToken Int- | HappyAbsSyn4 (Specification)- | HappyAbsSyn5 ((String, Region))- | HappyAbsSyn6 (Region)- | HappyAbsSyn7 ((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 "<built-in>" #-}-{-# LINE 16 "<built-in>" #-}-{-# LINE 1 "/usr/local/lib/ghc-7.10.2/include/ghcversion.h" #-}-------------------{-# LINE 17 "<built-in>" #-}-{-# 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.-
src/Camfort/Specification/Stencils/Grammar.y view
@@ -22,8 +22,8 @@ stencil { TId "stencil" } region { TId "region" } readOnce { TId "readonce" }- reflexive { TId "reflexive" }- irreflexive { TId "irreflexive" }+ pointed { TId "pointed" }+ nonpointed { TId "nonpointed" } atMost { TId "atmost" } atLeast { TId "atleast" } dim { TId "dim" }@@ -56,7 +56,7 @@ : forward '(' REGION_ATTRS ')' { applyAttr Forward $3 } | backward '(' REGION_ATTRS ')' { applyAttr Backward $3 } | centered '(' REGION_ATTRS ')' { applyAttr Centered $3 }-| reflexive '(' dim '=' num ')' { Centered 0 (read $5) True }+| pointed '(' dim '=' num ')' { Centered 0 (read $5) True } | REGION '+' REGION { Or $1 $3 } | REGION '*' REGION { And $1 $3 } | '(' REGION ')' { $2 }@@ -87,7 +87,7 @@ DIM : dim '=' num { Dim $ read $3 } REFL :: { Bool }- : irreflexive { False }+ : nonpointed { False } SPECDEC :: { Spec } : APPROXMODS MOD REGION { Spatial ($1 ++ [$2]) $3 }
src/Camfort/Specification/Stencils/InferenceBackend.hs view
@@ -16,213 +16,141 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE LambdaCase #-} module Camfort.Specification.Stencils.InferenceBackend where -import Prelude hiding (sum)-import Data.Generics.Uniplate.Operations-import Data.List hiding (sum)-import Data.Data-import Control.Arrow ((***))-import Data.Function+import Data.List+import Data.Maybe+import Algebra.Lattice (joins1) import Camfort.Specification.Stencils.Model+import Camfort.Specification.Stencils.DenotationalSemantics import Camfort.Helpers-import Camfort.Helpers.Vec--import Debug.Trace-import Unsafe.Coerce+import qualified Camfort.Helpers.Vec as V import Camfort.Specification.Stencils.Syntax {- Spans are a pair of a lower and upper bound -}-type Span a = (a, a)-mkTrivialSpan a = (a, a) -inferFromIndices :: VecList Int -> Specification-inferFromIndices (VL ixs) = Specification $- case fromBool mult of- Linear -> Single $ inferCore ixs'- NonLinear -> Multiple $ inferCore ixs'- where- (ixs', mult) = hasDuplicates ixs---- Same as inferFromIndices but don't do any linearity checking--- (defaults to NonLinear). This is used when the front-end does--- the linearity check first as an optimimsation.-inferFromIndicesWithoutLinearity :: VecList Int -> Specification-inferFromIndicesWithoutLinearity (VL ixs) =- Specification . Multiple . inferCore $ ixs--inferCore :: (IsNatural n, Permutable n) => [Vec n Int] -> Approximation Spatial-inferCore = simplify . fromRegionsToSpec . inferMinimalVectorRegions--simplify :: Approximation Spatial -> Approximation Spatial-simplify = fmap simplifySpatial--simplifySpatial :: Spatial -> Spatial-simplifySpatial (Spatial (Sum ps)) = Spatial (Sum ps')- where ps' = order (reducor ps normaliseNoSort size)- order = sort . (map (Product . sort . unProd))- size :: [RegionProd] -> Int- size = foldr (+) 0 . map (length . unProd)---- Given a list, a list->list transofmer, a size function--- find the minimal transformed list by applying the transformer--- to every permutation of the list and when a smaller list is found--- iteratively apply to permutations on the smaller list-reducor :: [a] -> ([a] -> [a]) -> ([a] -> Int) -> [a]-reducor xs f size = reducor' (permutations xs)- where- reducor' [y] = f y- reducor' (y:ys) =- if (size y' < size y)- then reducor' (permutations y')- else reducor' ys- where y' = f y--fromRegionsToSpec :: IsNatural n => [Span (Vec n Int)] -> Approximation Spatial-fromRegionsToSpec = foldr (\x y -> sum (toSpecND x) y) zero+type Span a = (a, a) --- toSpecND converts an n-dimensional region into an exact--- spatial specification or a bound of spatial specifications-toSpecND :: Span (Vec n Int) -> Approximation Spatial-toSpecND = toSpecPerDim 1+spansToApproxSpatial :: [ Span (V.Vec (V.S n) Int) ]+ -> Either String (Approximation Spatial)+spansToApproxSpatial spans = sequence . fmap intervalsToRegions $ approxUnion where- -- convert the region one dimension at a time.- toSpecPerDim :: Int -> Span (Vec n Int) -> Approximation Spatial- toSpecPerDim d (Nil, Nil) = one- toSpecPerDim d (Cons l ls, Cons u us) =- prod (toSpec1D d l u) (toSpecPerDim (d + 1) (ls, us))---- toSpec1D takes a dimension identifier, a lower and upper bound of a region in--- that dimension, and builds the simple directional spec.-toSpec1D :: Dimension -> Int -> Int -> Approximation Spatial-toSpec1D dim l u- | l == absoluteRep || u == absoluteRep =- Exact $ Spatial (Sum [Product []])-- | l == 0 && u == 0 =- Exact $ Spatial (Sum [Product [Centered 0 dim True]])-- | l < 0 && u == 0 =- Exact $ Spatial (Sum [Product [Backward (abs l) dim True]])-- | l < 0 && u == (-1) =- Exact $ Spatial (Sum [Product [Backward (abs l) dim False]])-- | l == 0 && u > 0 =- Exact $ Spatial (Sum [Product [Forward u dim True]])+ approxVecs =+ toApprox . map (fmap absRepToInf . transposeVecInterval) $ spans+ approxUnion = fmap (optimise . joins1 . map return) approxVecs - | l == 1 && u > 0 =- Exact $ Spatial (Sum [Product [Forward u dim False]])+ toApprox :: [ V.Vec n (Interval Arbitrary) ]+ -> Approximation [ V.Vec n (Interval Standard) ]+ toApprox vs+ | parts <- (elongatedPartitions . map approxVec) vs =+ case parts of+ (orgs, []) -> Exact . map fromExact $ orgs+ ([], elongs) -> Bound Nothing (Just $ map upperBound elongs)+ (orgs, elongs) -> Bound (Just . map upperBound $ orgs)+ (Just . map upperBound $ orgs ++ elongs) - | l < 0 && u > 0 && (abs l == u) =- Exact $ Spatial (Sum [Product [Centered u dim True]])+ elongatedPartitions =+ partition $ \case { Exact{} -> True; Bound{} -> False } - | l < 0 && u > 0 && (abs l /= u) =- Exact $ Spatial (Sum [Product [Backward (abs l) dim True],- Product [Forward u dim True]])- -- Represents a non-contiguous region- | otherwise =- upperBound $ Spatial (Sum [Product- [if l > 0 then Forward u dim True else Backward (abs l) dim True]])+ -- TODO: DELETE AS SOON AS POSSIBLE+ absRepToInf :: Interval Arbitrary -> Interval Arbitrary+ absRepToInf interv@(IntervArbitrary a b)+ | fromIntegral a == absoluteRep = IntervInfiniteArbitrary+ | fromIntegral b == absoluteRep = IntervInfiniteArbitrary+ | otherwise = interv+ absRepToInf interv = interv -{- Normalise a span into the form (lower, upper) based on the first index -}-normaliseSpan :: Span (Vec n Int) -> Span (Vec n Int)-normaliseSpan (Nil, Nil)- = (Nil, Nil)-normaliseSpan (a@(Cons l1 ls1), b@(Cons u1 us1))- | l1 <= u1 = (a, b)- | otherwise = (b, a)+ transposeVecInterval :: Span (V.Vec n Int) -> V.Vec n (Interval Arbitrary)+ transposeVecInterval (us, vs) = V.zipWith IntervArbitrary us vs --- DEPRECATED-{- `spanBoundingBox` creates a span which is a bounding box over two spans -}-spanBoundingBox :: Span (Vec n Int) -> Span (Vec n Int) -> Span (Vec n Int)-spanBoundingBox a b = boundingBox' (normaliseSpan a) (normaliseSpan b)+mkTrivialSpan :: V.Vec n Int -> Span (V.Vec n Int)+mkTrivialSpan V.Nil = (V.Nil, V.Nil)+mkTrivialSpan (V.Cons x xs) =+ if x == absoluteRep+ then (V.Cons (-absoluteRep) ys, V.Cons absoluteRep zs)+ else (V.Cons x ys, V.Cons x zs) where- boundingBox' :: Span (Vec n Int) -> Span (Vec n Int) -> Span (Vec n Int)- boundingBox' (Nil, Nil) (Nil, Nil)- = (Nil, Nil)- boundingBox' (Cons l1 ls1, Cons u1 us1) (Cons l2 ls2, Cons u2 us2)- = let (ls', us') = boundingBox' (ls1, us1) (ls2, us2)- in (Cons (min l1 l2) ls', Cons (max u1 u2) us')+ (ys, zs) = mkTrivialSpan xs +-- TODO: This seems completely redundant. Perhaps DELETE.+inferFromIndices :: V.VecList Int -> Specification+inferFromIndices (V.VL ixs) = Specification $+ case fromBool mult of+ Linear -> Once $ inferCore ixs'+ NonLinear -> Mult $ inferCore ixs'+ where+ (ixs', mult) = hasDuplicates ixs -{-| Given two spans, if they are consecutive- (i.e., (lower1, upper1) (lower2, upper2) where lower2 = upper1 + 1)- then compose together returning Just of the new span. Otherwise Nothing -}-composeConsecutiveSpans :: Span (Vec n Int)- -> Span (Vec n Int) -> [Span (Vec n Int)]-composeConsecutiveSpans (Nil, Nil) (Nil, Nil) = [(Nil, Nil)]-composeConsecutiveSpans (Cons l1 ls1, Cons u1 us1) (Cons l2 ls2, Cons u2 us2)- | (ls1 == ls2) && (us1 == us2) && (u1 + 1 == l2)- = [(Cons l1 ls1, Cons u2 us2)]- | otherwise- = []+-- Same as inferFromIndices but don't do any linearity checking+-- (defaults to NonLinear). This is used when the front-end does+-- the linearity check first as an optimimsation.+inferFromIndicesWithoutLinearity :: V.VecList Int -> Specification+inferFromIndicesWithoutLinearity (V.VL ixs) =+ Specification . Mult . inferCore $ ixs +inferCore :: [V.Vec n Int] -> Approximation Spatial+inferCore subs =+ case V.proveNonEmpty . head $ subs of+ Just (V.ExistsEqT V.ReflEq) ->+ case spansToApproxSpatial . inferMinimalVectorRegions $ subs of+ Right a -> a+ Left msg -> error msg+ Nothing -> error "Input vectors are empty!"+ {-| |inferMinimalVectorRegions| a key part of the algorithm, from a list of n-dimensional relative indices it infers a list of (possibly overlapping) 1-dimensional spans (vectors) within the n-dimensional space. Built from |minimalise| and |allRegionPermutations| -}-inferMinimalVectorRegions :: (Permutable n) => [Vec n Int] -> [Span (Vec n Int)]+inferMinimalVectorRegions :: [V.Vec n Int] -> [Span (V.Vec n Int)] inferMinimalVectorRegions = fixCoalesce . map mkTrivialSpan where fixCoalesce spans =- let spans' = minimaliseRegions . allRegionPermutations $ spans+ let spans' = minimaliseRegions . coalesceContiguous $ spans in if spans' == spans then spans' else fixCoalesce spans' -{-| Map from a lists of n-dimensional spans of relative indices into all- possible contiguous spans within the n-dimensional space (individual pass)-}-allRegionPermutations :: (Permutable n)- => [Span (Vec n Int)] -> [Span (Vec n Int)]-allRegionPermutations =- nub . concat . unpermuteIndices . map (coalesceRegions >< id) . groupByPerm . map permutationss- where- {- Permutations of a indices in a span- (independently permutes the lower and upper bounds in the same way) -}- permutationss :: Permutable n- => Span (Vec n Int)- -> [(Span (Vec n Int), Vec n Int -> Vec n Int)]- -- Since the permutation ordering is identical for lower & upper bound,- -- reuse the same unpermutation- permutationss (l, u) = map (\((l', un1), (u', un2)) -> ((l', u'), un1))- $ zip (permutationsV l) (permutationsV u)-- sortByFst = sortBy (\(l1, u1) (l2, u2) -> compare l1 l2)-- groupByPerm :: [[(Span (Vec n Int), Vec n Int -> Vec n Int)]]- -> [( [Span (Vec n Int)] , Vec n Int -> Vec n Int)]- groupByPerm = map (\ixP -> let unPerm = snd $ head ixP- in (map fst ixP, unPerm)) . transpose-- coalesceRegions :: [Span (Vec n Int)] -> [Span (Vec n Int)]- coalesceRegions = nub . foldL composeConsecutiveSpans . sortByFst+-- An alternative that is simpler and possibly quicker+coalesceContiguous :: [Span (V.Vec n Int)] -> [Span (V.Vec n Int)]+coalesceContiguous [] = []+coalesceContiguous [x] = [x]+coalesceContiguous [x, y] =+ case coalesce x y of+ Nothing -> [x, y]+ Just c -> [c]+coalesceContiguous (x:xs) =+ case sequenceMaybes (map (coalesce x) xs) of+ Nothing -> x : coalesceContiguous xs+ Just cs -> coalesceContiguous (cs ++ xs) - unpermuteIndices :: [([Span (Vec n Int)], Vec n Int -> Vec n Int)]- -> [[Span (Vec n Int)]]- unpermuteIndices = nub . map (\(rs, unPerm) -> map (unPerm *** unPerm) rs)+sequenceMaybes :: Eq a => [Maybe a] -> Maybe [a]+sequenceMaybes xs | all (== Nothing) xs = Nothing+ | otherwise = Just (catMaybes xs) --- Helper function, reduces a list two elements at a time with a non-determistic operation-foldL :: (a -> a -> [a]) -> [a] -> [a]-foldL f [] = []-foldL f [a] = [a]-foldL f (a:(b:xs)) = case f a b of- [] -> a : foldL f (b : xs)- cs -> foldL f (cs ++ xs)+coalesce :: Span (V.Vec n Int) -> Span (V.Vec n Int) -> Maybe (Span (V.Vec n Int))+coalesce (V.Nil, V.Nil) (V.Nil, V.Nil) = Just (V.Nil, V.Nil)+-- If two well-defined intervals are equal, then they cannot be coalesced+coalesce x y | x == y = Nothing+-- Otherwise+coalesce (V.Cons l1 ls1, V.Cons u1 us1) (V.Cons l2 ls2, V.Cons u2 us2)+ | l1 == l2 && u1 == u2+ = case coalesce (ls1, us1) (ls2, us2) of+ Just (l, u) -> Just (V.Cons l1 l, V.Cons u1 u)+ Nothing -> Nothing+ | (u1 + 1 == l2) && (us1 == us2) && (ls1 == ls2)+ = Just (V.Cons l1 ls1, V.Cons u2 us2)+ | (u2 + 1 == l1) && (us1 == us2) && (ls1 == ls2)+ = Just (V.Cons l2 ls2, V.Cons u1 us1)+ | otherwise+ = Nothing {-| Collapses the regions into a small set by looking for potential overlaps and eliminating those that overlap -}-minimaliseRegions :: [Span (Vec n Int)] -> [Span (Vec n Int)]+minimaliseRegions :: [Span (V.Vec n Int)] -> [Span (V.Vec n Int)] minimaliseRegions [] = [] minimaliseRegions xss = nub . minimalise $ xss- where localMin x ys = (filter' x (\y -> containedWithin x y && (x /= y)) xss) ++ ys+ where localMin x ys = filter' x (\y -> containedWithin x y && (x /= y)) xss ++ ys minimalise = foldr localMin [] -- If nothing is caught by the filter, i.e. no overlaps then return -- the original regions r@@ -231,97 +159,11 @@ ys -> ys {-| Binary predicate on whether the first region containedWithin the second -}-containedWithin :: Span (Vec n Int) -> Span (Vec n Int) -> Bool-containedWithin (Nil, Nil) (Nil, Nil)+containedWithin :: Span (V.Vec n Int) -> Span (V.Vec n Int) -> Bool+containedWithin (V.Nil, V.Nil) (V.Nil, V.Nil) = True-containedWithin (Cons l1 ls1, Cons u1 us1) (Cons l2 ls2, Cons u2 us2)+containedWithin (V.Cons l1 ls1, V.Cons u1 us1) (V.Cons l2 ls2, V.Cons u2 us2) = (l2 <= l1 && u1 <= u2) && containedWithin (ls1, us1) (ls2, us2)---{-| Defines the (total) class of vector sizes which are permutable, along with- the permutation function which pairs permutations with the 'unpermute'- operation -}-class Permutable (n :: Nat) where- -- From a Vector of length n to a list of 'selections'- -- (triples of a selected element, the rest of the vector,- -- a function to 'unselect')- selectionsV :: Vec n a -> [Selection n a]- -- From a Vector of length n to a list of its permutations paired with the- -- 'unpermute' function- permutationsV :: Vec n a -> [(Vec n a, Vec n a -> Vec n a)]---- 'Split' is a size-indexed family which gives the type of selections--- for each size:--- Z is trivial--- (S n) provides a triple of the select element, the remaining vector,--- and the 'unselect' function for returning the original value-type family Selection n a where- Selection Z a = a- Selection (S n) a = (a, Vec n a, a -> Vec n a -> Vec (S n) a)--instance Permutable Z where- selectionsV Nil = []- permutationsV Nil = [(Nil, id)]--instance Permutable (S Z) where- selectionsV (Cons x xs)- = [(x, Nil, Cons)]- permutationsV (Cons x Nil)- = [(Cons x Nil, id)]--instance Permutable (S n) => Permutable (S (S n)) where- selectionsV (Cons x xs) =- (x, xs, Cons) : [ (y, Cons x ys, unselect unSel)- | (y, ys, unSel) <- selectionsV xs ]- where- unselect :: (a -> Vec n a -> Vec (S n) a)- -> (a -> Vec (S n) a -> Vec (S (S n)) a)- unselect f y' (Cons x' ys') = Cons x' (f y' ys')-- permutationsV xs =- [ (Cons y zs, \(Cons y' zs') -> unSel y' (unPerm zs'))- | (y, ys, unSel) <- selectionsV xs,- (zs, unPerm) <- permutationsV ys ]--{- Vector list repreentation where the size 'n' is existential quantified -}-data VecList a where VL :: (IsNatural n, Permutable n) => [Vec n a] -> VecList a---- Lists existentially quanitify over a vector's size : Exists n . Vec n a-data List a where- List :: (IsNatural n, Permutable n) => Vec n a -> List a--lnil :: List a-lnil = List Nil-lcons :: a -> List a -> List a-lcons x (List Nil) = List (Cons x Nil)-lcons x (List (Cons y Nil)) = List (Cons x (Cons y Nil))-lcons x (List (Cons y (Cons z xs))) = List (Cons x (Cons y (Cons z xs)))--fromList :: [a] -> List a-fromList = foldr lcons lnil---- pre-condition: the input is a 'rectangular' list of lists (i.e. all internal--- lists have the same size)-fromLists :: [[Int]] -> VecList Int-fromLists [] = VL ([] :: [Vec Z Int])-fromLists (xs:xss) = consList (fromList xs) (fromLists xss)- where- consList :: List Int -> VecList Int -> VecList Int- consList (List vec) (VL []) = VL [vec]- consList (List vec) (VL (x:xs))- = let (vec', x') = zipVec vec x- in -- Force the pre-condition equality- case (preCondition x' xs, preCondition vec' xs) of- (ReflEq, ReflEq) -> VL (vec' : (x' : xs))-- where -- At the moment the pre-condition is 'assumed', and therefore- -- force used unsafeCoerce: TODO, rewrite- preCondition :: Vec n a -> [Vec n1 a] -> EqT n n1- preCondition xs x = unsafeCoerce ReflEq---- Equality type-data EqT (a :: k) (b :: k) where- ReflEq :: EqT a a -- Local variables: -- mode: haskell
src/Camfort/Specification/Stencils/InferenceFrontend.hs view
@@ -31,24 +31,22 @@ import Camfort.Analysis.CommentAnnotator import Camfort.Specification.Stencils.InferenceBackend+import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.Syntax-import Camfort.Specification.Stencils.Annotation+import Camfort.Specification.Stencils.Annotation () import qualified Camfort.Specification.Stencils.Grammar as Gram import qualified Camfort.Specification.Stencils.Synthesis as Synth import Camfort.Analysis.Annotations-import Camfort.Helpers.Vec-import Camfort.Helpers (collect)+import Camfort.Helpers (collect, descendReverseM, descendBiReverseM)+import qualified Camfort.Helpers.Vec as V import Camfort.Input-import qualified Camfort.Output as O import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Types as FAT import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.BBlocks as FAB import qualified Language.Fortran.Analysis.DataFlow as FAD import qualified Language.Fortran.Util.Position as FU-import qualified Language.Fortran.Util.SecondParameter as FUS import Data.Data import Data.Foldable@@ -58,7 +56,6 @@ import qualified Data.IntMap as IM import qualified Data.Set as S import Data.Maybe-import Data.List import Debug.Trace -- Define modes of interaction with the inference@@ -70,8 +67,9 @@ defaultValue = AssignMode data InferState = IS {- ivMap :: FAD.InductionVarMapByASTBlock,- hasSpec :: [(FU.SrcSpan, Variable)] }+ ivMap :: FAD.InductionVarMapByASTBlock+ , hasSpec :: [(FU.SrcSpan, Variable)]+ , visitedNodes :: [Int]} -- The inferer returns information as a LogLine@@ -89,7 +87,7 @@ -> Inferer a -> (a, [LogLine]) runInferer ivmap flTo =- flip evalState (IS ivmap [])+ flip evalState (IS ivmap [] []) . flip runReaderT flTo . runWriterT @@ -99,23 +97,19 @@ -> F.ProgramFile (FA.Analysis A) -> (F.ProgramFile (FA.Analysis A), [LogLine]) stencilInference nameMap mode marker pf =- (F.ProgramFile mi cm_pus' blocks', log1 ++ log2)+ (F.ProgramFile mi pus', log1) where -- Parse specification annotations and include them into the syntax tree -- that way if generate specifications at the same place we can -- decide whether to synthesise or not -- TODO: might want to output log0 somehow (though it doesn't fit LogLine)- (pf'@(F.ProgramFile mi cm_pus blocks), log0) =+ (pf'@(F.ProgramFile mi pus), log0) = if mode == Synth then runWriter (annotateComments Gram.specParser pf) else (pf, []) - (cm_pus', log1) = runWriter (transformBiM perPU cm_pus)- (blocks', log2) = runInferer ivMap flTo blocksInf- blocksInf = let ?flowsGraph = flTo- ?nameMap = nameMap- in descendBiM (perBlockInfer mode marker) blocks+ (pus', log1) = runWriter (transformBiM perPU pus) -- Run inference per program unit, placing the flowsmap in scope perPU :: F.ProgramUnit (FA.Analysis A)@@ -160,8 +154,9 @@ -> [F.Block (FA.Analysis A)] -> Inferer [([Variable], Specification)] genSpecsAndReport mode span lhs blocks = do- (IS ivmap _) <- get- let (specs, evalInfos) = runWriter $ genSpecifications ivmap lhs blocks+ (IS ivmap _ _) <- get+ let ((specs, visited), evalInfos) = runWriter $ genSpecifications ivmap lhs blocks+ modify (\state -> state { visitedNodes = (visitedNodes state) ++ visited }) tell [ (span, Left specs) ] if mode == EvalMode then do@@ -175,16 +170,24 @@ return specs else return specs ++ -- Match expressions which are array subscripts, returning Just of their -- index expressions, else Nothing isArraySubscript :: F.Expression (FA.Analysis A) -> Maybe [F.Index (FA.Analysis A)] isArraySubscript (F.ExpSubscript _ _ (F.ExpValue _ _ (F.ValVariable _)) subs) = Just $ F.aStrip subs-isArraySubscript (F.ExpDataRef _ _ _ e) = isArraySubscript e+isArraySubscript (F.ExpDataRef _ _ e e') = do+ isArraySubscript e <++> isArraySubscript e'+ where+ Nothing <++> Nothing = Nothing+ Nothing <++> Just xs = Just xs+ Just xs <++> Nothing = Just xs+ Just xs <++> Just ys = Just (xs ++ ys) isArraySubscript _ = Nothing -fromJustMsg msg (Just x) = x+fromJustMsg _ (Just x) = x fromJustMsg msg Nothing = error msg -- Traverse Blocks in the AST and infer stencil specifications@@ -192,7 +195,7 @@ => InferMode -> Char -> F.Block (FA.Analysis A) -> Inferer (F.Block (FA.Analysis A)) -perBlockInfer Synth _ b@(F.BlComment ann span _) = do+perBlockInfer Synth _ b@(F.BlComment ann _ _) = do -- If we have a comment that is actually a specification then record that -- this has been assigned so that we don't generate extra specifications -- that overlap with user-given oones@@ -203,37 +206,45 @@ (Just (Left (Gram.SpecDec _ vars)), Just block) -> -- Is the block an assignment case block of- s@(F.BlStatement _ span _ assg@(F.StExpressionAssign _ _ _ _)) -> do+ F.BlStatement _ span _ F.StExpressionAssign{} -> do -- Then update the list of spans+vars that have specifications state <- get put (state { hasSpec = hasSpec state ++ zip (repeat span) vars }) _ -> return () return b -perBlockInfer mode marker b@(F.BlStatement ann span@(FU.SrcSpan lp up) _ stmnt)+perBlockInfer mode marker b@(F.BlStatement ann span@(FU.SrcSpan lp _) _ stmnt) | mode == AssignMode || mode == CombinedMode || mode == EvalMode || mode == Synth = do- -- On all StExpressionAssigns that occur in stmt....- let lhses = [lhs | (F.StExpressionAssign _ _ lhs _)++ (IS ivmap hasSpec visitedStmts) <- get+ let label = fromMaybe (-1) (FA.insLabel ann)+ if (label `elem` visitedStmts)+ then -- This statement has been part of a visited dataflow path+ return b+ else do+ -- On all StExpressionAssigns that occur in stmt....+ let lhses = [lhs | (F.StExpressionAssign _ _ lhs _) <- universe stmnt :: [F.Statement (FA.Analysis A)]]- (IS ivmap hasSpec) <- get- specs <- flip mapM lhses- -- ... apply the following:- (\lhs -> do- case isArraySubscript lhs of- Just subs ->- -- Left-hand side is a subscript-by relative index or by a range- case neighbourIndex ivmap subs of- Just lhs -> genSpecsAndReport mode span lhs [b]- Nothing -> if mode == EvalMode- then do- tell [(span , Right ("EVALMODE: LHS is an array\- \ subscript we can't handle \- \(tag: LHSnotHandled)",""))]- return []- else return []- -- Not an assign we are interested in- _ -> return [])- if mode == Synth && not (null specs) && specs /= [[]]+ specs <- forM lhses $ \lhs -> do+ -- ... apply the following:+ case lhs of+ -- Assignment to a variable+ (F.ExpValue _ _ (F.ValVariable v)) -> genSpecsAndReport mode span [] [b]+ _ -> case isArraySubscript lhs of+ Just subs ->+ -- Left-hand side is a subscript-by relative index or by a range+ case neighbourIndex ivmap subs of+ Just lhs -> genSpecsAndReport mode span lhs [b]+ Nothing -> if mode == EvalMode+ then do+ tell [(span , Right ("EVALMODE: LHS is an array\+ \ subscript we can't handle \+ \(tag: LHSnotHandled)",""))]+ return []+ else return []+ -- Not an assign we are interested in+ _ -> return []+ if mode == Synth && not (null specs) && specs /= [[]] then let specComment = Synth.formatSpec (Just (tabs ++ '!':marker:" ")) ?nameMap (span, Left (concat specs')) specs' = map (mapMaybe noSpecAlready) specs@@ -247,73 +258,104 @@ (FU.SrcSpan loc _) = span span' = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) ann' = ann { FA.prevAnnotation = (FA.prevAnnotation ann) { refactored = Just loc } }- in return $ F.BlComment ann' span' specComment+ in return $ F.BlComment ann' span' (F.Comment specComment) else return b perBlockInfer mode marker b@(F.BlDo ann span lab cname lab' mDoSpec body tlab) = do- -- introduce any induction variables into the induction variable state- if (mode == DoMode || mode == CombinedMode) && isStencilDo b then genSpecsAndReport mode span [] body else return [] - -- descend into the body of the do-statement- body' <- mapM (descendBiM (perBlockInfer mode marker)) body- -- Remove any induction variable from the state+ -- descend into the body of the do-statement (in reverse order)+ body' <- mapM (descendBiReverseM (perBlockInfer mode marker)) (reverse body) return $ F.BlDo ann span lab cname lab' mDoSpec body' tlab perBlockInfer mode marker b = do -- Go inside child blocks- b' <- descendM (descendBiM (perBlockInfer mode marker)) $ b+ b' <- descendReverseM (descendBiReverseM (perBlockInfer mode marker)) $ b return b' +-- Combiantor for reducing a map with effects and partiality inside+-- into an effectful list of key-value pairs+assocsSequence :: Monad m => M.Map k (m (Maybe a)) -> m [(k, a)]+assocsSequence maps = do+ assocs <- sequence . map strength . M.toList $ maps+ return . catMaybes . map strength $ assocs+ where+ strength :: Monad m => (a, m b) -> m (a, b)+ strength (a, mb) = mb >>= (\b -> return (a, b))+ genSpecifications :: Params => FAD.InductionVarMapByASTBlock -> [Neighbour] -> [F.Block (FA.Analysis A)]- -> Writer EvalLog [([Variable], Specification)]+ -> Writer EvalLog ([([Variable], Specification)], [Int]) genSpecifications ivs lhs blocks = do- let subscripts = evalState (mapM (genSubscripts True) blocks) []- varToMaybeSpecs <- sequence . map strength . mkSpecs $ subscripts- let varToSpecs = catMaybes . map strength $ varToMaybeSpecs+ let (subscripts, visitedNodes) = subscriptsOnRhs ?nameMap blocks+ varToSpecs <- assocsSequence $ mkSpecs subscripts case varToSpecs of [] -> do tell [("EVALMODE: Empty specification (tag: emptySpec)", "")]- return []+ return ([], visitedNodes) _ -> do let varsToSpecs = groupKeyBy varToSpecs- return $ splitUpperAndLower varsToSpecs+ return (splitUpperAndLower varsToSpecs, visitedNodes) where- mkSpecs = M.toList- . M.mapWithKey (\v -> indicesToSpec ivs v lhs)- . M.unionsWith (++)+ mkSpecs = M.mapWithKey (\v -> indicesToSpec ivs v lhs) splitUpperAndLower = concatMap splitUpperAndLower'- splitUpperAndLower' (vs, Specification (Multiple (Bound (Just l) (Just u)))) =- [(vs, Specification (Multiple (Bound (Just l) Nothing))),- (vs, Specification (Multiple (Bound Nothing (Just u))))]- splitUpperAndLower' (vs, Specification (Single (Bound (Just l) (Just u)))) =- [(vs, Specification (Single (Bound (Just l) Nothing))),- (vs, Specification (Single (Bound Nothing (Just u))))]+ splitUpperAndLower' (vs, Specification (Mult (Bound (Just l) (Just u))))+ | isUnit l =+ [(vs, Specification (Mult (Bound Nothing (Just u))))]+ | otherwise =+ [(vs, Specification (Mult (Bound (Just l) Nothing))),+ (vs, Specification (Mult (Bound Nothing (Just u))))]+ splitUpperAndLower' (vs, Specification (Once (Bound (Just l) (Just u))))+ | isUnit l =+ [(vs, Specification (Mult (Bound Nothing (Just u))))]+ | otherwise =+ [(vs, Specification (Once (Bound (Just l) Nothing))),+ (vs, Specification (Once (Bound Nothing (Just u))))] splitUpperAndLower' x = [x] +{-| subscriptsOnRhs+ Takes * a name map+ * a list of blocks representing an RHS+ Returns a map from array variables to indices, and a list of+ nodes that were visited when computing this information -}+subscriptsOnRhs :: Params+ => FAR.NameMap+ -> [F.Block (FA.Analysis A)]+ -> (M.Map Variable [[F.Index (FA.Analysis A)]], [Int])+subscriptsOnRhs nameMap blocks =+ (subscripts', visitedNodes)+ where+ (maps, visitedNodes) = runState (mapM (genSubscripts True) blocks) []+ subscripts = M.unionsWith (++) maps+ subscripts' = filterOutFuns ?nameMap subscripts+ genOffsets :: Params => FAD.InductionVarMapByASTBlock -> [Neighbour] -> [F.Block (FA.Analysis A)] -> Writer EvalLog [(Variable, (Bool, [[Int]]))] genOffsets ivs lhs blocks = do- let subscripts = evalState (mapM (genSubscripts True) blocks) []- varToMaybeSpecs <- sequence . map strength . mkOffsets $ subscripts- return $ catMaybes . map strength $ varToMaybeSpecs+ let (subscripts, _) = subscriptsOnRhs ?nameMap blocks+ assocsSequence $ mkOffsets subscripts where- mkOffsets = M.toList- . M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs)- . M.unionsWith (++)+ mkOffsets = M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs) -strength :: Monad m => (a, m b) -> m (a, b)-strength (a, mb) = mb >>= (\b -> return (a, b)) +-- Filter out any variable names which do not appear in the name map or+-- which in appear in the name map with the same name, indicating they+-- are an instric function, e.g., abs+filterOutFuns nameMap m =+ M.filterWithKey (\k _ ->+ case k `M.lookup` nameMap of+ Nothing -> False+ Just k' | k == k' -> False+ _ -> True) m+ -- Generate all subscripting expressions (that are translations on -- induction variables) that flow to this block -- The State monad provides a list of the visited nodes so far@@ -326,7 +368,7 @@ -- Don't pull dependencies through arrays = return M.empty -genSubscripts top block = do+genSubscripts _ block = do visited <- get case (FA.insLabel $ F.getAnnotation block) of @@ -353,13 +395,12 @@ 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) =+ replaceModulo e@(F.ExpFunctionCall _ _+ (F.ExpValue _ _ (F.ValIntrinsic iname)) subs)+ | iname `elem` ["modulo", "mod", "amod", "dmod"] -- We expect that the first parameter to modulo is being treated -- as an IxSingle element- case (head $ F.aStrip subs) of- (F.IxSingle _ _ _ e') -> e'- _ -> e+ , Just (F.Argument _ _ _ e':_) <- fmap F.aStrip subs = e' replaceModulo e = e genRHSsubscripts' b =@@ -375,7 +416,7 @@ getInductionVar _ = [] isStencilDo :: F.Block (FA.Analysis A) -> Bool-isStencilDo b@(F.BlDo _ span _ _ _ mDoSpec body _) =+isStencilDo (F.BlDo _ _ _ _ _ mDoSpec body _) = -- Check to see if the body contains any affine use of the induction variable -- as a subscript case getInductionVar mDoSpec of@@ -459,15 +500,16 @@ relativiseRHS _ rhses = rhses relativiseBy v i (Neighbour u j) | v == u = Neighbour u (j - i)- -- RHS is a range, map it to constant- relativiseBy v i (Neighbour "" j) = Constant (F.ValInteger "") relativiseBy _ _ x = x -- Check that induction variables are used consistently consistentIVSuse :: [Neighbour] -> [[Neighbour]] -> Bool-consistentIVSuse lhs [] = True+consistentIVSuse [] _ = True+consistentIVSuse _ [] = True consistentIVSuse lhs rhses =- consistentRHS /= Nothing && (all consistentWithLHS (fromJust consistentRHS))+ rhsBasis /= Nothing -- There is a consitent RHS+ && (all (`consistentWith` lhs) (fromJust rhsBasis)+ || all (`consistentWith` (fromJust rhsBasis)) lhs) where cmp (Neighbour v i) (Neighbour v' _) | v == v' = Just $ Neighbour v i | otherwise = Nothing@@ -477,25 +519,25 @@ cmp (NonNeighbour {}) (Neighbour {}) = Nothing cmp (Neighbour {}) (NonNeighbour{}) = Nothing cmp _ _ = Just $ Constant (F.ValInteger "")- consistentRHS = foldrM (\a b -> mapM (uncurry cmp) $ zip a b) (head rhses) (tail rhses)+ rhsBasis = foldrM (\a b -> mapM (uncurry cmp) $ zip a b) (head rhses) (tail rhses) -- If there is an induction variable on the RHS, then it also occurs on -- the LHS- consistentWithLHS :: Neighbour -> Bool- consistentWithLHS (Neighbour rv _) = any (matchesIV rv) lhs- consistentWithLHS _ = True+ consistentWith :: Neighbour -> [Neighbour] -> Bool+ consistentWith (Neighbour rv _) ns = any (matchesIV rv) ns+ consistentWith _ _ = True matchesIV :: Variable -> Neighbour -> Bool matchesIV v (Neighbour v' _) | v == v' = True -- All RHS to contain index ranges- matchesIV v (Neighbour v' _) | v == "" = True- matchesIV v (Neighbour v' _) | v' == "" = True+ matchesIV v Neighbour{} | v == "" = True+ matchesIV _ (Neighbour v' _) | v' == "" = True matchesIV _ _ = False -- Convert list of relative offsets to a spec relativeIxsToSpec :: [[Int]] -> Maybe Specification relativeIxsToSpec ixs = if isEmpty exactSpec then Nothing else Just exactSpec- where exactSpec = inferFromIndicesWithoutLinearity . fromLists $ ixs+ where exactSpec = inferFromIndicesWithoutLinearity . V.fromLists $ ixs isNeighbour :: Data a => F.Index (FA.Analysis a) -> [Variable] -> Bool isNeighbour exp vs =@@ -548,8 +590,8 @@ ixsspan (F.IxRange _ sp _ _ _) = sp ixsspan (F.IxSingle _ sp _ _ ) = sp -ixToNeighbour' ivs (F.IxRange _ _ Nothing Nothing Nothing) = Neighbour "" 0-ixToNeighbour' ivs (F.IxRange _ _ Nothing Nothing+ixToNeighbour' _ (F.IxRange _ _ Nothing Nothing Nothing) = Neighbour "" 0+ixToNeighbour' _ (F.IxRange _ _ Nothing Nothing (Just (F.ExpValue _ _ (F.ValInteger "1")))) = Neighbour "" 0 ixToNeighbour' ivs (F.IxSingle _ _ _ exp) = expToNeighbour ivs exp@@ -564,7 +606,7 @@ | FA.varName e `elem` ivs = Neighbour (FA.varName e) 0 | otherwise = Constant (fmap (const ()) v) -expToNeighbour ivs (F.ExpValue _ _ val) = Constant (fmap (const ()) val)+expToNeighbour _ (F.ExpValue _ _ val) = Constant (fmap (const ()) val) expToNeighbour ivs (F.ExpBinary _ _ F.Addition e@(F.ExpValue _ _ (F.ValVariable _))
src/Camfort/Specification/Stencils/Model.hs view
@@ -22,202 +22,387 @@ -} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE MultiWayIf #-} -module Camfort.Specification.Stencils.Model where+module Camfort.Specification.Stencils.Model ( Interval(..)+ , Bound(..)+ , approxVec+ , Offsets(..)+ , UnionNF+ , vecLength+ , unfCompare+ , optimise+ , maximas+ , Approximation(..)+ , lowerBound, upperBound+ , fromExact+ , Multiplicity(..)+ , Peelable(..)+ ) where -import Camfort.Specification.Stencils.Syntax-import Data.Set hiding (map,foldl',(\\))-import qualified Data.Set as Set-import Data.List-import qualified Data.List as DL-import qualified Data.Map as DM+import qualified Control.Monad as CM -{-| This function maps inner representation to a set of vectors of length-- given by `dim`. This is the mathematical representation of the-- specification. |-}-model :: Multiplicity (Approximation Spatial)- -> Int- -> Multiplicity (Approximation (Set [Int]))-model s dims =- let ?globalDimensionality = dims- in mkModel s+import Algebra.Lattice+import Data.Semigroup+import qualified Data.List.NonEmpty as NE+import qualified Data.Set as S+import Data.Foldable+import Data.SBV+import Data.Data+import Data.List (sortBy, nub)+import Data.Maybe (fromJust)+import qualified Data.PartialOrd as PO -consistent :: Multiplicity [[Int]]- -> Multiplicity (Approximation Spatial)- -> Bool--- If the specification says "readOnce" but there are duplicates among--- offsets, then there is no consistency.------ Note that if the spec omits "readOnce" and the offsets happen to be--- unique that is allowed as "readOnce" is an extra qualifier.-consistent (Multiple _) (Single _) = False-consistent mult1 spec =- consistent' (model spec dimensionality)- where- dimensionality = length . head $ accesses- consistent' m2 =- case fromMult m2 of- Exact unifiers ->- consistent' (Multiple (Bound Nothing (Just unifiers))) &&- consistent' (Multiple (Bound (Just unifiers) Nothing))- Bound lus@Just{} uus@Just{} ->- consistent' (Multiple (Bound lus Nothing)) &&- consistent' (Multiple (Bound Nothing uus))- Bound Nothing (Just unifiers) ->- all (\access -> any (access `accepts`) unifiers) accesses- Bound (Just unifiers) Nothing ->- all (\unifier -> any (`accepts` unifier) accesses) unifiers+import qualified Camfort.Helpers.Vec as V+import System.IO.Unsafe+import Debug.Trace - accesses = fromMult mult1+-- Utility container+class Container a where+ type MemberTyp a+ type CompTyp a - access `accepts` unifier =- all (\(u,v) -> v == absoluteRep || u == v) (zip access unifier)+ member :: MemberTyp a -> a -> Bool+ compile :: a -> (CompTyp a -> SBool) --- Recursive `Model` class implemented for all parts of the spec.-class Model spec where- type Domain spec+--------------------------------------------------------------------------------+-- Arbitrary sets representing offsets+-------------------------------------------------------------------------------- - -- generate model for the specification, where the implicit- -- parameter ?globalDimensionality is the global dimensionality- -- for the spec (not just the local maximum dimensionality)- mkModel :: (?globalDimensionality :: Int) => spec -> Domain spec+data Offsets =+ Offsets (S.Set Int64)+ | SetOfIntegers+ deriving Eq - -- Return the maximum dimension specified in the spec- -- giving the dimensionality for that specification- dimensionality :: spec -> Int- dimensionality = maximum . dimensions- -- Return all the dimensions specified for in this spec- dimensions :: spec -> [Int]+instance Ord Offsets where+ Offsets s `compare` Offsets s' = s `compare` s'+ Offsets _ `compare` SetOfIntegers = LT+ SetOfIntegers `compare` Offsets _ = GT+ SetOfIntegers `compare` SetOfIntegers = EQ --- Set representation where multiplicities are (-1) modulo 2--- that is, False = multiplicity 1, True = multiplicity > 1-instance Model Specification where- type Domain Specification = Multiplicity (Approximation (Set [Int]))+instance Container Offsets where+ type MemberTyp Offsets = Int64+ type CompTyp Offsets = SInt64 - mkModel (Specification s) = mkModel s+ member i (Offsets s) = i `S.member` s+ member _ _ = True - dimensionality (Specification s) = dimensionality s+ compile (Offsets s) i = i `sElem` map fromIntegral (S.toList s)+ compile SetOfIntegers _ = true - dimensions (Specification s) = dimensions s+instance JoinSemiLattice Offsets where+ (Offsets s) \/ (Offsets s') = Offsets $ s `S.union` s'+ _ \/ _ = SetOfIntegers -instance Model (Multiplicity (Approximation Spatial)) where- type Domain (Multiplicity (Approximation Spatial)) =- Multiplicity (Approximation (Set [Int]))+instance MeetSemiLattice Offsets where+ (Offsets s) /\ (Offsets s') = Offsets $ s `S.intersection` s'+ off@Offsets{} /\ _ = off+ _ /\ o = o - mkModel (Multiple s) = Multiple (mkModel s)- mkModel (Single s) = Single (mkModel s)+instance Lattice Offsets - dimensionality mult = dimensionality $ fromMult mult+instance BoundedJoinSemiLattice Offsets where+ bottom = Offsets S.empty - dimensions mult = dimensions $ fromMult mult+instance BoundedMeetSemiLattice Offsets where+ top = SetOfIntegers -instance Model (Approximation Spatial) where- type Domain (Approximation Spatial) = Approximation (Set [Int])+instance BoundedLattice Offsets - mkModel = fmap mkModel- dimensionality (Exact s) = dimensionality s- dimensionality (Bound l u) = dimensionality l `max` dimensionality u+--------------------------------------------------------------------------------+-- Interval as defined in the paper+-------------------------------------------------------------------------------- - dimensions (Exact s) = dimensions s- dimensions (Bound l u) = dimensions l ++ dimensions u+data Bound = Arbitrary | Standard --- Lifting of model to Maybe type-instance Model a => Model (Maybe a) where- type Domain (Maybe a) = Maybe (Domain a)+-- | Interval data structure assumes the following:+-- 1. The first num. param. is less than the second;+-- 2. For holed intervals, first num. param. <= 0 <= second num. param.;+data Interval a where+ IntervArbitrary :: Int -> Int -> Interval Arbitrary+ IntervInfiniteArbitrary :: Interval Arbitrary+ IntervHoled :: Int64 -> Int64 -> Bool -> Interval Standard+ IntervInfinite :: Interval Standard - mkModel Nothing = Nothing- mkModel (Just x) = Just (mkModel x)+deriving instance Eq (Interval a) - dimensions Nothing = [0]- dimensions (Just x) = dimensions x+instance Show (Interval Standard) where+ show IntervInfinite = "IntervInfinite"+ show (IntervHoled lb up p) =+ "Interv [" ++ show lb ++ "," ++ show up ++ "]^" ++ show p --- Core part of the model-instance Model Spatial where- type Domain Spatial = Set [Int]+approxInterv :: Interval Arbitrary -> Approximation (Interval Standard)+approxInterv (IntervArbitrary a b)+ | a > b = error+ "Interval condition violated: lower bound is bigger than the upper bound."+ | a <= 0, b >= 0 = Exact $ IntervHoled a' b' True+ | a <= -1, b == -1 = Exact $ IntervHoled a' 0 False+ | a == 1, b >= 1 = Exact $ IntervHoled 0 b' False+ | a > 1, b > 1 = Bound Nothing $ Just $ IntervHoled 0 b' False+ | a < -1, b < -1 = Bound Nothing $ Just $ IntervHoled a' 0 False+ | otherwise = error "Impossible: All posibilities are covered."+ where+ a' = fromIntegral a+ b' = fromIntegral b+approxInterv IntervInfiniteArbitrary = Exact IntervInfinite - mkModel (Spatial s) = mkModel s+approxVec :: forall n .+ V.Vec n (Interval Arbitrary)+ -> Approximation (V.Vec n (Interval Standard))+approxVec v =+ case findApproxIntervs stdVec of+ ([],_) -> Exact . fmap fromExact $ stdVec+ _ -> Bound Nothing (Just $ upperBound <$> stdVec)+ where+ stdVec :: V.Vec n (Approximation (Interval Standard))+ stdVec = fmap approxInterv v - dimensionality (Spatial s) = dimensionality s+ findApproxIntervs :: forall n . V.Vec n (Approximation (Interval Standard))+ -> ([ Int ], [ Int ])+ findApproxIntervs v = findApproxIntervs' 0 v ([],[]) - dimensions (Spatial s) = dimensions s+ findApproxIntervs' :: forall n . Int+ -> V.Vec n (Approximation (Interval Standard))+ -> ([ Int ], [ Int ])+ -> ([ Int ], [ Int ])+ findApproxIntervs' _ V.Nil acc = acc+ findApproxIntervs' i (V.Cons x xs) (bixs, eixs) =+ findApproxIntervs' (i+1) xs $+ case x of+ Bound{} -> (i:bixs, eixs)+ Exact{} -> (bixs, i:eixs) +instance Container (Interval Standard) where+ type MemberTyp (Interval Standard) = Int64+ type CompTyp (Interval Standard) = SInt64 -instance Model RegionSum where- type Domain RegionSum = Set [Int]- mkModel (Sum ss) = unions (map mkModel ss)- dimensionality (Sum ss) =- maximum1 (map dimensionality ss)+ member 0 (IntervHoled _ _ b) = b+ member i (IntervHoled a b _) = i >= a && i <= b+ member _ _ = True - dimensions (Sum ss) = concatMap dimensions ss+ compile (IntervHoled i1 i2 b) i+ | b = inRange i range+ | otherwise = inRange i range &&& i ./= 0+ where+ range = (fromIntegral i1, fromIntegral i2)+ compile IntervInfinite _ = true +instance JoinSemiLattice (Interval Standard) where+ (IntervHoled lb ub noHole) \/ (IntervHoled lb' ub' noHole') =+ IntervHoled (min lb lb') (max ub ub') (noHole || noHole')+ _ \/ _ = top -instance Model Region where- type Domain Region = Set [Int]+instance MeetSemiLattice (Interval Standard) where+ (IntervHoled lb ub noHole) /\ (IntervHoled lb' ub' noHole') =+ IntervHoled (max lb lb') (min ub ub') (noHole && noHole')+ int@IntervHoled{} /\ _ = int+ _ /\ int = int - mkModel (Forward dep dim reflx) = fromList- [mkSingleEntryNeg i dim ?globalDimensionality | i <- [i0..dep]]- where i0 = if reflx then 0 else 1+instance Lattice (Interval Standard) - mkModel (Backward dep dim reflx) = fromList- [mkSingleEntryNeg i dim ?globalDimensionality | i <- [(-dep)..i0]]- where i0 = if reflx then 0 else -1+instance BoundedJoinSemiLattice (Interval Standard) where+ bottom = IntervHoled 0 0 False - mkModel (Centered dep dim reflx) = fromList- [mkSingleEntryNeg i dim ?globalDimensionality | i <- [(-dep)..dep] \\ i0]- where i0 = if reflx then [] else [0]+instance BoundedMeetSemiLattice (Interval Standard) where+ top = IntervInfinite - dimensionality (Forward _ d _) = d- dimensionality (Backward _ d _) = d- dimensionality (Centered _ d _) = d+instance BoundedLattice (Interval Standard) - dimensions (Forward _ d _) = [d]- dimensions (Backward _ d _) = [d]- dimensions (Centered _ d _) = [d]+--------------------------------------------------------------------------------+-- Union of cartesian products normal form+-------------------------------------------------------------------------------- -mkSingleEntryNeg :: Int -> Int -> Int -> [Int]-mkSingleEntryNeg i 0 ds = error "Dimensions are 1-indexed"-mkSingleEntryNeg i 1 ds = i : replicate (ds - 1) absoluteRep-mkSingleEntryNeg i d ds = absoluteRep : mkSingleEntryNeg i (d - 1) (ds - 1)+type UnionNF n a = NE.NonEmpty (V.Vec n a) -instance Model RegionProd where- type Domain RegionProd = Set [Int]+vecLength :: UnionNF n a -> V.Natural n+vecLength = V.lengthN . NE.head - mkModel (Product []) = Set.empty- mkModel (Product [s]) = mkModel s- mkModel p@(Product ss) = cleanedProduct- where- cleanedProduct = fromList $ DL.filter keepPred product- product = cprodVs $ map (toList . mkModel) ss- dims = dimensions p- keepPred el = DL.foldr (\pr acc -> nonProdP pr && acc) True (zip [(1::Int)..] el)- nonProdP (i,el) = i `notElem` dims || el /= absoluteRep+instance Container a => Container (UnionNF n a) where+ type MemberTyp (UnionNF n a) = V.Vec n (MemberTyp a)+ type CompTyp (UnionNF n a) = V.Vec n (CompTyp a)+ member is = any (member' is)+ where+ member' is space = and $ V.zipWith member is space - dimensionality (Product ss) =- maximum1 (map dimensionality ss)- dimensions (Product ss) =- nub $ concatMap dimensions ss+ compile spaces is = foldr1 (|||) $ NE.map (`compile'` is) spaces+ where+ compile' space is =+ foldr' (\(set, i) -> (&&&) $ compile set i) true $ V.zip space is -tensor n s t = cleanedProduct- where- cleanedProduct = fromList $ DL.filter keepPred product- product = cprodV s t- keepPred el = DL.foldr (\pr acc -> nonProdP pr && acc) True (zip [(1::Int)..] el)- nonProdP (i,el) = i `notElem` [1..n] || el /= absoluteRep+instance JoinSemiLattice (UnionNF n a) where+ oi \/ oi' = oi <> oi' --- Cartesian product on list of vectors4-cprodVs :: [[[Int]]] -> [[Int]]-cprodVs = foldr1 cprodV+instance BoundedLattice a => MeetSemiLattice (UnionNF n a) where+ (/\) = CM.liftM2 (V.zipWith (/\)) -cprodV :: [[Int]] -> [[Int]] -> [[Int]]-cprodV xss yss = xss >>= (\xs -> yss >>= pairwisePerm xs)+instance BoundedLattice a => Lattice (UnionNF n a) -pairwisePerm :: [Int] -> [Int] -> [[Int]]-pairwisePerm x y = sequence . transpose $ [x, y]+unfCompare :: forall a b n . ( Container a, Container b+ , MemberTyp a ~ Int64, MemberTyp b ~ Int64+ , CompTyp a ~ SInt64, CompTyp b ~ SInt64+ )+ => UnionNF n a -> UnionNF n b -> Ordering+unfCompare oi oi' = unsafePerformIO $ do+ thmRes <- prove pred+ case thmRes of+ -- Tell the user if there was a hard proof error (e.g., if+ -- z3 is not installed/accessible).+ -- TODO: give more information+ ThmResult (ProofError _ msgs) -> fail $ unlines msgs+ _ ->+ if modelExists thmRes+ then do+ ce <- counterExample thmRes+ case V.fromList ce of+ V.VecBox cev ->+ case V.proveEqSize (NE.head oi) cev of+ Just V.ReflEq ->+ -- TODO: The second branch is defensive programming the+ -- member check is not necessary unless the counter example+ -- is bogus (it shouldn't be). Delete if it adversely+ -- effects the performance.+ if | cev `member` oi -> return GT+ | cev `member` oi' -> return LT+ | otherwise -> fail+ "Impossible: counter example is in \+ \neither of the operands"+ Nothing -> fail+ "Impossible: Counter example size doesn't \+ \match the original vector size."+ else "EQ branch" `trace` return EQ+ where+ counterExample :: ThmResult -> IO [ Int64 ]+ counterExample thmRes =+ case getModel thmRes of+ Right (False, ce) -> return ce+ Right (True, _) -> fail "Returned probable model."+ Left str -> fail str -maximum1 [] = 0-maximum1 xs = maximum xs+ pred :: Predicate+ pred = do+ freeVars <- (mkFreeVars . dimensionality) oi :: Symbolic [ SInt64 ]+ case V.fromList freeVars of+ V.VecBox freeVarVec ->+ case V.proveEqSize (NE.head oi) freeVarVec of+ Just V.ReflEq -> return $+ compile oi freeVarVec .== compile oi' freeVarVec+ Nothing -> fail $+ "Impossible: Free variables size doesn't match that of the " +++ "union parameter."+ dimensionality = V.length . NE.head++--------------------------------------------------------------------------------+-- Optimise unions+--------------------------------------------------------------------------------++instance PO.PartialOrd Offsets where+ (Offsets s) <= (Offsets s') = s <= s'+ SetOfIntegers <= Offsets{} = False+ _ <= SetOfIntegers = True++instance PO.PartialOrd (Interval Standard) where+ (IntervHoled lb ub p) <= (IntervHoled lb' ub' p') =+ (p' || not p) && lb >= lb' && ub <= ub'+ IntervInfinite <= IntervHoled{} = False+ _ <= IntervInfinite = True++instance PO.PartialOrd a => PO.PartialOrd (V.Vec n a) where+ v <= v' = and $ V.zipWith (PO.<=) v v'++optimise :: UnionNF n (Interval Standard) -> UnionNF n (Interval Standard)+optimise = NE.fromList . maximas . fixedPointUnion . NE.toList+ where+ fixedPointUnion unf =+ let unf' = unionLemma . maximas $ unf+ in if unf' == unf then unf' else fixedPointUnion unf'++sensibleGroupBy :: Eq a =>+ (a -> a -> Ordering)+ -> (a -> a -> Bool)+ -> [ a ]+ -> [ [ a ] ]+sensibleGroupBy ord p l = nub . map (\el -> sortBy ord . filter (p el) $ l) $ l++maximas :: [ V.Vec n (Interval Standard) ] -> [ V.Vec n (Interval Standard) ]+maximas = nub+ . fmap (head . PO.maxima)+ . sensibleGroupBy ord (PO.<=)+ where+ ord a b = fromJust $ a `PO.compare` b++-- | Union lemma says that if we have a product of intervals (as defined in+-- the paper) and we union two that agrees in each dimension except one.+-- The union is again a product of intervals that agrees with the original+-- dimensions in all dimensions except the original differing one. At that+-- point it is the union of intervals, which is itself still an interval.+unionLemma :: [ V.Vec n (Interval Standard) ] -> [ V.Vec n (Interval Standard) ]+unionLemma = map (foldr1 (V.zipWith (\/)))+ . sensibleGroupBy (\a b -> if a == b then EQ else LT) agreeButOne+ where+ -- This function returns true if two vectors agree at all points but one.+ -- It also holds if two vectors are identical.+ agreeButOne :: Eq a => V.Vec n a -> V.Vec n a -> Bool+ agreeButOne = go False+ where+ go :: Eq a => Bool -> V.Vec n a -> V.Vec n a -> Bool+ go _ V.Nil V.Nil = True+ go False (V.Cons x xs) (V.Cons y ys)+ | x == y = go False xs ys+ | otherwise = go True xs ys+ go True (V.Cons x xs) (V.Cons y ys)+ | x == y = go True xs ys+ | otherwise = False++--------------------------------------------------------------------------------+-- Injections for multiplicity and exactness+--------------------------------------------------------------------------------++data Approximation a = Exact a | Bound (Maybe a) (Maybe a)+ deriving (Eq, Show, Functor, Foldable, Traversable, Data, Typeable)++fromExact :: Approximation a -> a+fromExact (Exact a) = a+fromExact _ = error "Can't retrieve from bounded as if it was exact."++lowerBound :: Approximation a -> a+lowerBound (Bound (Just a) _) = a+lowerBound (Bound Nothing _) = error "Approximation doesn't have a lower bound."+lowerBound (Exact a) = a++upperBound :: Approximation a -> a+upperBound (Bound _ (Just a)) = a+upperBound (Bound _ Nothing) = error "Approximation doesn't have a upper bound."+upperBound (Exact a) = a++class Peelable a where+ type CoreTyp a+ peel :: a -> CoreTyp a++data Multiplicity a = Mult a | Once a+ deriving (Eq, Show, Functor, Foldable, Traversable, Data, Typeable)++instance Peelable (Multiplicity a) where+ type CoreTyp (Multiplicity a) = a++ peel (Mult a) = a+ peel (Once a) = a++{-+data Approximation a = Exact a | Lower a | Upper a+ deriving (Eq, Show, Functor, Data, Typeable)++instance Peelable Approximation where+ peel (Exact a) = a+ peel (Lower a) = a+ peel (Upper a) = a+-}
src/Camfort/Specification/Stencils/Syntax.hs view
@@ -19,11 +19,16 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE DeriveFunctor #-} module Camfort.Specification.Stencils.Syntax where import Camfort.Helpers+import Camfort.Specification.Stencils.Model ( Multiplicity(..)+ , peel+ , Approximation(..)+ , lowerBound, upperBound+ , fromExact+ ) import Prelude hiding (sum) @@ -41,32 +46,13 @@ {- *** 0. Representations -} --- Representation of an inference result, either exact or with some bound-data Approximation a =- Exact a | Bound (Maybe a) (Maybe a)- deriving (Eq, Data, Typeable, Show)--fromExact :: Approximation a -> a-fromExact (Exact a) = a-fromExact _ = error "Exception: fromExact on a non-exact result"--upperBound :: a -> Approximation a-upperBound x = Bound Nothing (Just x)--lowerBound :: a -> Approximation a-lowerBound x = Bound (Just x) Nothing--instance Functor Approximation where- fmap f (Exact x) = Exact (f x)- fmap f (Bound x y) = Bound (fmap f x) (fmap f y)- -- 'absoluteRep' is an integer to use to represent absolute indexing expressions -- (which may be constants, non-affine indexing expressions, or expressions -- involving non-induction variables). This is set to maxBoound :: Int usually, -- but can be made smaller for debugging purposes, -- e.g., 100, but it needs to be high enough to clash with reasonable -- relative indices.-absoluteRep = 100 :: Int -- maxBound :: Int+absoluteRep = maxBound :: Int {- *** 1 . Specification syntax -} @@ -96,7 +82,7 @@ deriving (Eq, Data, Typeable) isEmpty :: Specification -> Bool-isEmpty (Specification mult) = isUnit . fromMult $ mult+isEmpty (Specification mult) = isUnit . peel $ mult -- ********************** -- Spatial specifications:@@ -119,20 +105,13 @@ hasDuplicates :: Eq a => [a] -> ([a], Bool) hasDuplicates xs = (nub xs, nub xs /= xs) -fromMult :: Multiplicity a -> a-fromMult (Multiple a) = a-fromMult (Single a) = a- setLinearity :: Linearity -> Specification -> Specification setLinearity l (Specification mult)- | l == Linear = Specification $ Single $ fromMult mult- | l == NonLinear = Specification $ Multiple $ fromMult mult+ | l == Linear = Specification $ Once $ peel mult+ | l == NonLinear = Specification $ Mult $ peel mult data Linearity = Linear | NonLinear deriving (Eq, Data, Typeable) -data Multiplicity a = Multiple a | Single a- deriving (Eq, Data, Typeable, Functor, Show)- type Dimension = Int -- spatial dimensions are 1 indexed type Depth = Int type IsRefl = Bool@@ -190,147 +169,6 @@ regionPlus x y | x == y = Just x regionPlus x y = Nothing -instance PartialMonoid RegionProd where- emptyM = Product []-- appendM (Product []) s = Just s- appendM s (Product []) = Just s- appendM (Product [s]) (Product [s']) =- regionPlus s s' >>= (\sCombined -> return $ Product [sCombined])- appendM (Product ss) (Product ss')- | ss == ss' = Just $ Product ss- | otherwise =- case absorbReflexive ss ss' of- Just (ss0, ss1) ->- case distAndOverlaps ss0 ss1 of- Just ss'' -> return $ Product $ sort ss''- Nothing -> return $ Product $ sort (ss0 ++ ss1)- Nothing -> case distAndOverlaps ss ss' of- Just ss'' -> return $ Product $ sort ss''- Nothing -> Nothing----Based on equations:--- Forward n d + Reflexive d = Forward n d--- Backward n d + Reflexive d = Backward n d--- Centered n d + Reflexive d = Centered n d--- (and so on for n-ary cases and Backward and Centered).--absorbReflexive :: [Region] -> [Region] -> Maybe ([Region], [Region])-absorbReflexive a b =- absorbReflexive' (sortBy cmpDims a) (sortBy cmpDims b)- <|> absorbReflexive' (sortBy cmpDims b) (sortBy cmpDims a)- where cmpDims = compare `on` getDimension--absorbReflexive' [] [] = Just ([], [])-absorbReflexive' (Forward d dim reflx : rs) [Centered 0 dim' _]- | dim == dim' = Just (Forward d dim True:rs, [])--absorbReflexive' (Backward d dim reflx : rs) [Centered 0 dim' _]- | dim == dim' = Just (Backward d dim True:rs, [])--absorbReflexive' (Centered d dim reflx : rs) [Centered 0 dim' _]- | dim == dim' && d /= 0 = Just (Centered d dim True:rs, [])--absorbReflexive' _ _ = Nothing---- Implements a combination of (+DIST), (+COMM), and (OVERLAPS)-distAndOverlaps :: [Region] -> [Region] -> Maybe [Region]-distAndOverlaps x y =- if length x <= 1 || length y <= 1- then Nothing- else -- (+COMM)- distAndOverlaps' x y <|> distAndOverlaps' y x--distAndOverlaps' [] xs = Just xs-distAndOverlaps' xs [] = Just xs---- F+F-distAndOverlaps' (Forward d dim refl : rs) (Forward d' dim' refl' : rs')- | rs == rs' && dim == dim'- = Just (Forward (max d d') dim (refl || refl') : rs)---- B+B-distAndOverlaps' (Backward d dim refl : rs) (Backward d' dim' refl' : rs')- | rs == rs' && dim == dim'- = Just (Backward (max d d') dim (refl || refl') : rs)---- C+C-distAndOverlaps' (Centered d dim refl : rs) (Centered d' dim' refl' : rs')- | rs == rs' && dim == dim' && d /= 0 && d' /= 0- = Just (Centered (max d d') dim (refl || refl') : rs)---- C+F-distAndOverlaps' (Forward d dim refl : rs) (Centered d' dim' refl' : rs')- | rs == rs' && dim == dim' && d <= d' && d' /= 0- = Just (Centered d' dim (refl || refl') : rs)---- C+B-distAndOverlaps' (Backward d dim refl : rs) (Centered d' dim' refl' : rs')- | rs == rs' && dim == dim' && d <= d' && d' /= 0- = Just (Centered d' dim (refl || refl') : rs)---- F+B-distAndOverlaps' (Forward d dim reflx : rs) (Backward d' dim' reflx' : rs')- | rs == rs' && d == d' && dim == dim'- = Just (Centered d dim (reflx || reflx') : rs)---- C+R-distAndOverlaps' (Centered d dim reflx : rs) (Centered 0 dim' True : rs')- | rs == rs' && dim == dim' && d /= 0- = Just (Centered d dim True : rs)---- F+R-distAndOverlaps' (Forward d dim reflx : rs) (Centered 0 dim' True : rs')- | rs == rs' && dim == dim'- = Just (Forward d dim True : rs)---- B+R-distAndOverlaps' (Backward d dim reflx : rs) (Centered 0 dim' True : rs')- | rs == rs' && dim == dim'- = Just (Backward d dim True : rs)---- IRREFL B+!B-distAndOverlaps' p1@(Backward d1 dim1 refl1 : Backward d2 dim2 refl2 : rs)- p2@(Backward d1' dim1' refl1' : Backward d2' dim2' refl2' : rs')- | rs == rs' && dim1 == dim1' && dim2 == dim2'- && d1 == d1' && d2 == d2' && refl1 == not refl1' && refl2 == not refl2'- = Just $ [Backward d1 dim1 True, Backward d2 dim2 True] ++ rs-- | rs == rs' && dim1 == dim2' && dim2 == dim1'- && d1 == d2' && d2 == d1' && refl1 == not refl2' && refl2 == not refl1'- = Just $ [Backward d1 dim1 True, Backward d2 dim2 True] ++ rs---- IRREFL C+!C-distAndOverlaps' p1@(Centered d1 dim1 refl1 : Centered d2 dim2 refl2 : rs)- p2@(Centered d1' dim1' refl1' : Centered d2' dim2' refl2' : rs')- | rs == rs' && dim1 == dim1' && dim2 == dim2' && (d1 * d2 * d1' * d2' /= 0)- && d1 == d1' && d2 == d2' && refl1 == not refl1' && refl2 == not refl2'- = Just $ [Centered d1 dim1 True, Centered d2 dim2 True] ++ rs-- | rs == rs' && dim1 == dim2' && dim2 == dim1'- && d1 == d2' && d2 == d1' && refl1 == not refl2' && refl2 == not refl1'- = Just $ [Centered d1 dim1 True, Centered d2 dim2 True] ++ rs---- IRREFL F+!F-distAndOverlaps' p1@(Forward d1 dim1 refl1 : Forward d2 dim2 refl2 : rs)- p2@(Forward d1' dim1' refl1' : Forward d2' dim2' refl2' : rs')- | rs == rs' && dim1 == dim1' && dim2 == dim2' && (d1 * d2 * d1' * d2' /= 0)- && d1 == d1' && d2 == d2' && refl1 == not refl1' && refl2 == not refl2'- = Just $ [Forward d1 dim1 True, Forward d2 dim2 True] ++ rs-- | rs == rs' && dim1 == dim2' && dim2 == dim1' && (d1 * d2 * d1' * d2' /= 0)- && d1 == d2' && d2 == d1' && refl1 == not refl2' && refl2 == not refl1'- = Just $ [Forward d1 dim1 True, Forward d2 dim2 True] ++ rs---- push any remaining idempotence through dist--- distAndOverlaps(r*s + r*s') = r*(distAndOverlaps (s + s'))-distAndOverlaps' (r:rs) (r':rs')- | r == r' = do rs'' <- distAndOverlaps rs rs'- return $ r : rs''--distAndOverlaps' _ _ = Nothing-- -- Operations on region specifications form a semiring -- where `sum` is the additive, and `prod` is the multiplicative -- [without the annihilation property for `zero` with multiplication]@@ -390,7 +228,7 @@ do (Product spec) <- ss (Product spec') <- ss' return $ Product $ nub $ sort $ spec ++ spec'- sum (Sum ss) (Sum ss') = Sum $ normalise $ ss ++ ss'+ sum (Sum ss) (Sum ss') = Sum $ ss ++ ss' zero = Sum [] one = Sum [Product []] isUnit s@(Sum ss) = s == zero || s == one || all (== Product []) ss@@ -410,18 +248,20 @@ instance {-# OVERLAPS #-} Show (Multiplicity (Approximation Spatial)) where show mult- | Multiple appr <- mult = apprStr empty appr- | Single appr <- mult = apprStr "readOnce, " appr+ | Mult appr <- mult = apprStr empty empty appr+ | Once appr <- mult = apprStr "readOnce" ", " appr where- apprStr linearity appr =+ apprStr linearity sep appr = case appr of- Exact s -> linearity ++ show s+ Exact s -> linearity ++ optionalSeparator sep (show s) Bound Nothing Nothing -> "empty"- Bound Nothing (Just s) -> "atMost, " ++ linearity ++ show s- Bound (Just s) Nothing -> "atLeast, " ++ linearity ++ show s+ Bound Nothing (Just s) -> "atMost, " ++ linearity ++ optionalSeparator sep (show s)+ Bound (Just s) Nothing -> "atLeast, " ++ linearity ++ optionalSeparator sep (show s) Bound (Just sL) (Just sU) ->- "atLeast, " ++ linearity ++ show sL ++- "; atMost, " ++ linearity ++ show sU+ "atLeast, " ++ linearity ++ optionalSeparator sep (show sL) +++ "; atMost, " ++ linearity ++ optionalSeparator sep (show sU)+ optionalSeparator sep "" = ""+ optionalSeparator sep s = sep ++ s instance {-# OVERLAPS #-} Show (Approximation Spatial) where show (Exact s) = show s@@ -459,13 +299,13 @@ show (Forward dep dim reflx) = showRegion "forward" dep dim reflx show (Backward dep dim reflx) = showRegion "backward" dep dim reflx show (Centered dep dim reflx)- | dep == 0 = "reflexive(dim=" ++ show dim ++ ")"+ | dep == 0 = "pointed(dim=" ++ show dim ++ ")" | otherwise = showRegion "centered" dep dim reflx -- Helper for showing regions showRegion typ depS dimS reflx = typ ++ "(depth=" ++ show depS ++ ", dim=" ++ show dimS- ++ (if reflx then "" else ", irreflexive")+ ++ (if reflx then "" else ", nonpointed") ++ ")" -- Helper for reassociating an association list, grouping the keys together that
src/Camfort/Specification/Stencils/Synthesis.hs view
@@ -20,34 +20,20 @@ module Camfort.Specification.Stencils.Synthesis where -import Data.Data import Data.List import Data.Maybe import qualified Data.Map as M-import Data.Generics.Uniplate.Operations-import Control.Monad.State.Lazy-import Control.Monad.Reader-import Control.Monad.Writer hiding (Product) -import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.Syntax-import Camfort.Specification.Stencils.Model import Camfort.Analysis.Annotations-import Camfort.Helpers.Vec--- These two are redefined here for ForPar ASTs-import Camfort.Helpers hiding (lineCol, spanLineCol) import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Types as FAT import qualified Language.Fortran.Analysis.Renaming as FAR-import qualified Language.Fortran.Analysis.BBlocks as FAB-import qualified Language.Fortran.Analysis.DataFlow as FAD import qualified Language.Fortran.Util.Position as FU import Language.Fortran.Util.Position-import Data.Map hiding (map) -- Format inferred specifications formatSpec ::@@ -65,7 +51,7 @@ Nothing -> show span ++ " " Just pr -> pr -formatSpec prefix nm (span, Left []) = ""+formatSpec _ _ (_, Left []) = "" formatSpec prefix nm (span, Left specs) = (intercalate "\n" $ map (\s -> prefix' ++ doSpec s) specs) where
src/Camfort/Specification/Units.hs view
@@ -22,17 +22,24 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} module Camfort.Specification.Units- (checkUnits, inferUnits, synthesiseUnits, inferCriticalVariables)+ (checkUnits, inferUnits, compileUnits, synthesiseUnits, inferCriticalVariables, chooseImplicitNames) where import qualified Data.Map.Strict as M+import Data.Data import Data.Char (isNumber)-import Data.List (intercalate)-import Data.Maybe (fromMaybe, maybeToList, listToMaybe, mapMaybe)+import Data.List (intercalate, find, sort, group, nub, inits)+import Data.Maybe (fromMaybe, maybeToList, listToMaybe, mapMaybe, isJust, maybe)+import Data.Binary import Data.Generics.Uniplate.Operations+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as LB import Control.Monad.State.Strict+import GHC.Generics (Generic) import Camfort.Helpers hiding (lineCol) import Camfort.Helpers.Syntax@@ -48,9 +55,11 @@ import Camfort.Specification.Units.Synthesis (runSynthesis) import qualified Language.Fortran.Analysis.Renaming as FAR+import qualified Language.Fortran.Analysis.Types as FAT import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.AST as F import qualified Language.Fortran.Util.Position as FU+import Language.Fortran.Util.ModFile -- For debugging and development purposes import qualified Debug.Trace as D@@ -71,33 +80,50 @@ -- Format report 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 [ " " ++ expReport ei | ei <- expInfo ], numVars)+ okReport vars = ( logs ++ "\n" ++ fname ++ ": "+ ++ show numVars+ ++ " variable declarations suggested to be given a specification:\n"+ ++ unlines [ " " ++ declReport d | d <- M.toList dmapSlice ]+ , numVars) where- names = map showVar vars- expInfo = filter ((`elem` names) . FA.srcName) $ declVariables pfUA- numVars = length expInfo-- expReport e = "(" ++ showSrcSpan (FU.getSpan e) ++ ") " ++ FA.srcName e+ varNames = map unitVarName vars+ dmapSlice = M.filterWithKey (\ k _ -> k `elem` varNames) dmap+ numVars = M.size dmapSlice - varReport = intercalate ", " . map showVar+ declReport (v, (dc, ss)) = vfilename ++ " (" ++ showSrcSpan ss ++ ") " ++ fromMaybe v (M.lookup v uniqnameMap)+ where vfilename = fromMaybe fname $ M.lookup v fromWhereMap - showVar (UnitVar (_, s)) = s- showVar (UnitLiteral _) = "<literal>"- showVar _ = "<bad>"+ unitVarName (UnitVar (v, _)) = v+ unitVarName (UnitParamVarUse (_, (v, _), _)) = v+ unitVarName _ = "<bad>" errReport exc = logs ++ "\n" ++ fname ++ ":\n" ++ show exc -- run inference- uOpts = uo { uoNameMap = nameMap }- (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runCriticalVariables+ uOpts = uo { uoNameMap = FAR.extractNameMap pfRenamed }+ (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ do+ modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ initInference+ runCriticalVariables pfUA = usProgramFile state -- the program file after units analysis is done - pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf- nameMap = FAR.extractNameMap pfRenamed+ -- Use the module map derived from all of the included Camfort Mod files.+ mmap = combinedModuleMap (M.elems (uoModFiles uo))+ pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf + -- Map of all declarations+ dmap = extractDeclMap pfRenamed `M.union` combinedDeclMap (M.elems (uoModFiles uo))++ mmap' = extractModuleMap pfRenamed `M.union` mmap -- post-parsing+ -- unique name -> src name across modules+ uniqnameMap = M.fromList [+ (FA.varName e, FA.srcName e) |+ e@(F.ExpValue _ _ (F.ValVariable {})) <- universeBi pfRenamed :: [F.Expression UA]+ -- going to ignore intrinsics here+ ] `M.union` (M.unions . map (M.fromList . map (\ (a, (b, _)) -> (b, a)) . M.toList) $ M.elems mmap')+ fromWhereMap = genUniqNameToFilenameMap . M.elems $ uoModFiles uo+ checkUnits, inferUnits :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> Report {-| Check units-of-measure for a program -}@@ -106,14 +132,17 @@ | Left exc <- eCons = errReport exc where -- Format report- okReport Nothing = logs ++ "\n" ++ fname ++ ": Consistent. " ++ show nVars ++ " variables checked."- okReport (Just cons) = logs ++ "\n" ++ fname ++ ": Inconsistent:\n" ++ reportErrors cons+ okReport Nothing = logs ++ "\n" ++ fname ++ ": Consistent. " ++ show nVars ++ " variables checked."+ okReport (Just cons) = logs ++ "\n" ++ fname ++ ": Inconsistent:\n" ++ reportErrors cons ++ "\n\n" +++ unlines (map show constraints) - reportErrors cons = unlines [ reportError con | con <- cons ]- reportError con = " - at " ++ srcSpan con- ++ pprintConstr (orient (unrename nameMap con))- ++ additionalInfo con+ reportErrors cons = unlines [ maybe "" showSS ss ++ str | (ss, str) <- reports ] where+ reports = map head . group . sort $ map reportError cons+ showSS = (++ ": ") . (" - at "++) . showSrcSpan++ reportError con = (findCon con, pprintConstr (orient (unrename nameMap con)) ++ additionalInfo con)+ where -- Create additional info for errors additionalInfo con = if null (errorInfo con)@@ -137,6 +166,7 @@ mapNotFirst f (x : xs) = x : (map f xs) orient (ConEq u (UnitVar v)) = ConEq (UnitVar v) u+ orient (ConEq u (UnitParamVarUse v)) = ConEq (UnitParamVarUse v) u orient c = c pad o = (++) (replicate o ' ')@@ -145,14 +175,19 @@ | otherwise = "" -- Find a given constraint within the annotated AST. FIXME: optimise+ findCon :: Constraint -> Maybe FU.SrcSpan- findCon con = listToMaybe $ [ FU.getSpan x | x <- universeBi pfUA :: [F.Expression UA], getConstraint x `eq` con ] ++- [ FU.getSpan x | x <- universeBi pfUA :: [F.Statement UA] , getConstraint x `eq` con ] ++- [ FU.getSpan x | x <- universeBi pfUA :: [F.Declarator UA], getConstraint x `eq` con ] ++- [ FU.getSpan x | x <- universeBi pfUA :: [F.Argument UA] , getConstraint x `eq` con ]- where eq Nothing _ = False- eq (Just c1) c2 = conParamEq c1 c2+ findCon con = lookupWith (eq con) constraints+ where eq c1 c2 = or [ conParamEq c1 c2' | c2' <- universeBi c2 ] + constraints = [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Expression UA] , c <- maybeToList (getConstraint x) ] +++ [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Statement UA] , c <- maybeToList (getConstraint x) ] +++ [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Argument UA] , c <- maybeToList (getConstraint x) ] +++ [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.Declarator UA] , c <- maybeToList (getConstraint x) ] +++ -- Why reverse? So that PUFunction and PUSubroutine appear first in the list, before PUModule.+ reverse [ (c, FU.getSpan x) | x <- universeBi pfUA :: [F.ProgramUnit UA]+ , c <- maybeToList (getConstraint x) ]+ varReport = intercalate ", " . map showVar showVar (UnitVar (_, s)) = s@@ -163,7 +198,11 @@ -- run inference uOpts = uo { uoNameMap = nameMap }- (eCons, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInconsistentConstraints+ (eCons, state, logs) = runUnitSolver uOpts pfRenamed $ do+ modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ initInference+ runInconsistentConstraints templateMap = usTemplateMap state pfUA :: F.ProgramFile UA pfUA = usProgramFile state -- the program file after units analysis is done@@ -174,9 +213,34 @@ UnitParamVarAbs {} -> True; UnitParamVarUse {} -> True _ -> False - pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf+ -- Use the module map derived from all of the included Camfort Mod files.+ mmap = combinedModuleMap (M.elems (uoModFiles uo))+ pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf nameMap = FAR.extractNameMap pfRenamed +lookupWith :: (a -> Bool) -> [(a,b)] -> Maybe b+lookupWith f = fmap snd . find (f . fst)++-- | Create unique names for all of the inferred implicit polymorphic+-- unit variables.+chooseImplicitNames :: [(VV, UnitInfo)] -> [(VV, UnitInfo)]+chooseImplicitNames vars = replaceImplicitNames (genImplicitNamesMap vars) vars++genImplicitNamesMap :: Data a => a -> M.Map UnitInfo UnitInfo+genImplicitNamesMap x = M.fromList [ (absU, UnitParamEAPAbs (newN, newN)) | (absU, newN) <- zip absUnits newNames ]+ where+ absUnits = nub [ u | u@(UnitParamPosAbs _) <- universeBi x ]+ eapNames = nub $ [ n | u@(UnitParamEAPAbs (_, n)) <- universeBi x ] +++ [ n | u@(UnitParamEAPUse ((_, n), _)) <- universeBi x ]+ newNames = filter (`notElem` eapNames) . map ('\'':) $ nameGen+ nameGen = concatMap sequence . tail . inits $ repeat ['a'..'z']++replaceImplicitNames :: Data a => M.Map UnitInfo UnitInfo -> a -> a+replaceImplicitNames implicitMap = transformBi replace+ where+ replace u@(UnitParamPosAbs _) = fromMaybe u $ M.lookup u implicitMap+ replace u = u+ {-| Check and infer units-of-measure for a program This produces an output of all the unit information for a program -} inferUnits uo (fname, pf)@@ -185,24 +249,94 @@ | Left exc <- eVars = errReport exc where -- Format report- okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ]+ okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] ++ show vars where- expInfo = [ (e, u) | e <- declVariables pfUA- , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ]+ expInfo = [ (ei, u) | ei@(ExpInfo _ vname sname) <- declVariableNames pfUA+ , u <- maybeToList ((vname, sname) `lookup` vars) ] - expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e+ expReport (ExpInfo ss vname sname, u) = " " ++ showSrcSpan ss ++ " unit " ++ show u ++ " :: " ++ sname errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap }- (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables+ (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ do+ modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ initInference+ chooseImplicitNames `fmap` runInferVariables pfUA = usProgramFile state -- the program file after units analysis is done - pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf+ -- Use the module map derived from all of the included Camfort Mod files.+ mmap = combinedModuleMap (M.elems (uoModFiles uo))+ pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf+ nameMap = FAR.extractNameMap pfRenamed +combinedCompiledUnits :: ModFiles -> CompiledUnits+combinedCompiledUnits mfs = CompiledUnits { cuTemplateMap = M.unions tmaps+ , cuNameParamMap = M.unions nmaps }+ where+ cus = map mfCompiledUnits mfs+ tmaps = map cuTemplateMap cus+ nmaps = map cuNameParamMap cus++-- | Name of the labeled data within a ModFile containing unit-specific info.+unitsCompiledDataLabel = "units-compiled-data"++mfCompiledUnits :: ModFile -> CompiledUnits+mfCompiledUnits mf = case lookupModFileData unitsCompiledDataLabel mf of+ Nothing -> emptyCompiledUnits+ Just bs -> case decodeOrFail (LB.fromStrict bs) of+ Left _ -> emptyCompiledUnits+ Right (_, _, cu) -> cu++genUnitsModFile :: F.ProgramFile UA -> CompiledUnits -> ModFile+genUnitsModFile pf cu = alterModFileData f unitsCompiledDataLabel $ genModFile pf+ where+ f _ = Just . LB.toStrict $ encode cu++compileUnits :: UnitOpts -> [FileProgram] -> (String, [(Filename, B.ByteString)])+compileUnits uo fileprogs = (concat reports, concat bins)+ where+ (reports, bins) = unzip [ (report, bin) | fileprog <- fileprogs+ , let (report, bin) = compileUnits' uo fileprog ]++compileUnits' :: UnitOpts -> FileProgram -> (String, [(Filename, B.ByteString)])+compileUnits' uo (fname, pf)+ | Right cu <- eCUnits = okReport cu+ | Left exc <- eCUnits = errReport exc+ where+ -- Format report+ okReport cu = ( logs ++ "\n" ++ fname ++ ":\n" ++ if uoDebug uo then debugInfo else []+ -- FIXME, filename manipulation (needs to go in -I dir?)+ , [(fname ++ modFileSuffix, encodeModFile (genUnitsModFile pfTyped cu))] )+ where+ debugInfo = unlines [ n ++ ":\n " ++ intercalate "\n " (map show cs) | (n, cs) <- M.toList (cuTemplateMap cu) ] +++ unlines ("nameParams:" : (map show . M.toList $ cuNameParamMap cu))+++ errReport exc = ( logs ++ "\n" ++ fname ++ ": " ++ show exc+ , [] )+ -- run inference+ uOpts = uo { uoNameMap = nameMap }+ (eCUnits, state, logs) = runUnitSolver uOpts pfTyped $ do+ modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ initInference+ runCompileUnits++ pfUA = usProgramFile state -- the program file after units analysis is done++ -- Use the module map derived from all of the included Camfort Mod files.+ mmap = combinedModuleMap (M.elems (uoModFiles uo))+ tenv = combinedTypeEnv (M.elems (uoModFiles uo))+ pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf+ pfTyped = fst . FAT.analyseTypesWithEnv tenv $ pfRenamed++ nameMap = FAR.extractNameMap pfTyped+ synthesiseUnits :: UnitOpts -> Char -> (Filename, F.ProgramFile Annotation)@@ -216,21 +350,27 @@ -- Format report okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] where- expInfo = [ (e, u) | e <- declVariables pfUA- , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ]+ expInfo = [ (ei, u) | ei@(ExpInfo _ vname sname) <- declVariableNames pfUA+ , u <- maybeToList ((vname, sname) `lookup` vars) ] - expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e+ expReport (ExpInfo ss vname sname, u) = " " ++ showSrcSpan ss ++ " unit " ++ show u ++ " :: " ++ sname errReport exc = logs ++ "\n" ++ fname ++ ": " ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap }- (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables >>= runSynthesis marker+ (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ do+ modifyTemplateMap . const . cuTemplateMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ modifyNameParamMap . const . cuNameParamMap . combinedCompiledUnits . M.elems $ uoModFiles uo+ initInference+ runInferVariables >>= (runSynthesis marker . chooseImplicitNames) pfUA = usProgramFile state -- the program file after units analysis is done pfFinal = fmap prevAnnotation . fmap FA.prevAnnotation $ pfUA -- strip annotations - pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf+ -- Use the module map derived from all of the included Camfort Mod files.+ mmap = combinedModuleMap (M.elems (uoModFiles uo))+ pfRenamed = FAR.analyseRenamesWithModuleMap mmap . FA.initAnalysis . fmap mkUnitAnnotation $ pf nameMap = FAR.extractNameMap pfRenamed --------------------------------------------------@@ -240,8 +380,23 @@ showSrcSpan :: FU.SrcSpan -> String showSrcSpan (FU.SrcSpan l u) = show l -declVariables :: F.ProgramFile UA -> [F.Expression UA]-declVariables pf = flip mapMaybe (universeBi pf) $ \ d -> case d of- F.DeclVariable _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ -> Just v- F.DeclArray _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just v+data ExpInfo = ExpInfo { expInfoSrcSpan :: FU.SrcSpan, expInfoVName :: F.Name, expInfoSName :: F.Name }+ deriving (Show, Eq, Ord, Typeable, Data, Generic)++-- | List of declared variables (including both decl statements & function returns, defaulting to first)+declVariableNames :: F.ProgramFile UA -> [ExpInfo]+declVariableNames pf = sort . M.elems $ M.unionWith (curry fst) declInfo puInfo+ where+ declInfo = M.fromList [ (expInfoVName ei, ei) | ei <- declVariableNamesDecl pf ]+ puInfo = M.fromList [ (expInfoVName ei, ei) | ei <- declVariableNamesPU pf ]++declVariableNamesDecl :: F.ProgramFile UA -> [ExpInfo]+declVariableNamesDecl pf = flip mapMaybe (universeBi pf :: [F.Declarator UA]) $ \ d -> case d of+ F.DeclVariable _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))+ F.DeclArray _ ss v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v)) _ -> Nothing+declVariableNamesPU :: F.ProgramFile UA -> [ExpInfo]+declVariableNamesPU pf = flip mapMaybe (universeBi pf :: [F.ProgramUnit UA]) $ \ pu -> case pu of+ F.PUFunction _ ss _ _ _ _ (Just v@(F.ExpValue _ _ (F.ValVariable _))) _ _ -> Just (ExpInfo ss (FA.varName v) (FA.srcName v))+ F.PUFunction _ ss _ _ _ _ Nothing _ _ -> Just (ExpInfo ss (puName pu) (puSrcName pu))+ _ -> Nothing
src/Camfort/Specification/Units/Environment.hs view
@@ -13,7 +13,7 @@ See the License for the specific language governing permissions and limitations under the License. -}-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, PatternGuards #-} {- Provides various data types and type class instances for the Units extension -}@@ -33,6 +33,8 @@ import Data.List import Data.Matrix import Data.Ratio+import Data.Binary+import GHC.Generics (Generic) import qualified Debug.Trace as D import Text.Printf@@ -44,10 +46,12 @@ data UnitInfo = UnitParamPosAbs (String, Int) -- an abstract parameter identified by PU name and argument position | UnitParamPosUse (String, Int, Int) -- identify particular instantiation of parameters- | UnitParamVarAbs (String, String) -- an abstract parameter identified by PU name and variable name- | UnitParamVarUse (String, String, Int) -- a particular instantiation of above+ | UnitParamVarAbs (String, VV) -- an abstract parameter identified by PU name and variable name+ | UnitParamVarUse (String, VV, Int) -- a particular instantiation of above | UnitParamLitAbs Int -- a literal with abstract, polymorphic units, uniquely identified | UnitParamLitUse (Int, Int) -- a particular instantiation of a polymorphic literal+ | UnitParamEAPAbs VV -- an abstract Explicitly Annotated Polymorphic unit variable+ | UnitParamEAPUse (VV, Int) -- a particular instantiation of an Explicitly Annotated Polymorphic unit variable | UnitLiteral Int -- literal with undetermined but uniquely identified units | UnitlessLit -- a unitless literal | UnitlessVar -- a unitless variable@@ -56,30 +60,39 @@ | UnitVar VV -- variable with undetermined units: (unique name, source name) | UnitMul UnitInfo UnitInfo -- two units multiplied | UnitPow UnitInfo Double -- a unit raised to a constant power- deriving (Eq, Ord, Data, Typeable)+ | UnitRecord [(String, UnitInfo)] -- 'record'-type of units+ deriving (Eq, Ord, Data, Typeable, Generic) +instance Binary UnitInfo+ instance Show UnitInfo where show u = case u of- UnitParamPosAbs (f, i) -> printf "#<ParamPosAbs %s[%d]>" f i- UnitParamPosUse (f, i, j) -> printf "#<ParamPosUse %s[%d] callId=%d>" f i j- UnitParamVarAbs (f, v) -> printf "#<ParamVarAbs %s.%s>" f v- UnitParamVarUse (f, v, j) -> printf "#<ParamVarUse %s.%s callId=%d>" f v j- UnitParamLitAbs i -> printf "#<ParamLitAbs litId=%d>" i- UnitParamLitUse (i, j) -> printf "#<ParamLitUse litId=%d callId=%d]>" i j- UnitLiteral i -> printf "#<Literal id=%d>" i- UnitlessLit -> "1"- UnitlessVar -> "1"- UnitName name -> name- UnitAlias name -> name- UnitVar (vName, _) -> printf "#<Var %s>" vName+ UnitParamPosAbs (f, i) -> printf "#<ParamPosAbs %s[%d]>" f i+ UnitParamPosUse (f, i, j) -> printf "#<ParamPosUse %s[%d] callId=%d>" f i j+ UnitParamVarAbs (f, (v, _)) -> printf "#<ParamVarAbs %s.%s>" f v+ UnitParamVarUse (f, (v, _), j) -> printf "#<ParamVarUse %s.%s callId=%d>" f v j+ UnitParamLitAbs i -> printf "#<ParamLitAbs litId=%d>" i+ UnitParamLitUse (i, j) -> printf "#<ParamLitUse litId=%d callId=%d]>" i j+ UnitParamEAPAbs (v, _) -> v+ UnitParamEAPUse ((v, _), i) -> printf "#<ParamEAPUse %s callId=%d]>" v i+ UnitLiteral i -> printf "#<Literal id=%d>" i+ UnitlessLit -> "1"+ UnitlessVar -> "1"+ UnitName name -> name+ UnitAlias name -> name+ UnitVar (vName, _) -> printf "#<Var %s>" vName+ UnitRecord recs -> "record (" ++ intercalate ", " (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")" UnitMul u1 (UnitPow u2 k)- | k < 0 -> maybeParen u1 ++ " / " ++ maybeParen (UnitPow u2 (-k))- UnitMul u1 u2 -> maybeParenS u1 ++ " " ++ maybeParenS u2- UnitPow u 1 -> show u- UnitPow u 0 -> "1"- UnitPow u k ->+ | k < 0 -> maybeParen u1 ++ " / " ++ maybeParen (UnitPow u2 (-k))+ UnitMul u1 u2 -> maybeParenS u1 ++ " " ++ maybeParenS u2+ UnitPow u 1 -> show u+ UnitPow u 0 -> "1"+ UnitPow u k -> -- printf "%s**%f" (maybeParen u) k case doubleToRationalSubset k of- Just r -> printf "%s**%s" (maybeParen u) (showRational r)+ Just r+ | e <- showRational r+ , e /= "1" -> printf "%s**%s" (maybeParen u) e+ | otherwise -> show u Nothing -> error $ printf "Irrational unit exponent: %s**%f" (maybeParen u) k where showRational r@@ -87,7 +100,7 @@ | otherwise = showRational' r showRational' r | denominator r == 1 = show (numerator r)- | otherwise = printf "%s / %s" (numerator r) (denominator r)+ | otherwise = printf "(%d / %d)" (numerator r) (denominator r) where maybeParen x | all isAlphaNum s = s | otherwise = "(" ++ s ++ ")"@@ -125,21 +138,49 @@ data Constraint = ConEq UnitInfo UnitInfo -- an equality constraint | ConConj [Constraint] -- conjunction of constraints- deriving (Eq, Ord, Data, Typeable)+ deriving (Eq, Ord, Data, Typeable, Generic)++instance Binary Constraint+ type Constraints = [Constraint] instance Show Constraint where show (ConEq u1 u2) = show u1 ++ " === " ++ show u2 show (ConConj cs) = intercalate " && " (map show cs) +isVarUnit (UnitVar _) = True+isVarUnit (UnitParamVarUse _) = True+isVarUnit _ = False++isUnresolvedUnit (UnitVar _) = True+isUnresolvedUnit (UnitParamVarUse _) = True+isUnresolvedUnit (UnitParamVarAbs _) = True+isUnresolvedUnit (UnitParamPosUse _) = True+isUnresolvedUnit (UnitParamPosAbs _) = True+isUnresolvedUnit (UnitParamLitUse _) = True+isUnresolvedUnit (UnitParamLitAbs _) = True+isUnresolvedUnit (UnitParamEAPAbs _) = True+isUnresolvedUnit (UnitParamEAPUse _) = True+isUnresolvedUnit (UnitPow u _) = isUnresolvedUnit u+isUnresolvedUnit (UnitMul u1 u2) = isUnresolvedUnit u1 || isUnresolvedUnit u2+isUnresolvedUnit _ = False++isResolvedUnit = not . isUnresolvedUnit+ pprintConstr :: Constraint -> String-pprintConstr (ConEq u1@(UnitVar _) u2@(UnitVar _))- = "'" ++ pprintUnitInfo u1 ++ "' should have the same units as '" ++ pprintUnitInfo u2 ++ "'"-pprintConstr (ConEq u1 u2) = "'" ++ pprintUnitInfo u1 ++ "' should be '" ++ pprintUnitInfo u2 ++ "'"-pprintConstr (ConConj cs) = intercalate "\n\t and " (map pprintConstr cs)+pprintConstr (ConEq u1 u2)+ | isResolvedUnit u1 = "'" ++ pprintUnitInfo u2 ++ "' should have unit '" ++ pprintUnitInfo u1 ++ "'"+ | isResolvedUnit u2 = "'" ++ pprintUnitInfo u1 ++ "' should have unit '" ++ pprintUnitInfo u2 ++ "'"+pprintConstr (ConEq u1 u2) = "'" ++ pprintUnitInfo u1 ++ "' should have the same units as '" ++ pprintUnitInfo u2 ++ "'"+pprintConstr (ConConj cs) = intercalate "\n\t and " (map pprintConstr cs) pprintUnitInfo :: UnitInfo -> String pprintUnitInfo (UnitVar (_, sName)) = printf "%s" sName+pprintUnitInfo (UnitParamVarUse (_, (_, sName), _)) = printf "%s" sName+pprintUnitInfo (UnitParamPosUse (fname, 0, _)) = printf "result of %s" fname+pprintUnitInfo (UnitParamPosUse (fname, i, _)) = printf "parameter %d to %s" i fname+pprintUnitInfo (UnitParamEAPUse ((v, _), _)) = printf "explicitly annotated polymorphic unit %s" v+pprintUnitInfo (UnitLiteral _) = "literal number" pprintUnitInfo ui = show ui --------------------------------------------------@@ -147,8 +188,8 @@ -- | Constraint 'parametric' equality: treat all uses of a parametric -- abstractions as equivalent to the abstraction. conParamEq :: Constraint -> Constraint -> Bool-conParamEq (ConEq lhs1 rhs1) (ConEq lhs2 rhs2) = (unitParamEq lhs1 lhs2 && unitParamEq rhs1 rhs2) ||- (unitParamEq rhs1 lhs2 && unitParamEq lhs1 rhs2)+conParamEq (ConEq lhs1 rhs1) (ConEq lhs2 rhs2) = unitParamEq lhs1 lhs2 || unitParamEq rhs1 rhs2 ||+ unitParamEq rhs1 lhs2 || unitParamEq lhs1 rhs2 conParamEq (ConConj cs1) (ConConj cs2) = and $ zipWith conParamEq cs1 cs2 conParamEq _ _ = False @@ -161,6 +202,8 @@ unitParamEq (UnitParamVarUse (f', i', _)) (UnitParamVarAbs (f, i)) = (f, i) == (f', i') unitParamEq (UnitParamPosAbs (f, i)) (UnitParamPosUse (f', i', _)) = (f, i) == (f', i') unitParamEq (UnitParamPosUse (f', i', _)) (UnitParamPosAbs (f, i)) = (f, i) == (f', i')+unitParamEq (UnitParamEAPAbs v) (UnitParamEAPUse (v', _)) = v == v'+unitParamEq (UnitParamEAPUse (v', _)) (UnitParamEAPAbs v) = v == v' unitParamEq (UnitMul u1 u2) (UnitMul u1' u2') = unitParamEq u1 u1' && unitParamEq u2 u2' || unitParamEq u1 u2' && unitParamEq u2 u1' unitParamEq (UnitPow u p) (UnitPow u' p') = unitParamEq u u' && p == p'@@ -170,40 +213,43 @@ -- The annotation on the AST used for solving units. data UnitAnnotation a = UnitAnnotation {- prevAnnotation :: a,- unitSpec :: Maybe P.UnitStatement,- unitConstraint :: Maybe Constraint,- unitInfo :: Maybe UnitInfo,- unitBlock :: Maybe (F.Block (FA.Analysis (UnitAnnotation a))) }- deriving (Data, Typeable, Show)+ prevAnnotation :: a,+ unitSpec :: Maybe P.UnitStatement,+ unitConstraint :: Maybe Constraint,+ unitInfo :: Maybe UnitInfo,+ unitBlock :: Maybe (F.Block (FA.Analysis (UnitAnnotation a))), -- ^ linked variable declaration+ unitPU :: Maybe (F.ProgramUnit (FA.Analysis (UnitAnnotation a))) -- ^ linked program unit+ } deriving (Data, Typeable, Show) -dbgUnitAnnotation (UnitAnnotation _ s c i b) =+dbgUnitAnnotation (UnitAnnotation _ s c i b p) = "{ unitSpec = " ++ show s ++ ", unitConstraint = " ++ show c ++ ", unitInfo = " ++ show i ++ ", unitBlock = " ++ (case b of Nothing -> "Nothing" Just (F.BlStatement _ span _ (F.StDeclaration {})) -> "Just {decl}@" ++ show span Just (F.BlStatement _ span _ _) -> "Just {stmt}@" ++ show span Just _ -> "Just ...")+ ++ ", unitPU = " +++ (case p of+ Nothing -> "Nothing"+ Just (F.PUFunction _ span _ _ _ _ _ _ _) -> "Just {func}@" ++ show span+ Just (F.PUSubroutine _ span _ _ _ _ _) -> "Just {subr}@" ++ show span+ Just _ -> "Just ...") ++ "}" mkUnitAnnotation :: a -> UnitAnnotation a-mkUnitAnnotation a = UnitAnnotation a Nothing Nothing Nothing Nothing+mkUnitAnnotation a = UnitAnnotation a Nothing Nothing Nothing Nothing Nothing -------------------------------------------------- -- | Convert parser units to UnitInfo-toUnitInfo :: P.UnitOfMeasure -> UnitInfo-toUnitInfo (P.UnitProduct u1 u2) =- UnitMul (toUnitInfo u1) (toUnitInfo u2)-toUnitInfo (P.UnitQuotient u1 u2) =- UnitMul (toUnitInfo u1) (UnitPow (toUnitInfo u2) (-1))-toUnitInfo (P.UnitExponentiation u1 p) =- UnitPow (toUnitInfo u1) (toDouble p)+toUnitInfo :: P.UnitOfMeasure -> UnitInfo+toUnitInfo (P.UnitProduct u1 u2) = UnitMul (toUnitInfo u1) (toUnitInfo u2)+toUnitInfo (P.UnitQuotient u1 u2) = UnitMul (toUnitInfo u1) (UnitPow (toUnitInfo u2) (-1))+toUnitInfo (P.UnitExponentiation u1 p) = UnitPow (toUnitInfo u1) (toDouble p) where- toDouble :: P.UnitPower -> Double- toDouble (P.UnitPowerInteger i) = fromInteger i+ toDouble :: P.UnitPower -> Double+ toDouble (P.UnitPowerInteger i) = fromInteger i toDouble (P.UnitPowerRational x y) = fromRational (x % y)-toUnitInfo (P.UnitBasic str) =- UnitName str-toUnitInfo (P.Unitless) =- UnitlessLit+toUnitInfo (P.UnitBasic str) = UnitName str+toUnitInfo (P.Unitless) = UnitlessLit+toUnitInfo (P.UnitRecord us) = UnitRecord (map (fmap toUnitInfo) us)
src/Camfort/Specification/Units/InferenceBackend.hs view
@@ -18,19 +18,20 @@ Units of measure extension to Fortran: backend -} -{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} module Camfort.Specification.Units.InferenceBackend ( inconsistentConstraints, criticalVariables, inferVariables -- mainly for debugging and testing:- , shiftTerms, flattenConstraints, flattenUnits, constraintsToMatrix, rref, isInconsistentRREF )+ , shiftTerms, flattenConstraints, flattenUnits, constraintsToMatrix, constraintsToMatrices+ , rref, isInconsistentRREF, genUnitAssignments ) where import Data.Tuple (swap) import Data.Maybe (maybeToList)-import Data.List ((\\), findIndex, partition, sortBy, group)-import Data.Generics.Uniplate.Operations (rewrite)+import Data.List ((\\), findIndex, partition, sortBy, group, intercalate, tails, sort)+import Data.Generics.Uniplate.Operations (rewrite, universeBi) import Control.Monad import Control.Monad.State.Strict import Control.Monad.ST@@ -48,7 +49,7 @@ ) import qualified Numeric.LinearAlgebra as H import Numeric.LinearAlgebra.Devel (- newMatrix, readMatrix, writeMatrix, runSTMatrix+ newMatrix, readMatrix, writeMatrix, runSTMatrix, freezeMatrix, STMatrix ) import qualified Debug.Trace as D@@ -63,7 +64,7 @@ | null inconsists = Nothing | otherwise = Just [ con | (con, i) <- zip cons [0..], i `elem` inconsists ] where- (unsolvedM, inconsists, colA) = constraintsToMatrix cons+ (_, _, inconsists, _, _) = constraintsToMatrices cons -------------------------------------------------- @@ -71,31 +72,56 @@ -- inference or checking to work. criticalVariables :: Constraints -> [UnitInfo] criticalVariables [] = []-criticalVariables cons = filter (not . isUnitName) $ map (colA A.!) criticalIndices+criticalVariables cons = filter (not . isUnitRHS) $ map (colA A.!) criticalIndices where (unsolvedM, inconsists, colA) = constraintsToMatrix cons solvedM = rref unsolvedM uncriticalIndices = concatMap (maybeToList . findIndex (/= 0)) $ H.toLists solvedM criticalIndices = A.indices colA \\ uncriticalIndices- isUnitName (UnitName _) = True; isUnitName _ = False+ isUnitRHS (UnitName _) = True; isUnitRHS _ = False -------------------------------------------------- -- | Returns list of formerly-undetermined variables and their units. inferVariables :: Constraints -> [(VV, UnitInfo)]-inferVariables [] = []-inferVariables cons- | null inconsists = [ (var, if null units then UnitlessVar else foldl1 UnitMul units)- | ([UnitPow (UnitVar var) k], units) <- map (partition (not . isUnitName)) unitPows- , k `approxEq` 1 ]+inferVariables cons = unitVarAssignments+ where+ unitAssignments = genUnitAssignments cons+ -- Find the rows corresponding to the distilled "unit :: var"+ -- information for ordinary (non-polymorphic) variables.+ unitVarAssignments =+ [ (var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssignments, k `approxEq` 1 ] +++ [ (var, units) | ([UnitPow (UnitParamVarAbs (_, var)) k], units) <- unitAssignments, k `approxEq` 1 ]++-- | Raw units-assignment pairs.+genUnitAssignments :: [Constraint] -> [([UnitInfo], UnitInfo)]+genUnitAssignments cons+ | null inconsists = unitAssignments | otherwise = [] where- (unsolvedM, inconsists, colA) = constraintsToMatrix cons- solvedM = rref unsolvedM- cols = A.elems colA- unitPows = map (concatMap flattenUnits . zipWith UnitPow cols) (H.toLists solvedM)- isUnitName (UnitPow (UnitName _) _) = True; isUnitName _ = False+ (unsolvedM, inconsists, colA) = constraintsToMatrix cons+ solvedM = rref unsolvedM+ cols = A.elems colA + -- Convert the rows of the solved matrix into flattened unit+ -- expressions in the form of "unit ** k".+ unitPows = map (concatMap flattenUnits . zipWith UnitPow cols) (H.toLists solvedM)++ -- Variables to the left, unit names to the right side of the equation.+ unitAssignments = map (fmap (foldUnits . map negatePosAbs) . partition (not . isUnitRHS)) unitPows+ isUnitRHS (UnitPow (UnitName _) _) = True+ isUnitRHS (UnitPow (UnitParamEAPAbs _) _) = True+ -- Because this version of isUnitRHS different from+ -- constraintsToMatrix interpretation, we need to ensure that any+ -- moved ParamPosAbs units are negated, because they are+ -- effectively being shifted across the equal-sign:+ isUnitRHS (UnitPow (UnitParamPosAbs _) _) = True+ isUnitRHS _ = False++ foldUnits units+ | null units = UnitlessVar+ | otherwise = foldl1 UnitMul units+ -------------------------------------------------- simplifyConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2))@@ -146,6 +172,21 @@ augM = if rows rhsM == 0 || cols rhsM == 0 then lhsM else fromBlocks [[lhsM, rhsM]] inconsists = findInconsistentRows lhsM augM +constraintsToMatrices :: Constraints -> (H.Matrix Double, H.Matrix Double, [Int], A.Array Int UnitInfo, A.Array Int UnitInfo)+constraintsToMatrices cons = (lhsM, rhsM, inconsists, lhsCols, rhsCols)+ where+ -- convert each constraint into the form (lhs, rhs)+ consPairs = filter (uncurry (/=)) $ flattenConstraints cons+ -- ensure terms are on the correct side of the equal sign+ shiftedCons = map shiftTerms consPairs+ lhs = map fst shiftedCons+ rhs = map snd shiftedCons+ (lhsM, lhsCols) = flattenedToMatrix lhs+ (rhsM, rhsCols) = flattenedToMatrix rhs+ colElems = A.elems lhsCols ++ A.elems rhsCols+ augM = if rows rhsM == 0 || cols rhsM == 0 then lhsM else fromBlocks [[lhsM, rhsM]]+ inconsists = findInconsistentRows lhsM augM+ -- [[UnitInfo]] is a list of flattened constraints flattenedToMatrix :: [[UnitInfo]] -> (H.Matrix Double, A.Array Int UnitInfo) flattenedToMatrix cons = (m, A.array (0, numCols - 1) (map swap uniqUnits))@@ -169,25 +210,35 @@ negateCons = map (\ (UnitPow u k) -> UnitPow u (-k)) -colSort (UnitLiteral i) (UnitLiteral j) = compare i j-colSort (UnitLiteral _) _ = LT-colSort _ (UnitLiteral _) = GT-colSort x y = compare x y+negatePosAbs (UnitPow (UnitParamPosAbs x) k) = UnitPow (UnitParamPosAbs x) (-k)+negatePosAbs u = u +colSort (UnitLiteral i) (UnitLiteral j) = compare i j+colSort (UnitLiteral _) _ = LT+colSort _ (UnitLiteral _) = GT+colSort (UnitParamPosAbs x) (UnitParamPosAbs y) = compare x y+colSort (UnitParamPosAbs _) _ = GT+colSort _ (UnitParamPosAbs _) = LT+colSort x y = compare x y+ -------------------------------------------------- --- | Translate all constraints into a LHS, RHS side of units.-flattenConstraints :: Constraints -> [([UnitInfo], [UnitInfo])]-flattenConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2))+-- Units that should appear on the right-hand-side of the matrix during solving+isUnitRHS (UnitPow (UnitName _) _) = True+isUnitRHS (UnitPow (UnitParamEAPAbs _) _) = True+isUnitRHS _ = False --- | Shift UnitNames to the RHS, and all else to the LHS.+-- | Shift UnitNames/EAPAbs poly units to the RHS, and all else to the LHS. shiftTerms :: ([UnitInfo], [UnitInfo]) -> ([UnitInfo], [UnitInfo]) shiftTerms (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift) where- (lhsOk, lhsShift) = partition (not . isUnitName) lhs- (rhsOk, rhsShift) = partition isUnitName rhs- isUnitName (UnitPow (UnitName _) _) = True; isUnitName _ = False+ (lhsOk, lhsShift) = partition (not . isUnitRHS) lhs+ (rhsOk, rhsShift) = partition isUnitRHS rhs +-- | Translate all constraints into a LHS, RHS side of units.+flattenConstraints :: Constraints -> [([UnitInfo], [UnitInfo])]+flattenConstraints = map (\ (ConEq u1 u2) -> (flattenUnits u1, flattenUnits u2))+ -------------------------------------------------- -- Matrix solving functions based on HMatrix @@ -235,29 +286,32 @@ m = cols a below = getColumnBelow a (j - k, j) + erm = elemRowMult n (j - k) (recip (a @@> (j - k, j)))+ -- scale the row if the cell is not already equal to 1- erm = elemRowMult n (j - k) (recip (a @@> (j - k, j)))- (a1, mats1) = if a @@> (j - k, j) /= 1 then- (erm <> a, erm:mats)- else (a, mats)+ (a1, mats1) | a @@> (j - k, j) /= 1 = (erm <> a, erm:mats)+ | otherwise = (a, mats) -- Locate any non-zero values in the same column as (j - k, j) and -- cancel them out. Optimisation: instead of constructing a -- separate elemRowAdd matrix for each cancellation that are then -- multiplied together, simply build a single matrix that cancels -- all of them out at the same time, using the ST Monad.- findAdds i m ms = (new <> m, new:ms)+ findAdds i m ms+ | isWritten = (new <> m, new:ms)+ | otherwise = (m, ms) where- new = runSTMatrix $ do- new <- newMatrix 0 n n+ (isWritten, new) = runST $ do+ new <- newMatrix 0 n n :: ST s (STMatrix s Double) sequence [ writeMatrix new i' i' 1 | i' <- [0 .. (n - 1)] ]- let f i | i >= n = return ()- | i == j - k = f (i + 1)- | a @@> (i, j) == 0 = f (i + 1)- | otherwise = writeMatrix new i (j - k) (- (a @@> (i, j)))- >> f (i + 1)- f 0- return new+ let f w i | i >= n = return w+ | i == j - k = f w (i + 1)+ | a @@> (i, j) == 0 = f w (i + 1)+ | otherwise = writeMatrix new i (j - k) (- (a @@> (i, j)))+ >> f True (i + 1)+ isWritten <- f False 0+ (isWritten,) `fmap` freezeMatrix new+ (a2, mats2) = findAdds 0 a1 mats1 -- Get a list of values that occur below (i, j) in the matrix a.@@ -295,7 +349,7 @@ findInconsistentRows :: H.Matrix Double -> H.Matrix Double -> [Int] findInconsistentRows coA augA = [0..(rows augA - 1)] \\ consistent where- consistent = head (filter (tryRows coA augA) (pset ( [0..(rows augA - 1)])) ++ [[]])+ consistent = head (filter (tryRows coA augA) (tails ( [0..(rows augA - 1)])) ++ [[]]) -- Rouché–Capelli theorem is that if the rank of the coefficient -- matrix is not equal to the rank of the augmented matrix then@@ -309,3 +363,8 @@ extractRows = flip (?) -- hmatrix 0.17 changed interface m @@> i = m `atIndex` i++showCons str = unlines . ([replicate 50 '-', str ++ ":"]++) . (++[replicate 50 '^']) . map f+ where+ f (ConEq u1 u2) = show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)+ f (ConConj cons) = intercalate " && " (map f cons)
src/Camfort/Specification/Units/InferenceFrontend.hs view
@@ -22,11 +22,12 @@ {-# LANGUAGE PatternGuards #-} module Camfort.Specification.Units.InferenceFrontend- ( initInference, runCriticalVariables, runInferVariables, runInconsistentConstraints, getConstraint )+ ( initInference, runCriticalVariables, runInferVariables, runCompileUnits, runInconsistentConstraints, getConstraint+ , puName, puSrcName ) where import Data.Data (Data)-import Data.List (nub)+import Data.List (nub, intercalate, partition) import qualified Data.Map.Strict as M import qualified Data.IntMap.Strict as IM import qualified Data.Set as S@@ -40,6 +41,8 @@ import qualified Language.Fortran.AST as F import Language.Fortran.Parser.Utils (readReal, readInteger)+import Language.Fortran.Util.Position (getSpan)+import Language.Fortran.Util.ModFile import qualified Language.Fortran.Analysis as FA import Language.Fortran.Analysis (varName, srcName) @@ -59,6 +62,7 @@ initInference :: UnitSolver () initInference = do pf <- gets usProgramFile+ -- Parse unit annotations found in comments and link to their -- corresponding statements in the AST. let (linkedPF, parserReport) = runWriter $ annotateComments P.unitParser pf@@ -102,11 +106,13 @@ -- These constraints will include parametric polymorphic units that -- have not yet been instantiated into their particular uses. abstractCons <- extractConstraints+ dumpConsM "***abstractCons" abstractCons -- Eliminate all parametric polymorphic units by copying them for -- each specific use cases and substituting a unique call-site -- identifier that distinguishes each use-case from the others. cons <- applyTemplates abstractCons+ dumpConsM "***concreteCons" cons -- Remove any traces of CommentAnnotator, since the annotations can -- cause generic operations traversing the AST to get confused.@@ -117,7 +123,7 @@ debugLogging cleanLinks :: F.ProgramFile UA -> F.ProgramFile UA-cleanLinks = transformBi (\ a -> a { unitBlock = Nothing, unitSpec = Nothing } :: UnitAnnotation A)+cleanLinks = transformBi (\ a -> a { unitPU = Nothing, unitBlock = Nothing, unitSpec = Nothing } :: UnitAnnotation A) -------------------------------------------------- -- Inference functions@@ -142,6 +148,39 @@ cons <- usConstraints `fmap` get return $ inconsistentConstraints cons +-- | Produce information for a "units-mod" file.+runCompileUnits :: UnitSolver CompiledUnits+runCompileUnits = do+ cons <- usConstraints `fmap` get++ -- Sketching some ideas about solving the unit equation for each+ -- parameter of each function.+ let unitAssigns = map (fmap flattenUnits) $ genUnitAssignments cons+ let mulCons x = map (\ (UnitPow u k) -> UnitPow u (x * k))+ let negateCons = mulCons (-1)+ let epsilon = 0.001 -- arbitrary+ let approxEq a b = abs (b - a) < epsilon+ let uninvert ([UnitPow u k], rhs) | not (k `approxEq` 1) = ([UnitPow u 1], mulCons (1 / k) rhs)+ uninvert (lhs, rhs) = (lhs, rhs)+ let shiftTerms name pos (lhs, rhs) = (lhsOk ++ negateCons rhsShift, rhsOk ++ negateCons lhsShift)+ where+ (lhsOk, lhsShift) = partition isLHS lhs+ (rhsOk, rhsShift) = partition (not . isLHS) rhs+ isLHS (UnitParamPosAbs (n, i)) | n == name && i == pos = True+ isLHS (UnitPow u _) = isLHS u+ isLHS _ = False++ let nameParams = M.fromList [ (NPKParam name pos, rhs) | assign <- unitAssigns+ , UnitParamPosAbs (name, pos) <- universeBi assign+ , let (_, rhs) = uninvert $ shiftTerms name pos assign ]+++ let variables = M.fromList [ (NPKVariable var, units) | ([UnitPow (UnitVar var) k], units) <- unitAssigns+ , k `approxEq` 1 ]++ tmap <- gets usTemplateMap+ return $ CompiledUnits { cuTemplateMap = tmap, cuNameParamMap = nameParams `M.union` variables }+ -------------------------------------------------- -- | Seek out any parameters to functions or subroutines that do not@@ -177,65 +216,155 @@ -- variables are inside of a function or subroutine. insertUndeterminedUnits :: UnitSolver () insertUndeterminedUnits = do- pf <- gets usProgramFile- forM_ (universeBi pf) $ \ pu -> case pu of- F.PUFunction {} -> modifyPUBlocksM (transformBiM (toParamVar (puName pu))) pu- F.PUSubroutine {} -> modifyPUBlocksM (transformBiM (toParamVar (puName pu))) pu- _ -> modifyPUBlocksM (transformBiM toUnitVar) pu+ pf <- gets usProgramFile+ dmap <- (M.union (extractDeclMap pf) . combinedDeclMap . M.elems) `fmap` asks uoModFiles+ forM_ (universeBi pf :: [F.ProgramUnit UA]) $ \ pu ->+ modifyPUBlocksM (transformBiM (insertUndeterminedUnitVar dmap)) pu - where- toParamVar :: String -> F.Expression UA -> UnitSolver (F.Expression UA)- toParamVar fname v@(F.ExpValue _ _ (F.ValVariable _)) = do- let vname = varName v- let sname = srcName v- modifyVarUnitMap $ M.insertWith (curry snd) (vname, sname) (UnitParamVarAbs (fname, vname))- return v- toParamVar _ e = return e+-- Specifically handle variables+insertUndeterminedUnitVar :: DeclMap -> F.Expression UA -> UnitSolver (F.Expression UA)+insertUndeterminedUnitVar dmap v@(F.ExpValue _ _ (F.ValVariable _)) = do+ let vname = varName v+ let sname = srcName v+ let unit = toUnitVar dmap (vname, sname)+ modifyVarUnitMap $ M.insertWith (curry snd) (varName v, srcName v) unit+ return v+insertUndeterminedUnitVar _ e = return e - toUnitVar :: F.Expression UA -> UnitSolver (F.Expression UA)- toUnitVar v@(F.ExpValue _ _ (F.ValVariable _)) = do- let vname = varName v- let sname = srcName v- modifyVarUnitMap $ M.insertWith (curry snd) (vname, sname) (UnitVar (vname, sname))- return v- toUnitVar e = return e+-- Choose UnitVar or UnitParamVarAbs depending upon how the variable was declared.+toUnitVar :: DeclMap -> VV -> UnitInfo+toUnitVar dmap (vname, sname) = unit+ where+ unit = case fst `fmap` M.lookup vname dmap of+ Just (DCFunction (F.Named fname)) -> UnitParamVarAbs (fname, (vname, sname))+ Just (DCSubroutine (F.Named fname)) -> UnitParamVarAbs (fname, (vname, sname))+ _ -> UnitVar (vname, sname) -------------------------------------------------- +-- | Convert explicit polymorphic annotations such as (UnitName "'a")+-- into UnitParamEAPAbs with a 'context-unique-name' given by the+-- ProgramUnitName combined with the supplied unit name.+transformExplicitPolymorphism :: Maybe F.ProgramUnitName -> UnitInfo -> UnitInfo+transformExplicitPolymorphism (Just (F.Named f)) (UnitName a@('\'':_)) = UnitParamEAPAbs (a, f ++ "_" ++ a)+transformExplicitPolymorphism _ u = u+ -- | Any units provided by the programmer through comment annotations -- will be incorporated into the VarUnitMap. insertGivenUnits :: UnitSolver () insertGivenUnits = do pf <- gets usProgramFile- mapM_ checkComment [ b | b@(F.BlComment {}) <- universeBi pf ]+ mapM_ checkPU (universeBi pf) where+ -- Look through each Program Unit for the comments+ checkPU :: F.ProgramUnit UA -> UnitSolver ()+ checkPU pu@(F.PUComment a _ _)+ -- Look at unit assignment between function return variable and spec.+ | Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec+ , Just pu <- mPU = insertPUUnitAssigns (toUnitInfo unitsAST) pu vars+ -- Add a new unit alias.+ | Just (P.UnitAlias name unitsAST) <- mSpec = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST))+ | otherwise = return ()+ where+ mSpec = unitSpec (FA.prevAnnotation a)+ mPU = unitPU (FA.prevAnnotation a)+ -- Other type of ProgramUnit (e.g. one with a body of blocks)+ checkPU pu = mapM_ (checkBlockComment (getName pu)) [ b | b@(F.BlComment {}) <- universeBi (F.programUnitBody pu) ]+ where+ getName pu = case pu of+ F.PUFunction {} -> Just $ F.getName pu+ F.PUSubroutine {} -> Just $ F.getName pu+ _ -> Nothing+ -- Look through each comment that has some kind of unit annotation within it.- checkComment :: F.Block UA -> UnitSolver ()- checkComment (F.BlComment a _ _)+ checkBlockComment :: Maybe F.ProgramUnitName -> F.Block UA -> UnitSolver ()+ checkBlockComment pname (F.BlComment a _ _) -- Look at unit assignment between variable and spec. | Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec- , Just b <- mBlock = insertUnitAssignments (toUnitInfo unitsAST) b vars+ , Just b <- mBlock = insertBlockUnitAssigns pname (toUnitInfo unitsAST) b vars -- Add a new unit alias.- | Just (P.UnitAlias name unitsAST) <- mSpec = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST))- | otherwise = return ()+ | Just (P.UnitAlias name unitsAST) <- mSpec = modifyUnitAliasMap (M.insert name (toUnitInfo unitsAST))+ | otherwise = return () where mSpec = unitSpec (FA.prevAnnotation a) mBlock = unitBlock (FA.prevAnnotation a) -- Figure out the unique names of the referenced variables and -- then insert unit info under each of those names.- insertUnitAssignments :: UnitInfo -> F.Block UA -> [String] -> UnitSolver ()- insertUnitAssignments info (F.BlStatement _ _ _ (F.StDeclaration _ _ _ _ decls)) varRealNames = do+ insertBlockUnitAssigns :: Maybe F.ProgramUnitName -> UnitInfo -> F.Block UA -> [String] -> UnitSolver ()+ insertBlockUnitAssigns pname info (F.BlStatement _ _ _ (F.StDeclaration _ _ _ _ decls)) varRealNames = do -- figure out the 'unique name' of the varRealName that was found in the comment -- FIXME: account for module renaming -- FIXME: might be more efficient to allow access to variable renaming environ at this program point- let m = M.fromList [ ((varName e, srcName e), info)+ let info' = transform (transformExplicitPolymorphism pname) info+ let m = M.fromList [ ((varName e, srcName e), info') | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi decls :: [F.Expression UA] , varRealName <- varRealNames- , varRealName == FA.srcName e ]+ , varRealName == srcName e ] modifyVarUnitMap $ M.unionWith const m modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m + -- Insert unit annotation for function return variable+ insertPUUnitAssigns :: UnitInfo -> F.ProgramUnit UA -> [String] -> UnitSolver ()+ insertPUUnitAssigns info pu@(F.PUFunction _ _ _ _ _ _ mret _ _) varRealNames+ | (retUniq, retSrc) <- case mret of Just ret -> (FA.varName ret, FA.srcName ret)+ Nothing -> (puName pu, puSrcName pu)+ , retSrc `elem` varRealNames = do+ let pname = Just $ F.getName pu+ let info' = transform (transformExplicitPolymorphism pname) info+ let m = M.fromList [ ((retUniq, retSrc), info') ]+ modifyVarUnitMap $ M.unionWith const m+ modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m+++-- ensure polymorphic variable annotation is used correctly+checkPolymorphicAnnotation :: UnitSolver [String]+checkPolymorphicAnnotation = do+ pf <- gets usProgramFile+ checks <- mapM checkPU (universeBi pf)+ return . map fst . filter (not . snd) $ checks+ where+ -- Look through each Program Unit for its parameters and annotations+ checkPU :: F.ProgramUnit UA -> UnitSolver (String, Bool)+ checkPU pu = do+ (argPolys, resPolys) <- foldM (checkBlockComment (getNameAndArgs pu)) ([], []) [ b | b@(F.BlComment {}) <- universeBi (F.programUnitBody pu) ]+ return (puName pu, S.fromList resPolys `S.isSubsetOf` S.fromList argPolys)+ where+ getNameAndArgs :: F.ProgramUnit UA -> Maybe (String, [String], Maybe String)+ getNameAndArgs pu = case pu of+ F.PUFunction _ _ _ _ _ args Nothing _ _+ | name <- puName pu -> Just (name, map varName (universeBi args :: [F.Expression UA]), Just name)+ F.PUFunction _ _ _ _ _ args (Just res) _ _+ | name <- puName pu -> Just (name, map varName (universeBi args :: [F.Expression UA]), Just (varName res))+ F.PUSubroutine _ _ _ _ args _ _+ | name <- puName pu -> Just (name, map varName (universeBi args :: [F.Expression UA]), Nothing)+ _ -> Nothing+ checkBlockComment :: Maybe (String, [String], Maybe String) -> ([String], [String]) -> F.Block UA -> UnitSolver ([String], [String])+ checkBlockComment pinfo (argPolys, resPolys) (F.BlComment a _ _)+ -- Look at unit assignment between variable and spec.+ | Just (pname, args, mres) <- pinfo+ , Just (P.UnitAssignment (Just vars) unitsAST) <- mSpec+ , Just b <- mBlock =+ let+ annotVars = S.fromList [ varName e+ | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi b :: [F.Expression UA]+ , varSrcName <- vars+ , varSrcName == srcName e ]+ extractPolys ast = [ v | P.UnitBasic (v@('\'':_)) <- universeBi ast ]+ in case () of+ () | any (`S.member` annotVars) args -> return (extractPolys unitsAST ++ argPolys, resPolys)+ | Just res <- mres,+ res `S.member` annotVars -> return (argPolys, extractPolys unitsAST ++ resPolys)+ | otherwise -> return (argPolys, resPolys)+ | otherwise = return (argPolys, resPolys)+ where+ mSpec = unitSpec (FA.prevAnnotation a)+ mBlock = unitBlock (FA.prevAnnotation a)+++++ -------------------------------------------------- -- | Take the unit information from the VarUnitMap and use it to@@ -245,6 +374,7 @@ varUnitMap <- usVarUnitMap `fmap` get let annotateExp e@(F.ExpValue _ _ (F.ValVariable _)) | Just info <- M.lookup (varName e, srcName e) varUnitMap = setUnitInfo info e+ -- may need to annotate intrinsics separately annotateExp e = e return $ transformBi annotateExp pf @@ -270,8 +400,10 @@ -- Follow the LitMixed rules. expMixed e = case e of F.ExpValue _ _ (F.ValInteger i) | readInteger i == Just 0 -> withLiterals genParamLit e+ | isPolyCtxt -> expUnitless e | otherwise -> withLiterals genUnitLiteral e F.ExpValue _ _ (F.ValReal i) | readReal i == Just 0 -> withLiterals genParamLit e+ | isPolyCtxt -> expUnitless e | otherwise -> withLiterals genUnitLiteral e _ -> return e @@ -285,17 +417,54 @@ | isLiteral e = flip setUnitInfo e `fmap` m | otherwise = return e + isPolyCtxt = case pu of F.PUFunction {} -> True; F.PUSubroutine {} -> True; _ -> False++-- | Is it a literal, literally?+isLiteral :: F.Expression UA -> Bool+isLiteral (F.ExpValue _ _ (F.ValReal _)) = True+isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True+isLiteral _ = False++-- | Is expression a literal and is it zero?+isLiteralZero :: F.Expression UA -> Bool+isLiteralZero (F.ExpValue _ _ (F.ValInteger i)) = readInteger i == Just 0+isLiteralZero (F.ExpValue _ _ (F.ValReal i)) = readReal i == Just 0+isLiteralZero _ = False++-- | Is expression a literal and is it zero?+isLiteralNonZero :: F.Expression UA -> Bool+isLiteralNonZero (F.ExpValue _ _ (F.ValInteger i)) = readInteger i /= Just 0+isLiteralNonZero (F.ExpValue _ _ (F.ValReal i)) = readReal i /= Just 0+isLiteralNonZero _ = False+ -------------------------------------------------- -- | Convert all parametric templates into actual uses, via substitution. applyTemplates :: Constraints -> UnitSolver Constraints -- postcondition: returned constraints lack all Parametric constructors applyTemplates cons = do+ dumpConsM "applyTemplates" cons -- Get a list of the instances of parametric polymorphism from the constraints. let instances = nub [ (name, i) | UnitParamPosUse (name, _, i) <- universeBi cons ]++ -- Also generate a list of 'dummy' instances to ensure that every+ -- 'toplevel' function and subroutine is thoroughly expanded and+ -- analysed, even if it is not used in the current ProgramFile. (It+ -- might be part of a library module, for instance).+ pf <- gets usProgramFile+ dummies <- forM (topLevelFuncsAndSubs pf) $ \ pu -> do+ id <- genCallId+ return (puName pu, id)++ whenDebug $ do+ D.traceM ("instances: " ++ show instances ++ "\n")+ D.traceM ("dummies: " ++ show dummies ++ "\n")+ -- Work through the instances, expanding their templates, and -- substituting the callId into the abstract parameters.- concreteCons <- foldM (substInstance []) [] instances+ concreteCons <- liftM2 (++) (foldM (substInstance False []) [] instances)+ (foldM (substInstance True []) [] dummies)+ dumpConsM "applyTemplates: concreteCons" concreteCons -- Also include aliases in the final set of constraints, where -- aliases are implemented by simply asserting that they are equal@@ -305,14 +474,15 @@ let transAlias (UnitName a) | a `M.member` aliasMap = UnitAlias a transAlias u = u - return . transformBi transAlias . filter (not . isParametric) $ cons ++ concreteCons ++ aliases+ dumpConsM "aliases" aliases+ return . transformBi transAlias $ cons ++ concreteCons ++ aliases -- | Look up the Parametric templates for a given function or -- subroutine, and do the substitutions. Process any additional -- polymorphic calls that are uncovered, unless they are recursive -- calls that have already been seen in the current call stack.-substInstance :: [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints-substInstance callStack output (name, callId) = do+substInstance :: Bool -> [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints+substInstance isDummy callStack output (name, callId) = do tmap <- gets usTemplateMap -- Look up the templates associated with the given function or@@ -322,8 +492,12 @@ -- -- The reason for this is because functions called by functions can -- be used in a parametric polymorphic way.- template <- transformBiM callIdRemap $ [] `fromMaybe` M.lookup name tmap + -- npc <- nameParamConstraints name -- In case it is an imported function, use this.+ let npc = [] -- disabled for now+ template <- transformBiM callIdRemap $ npc `fromMaybe` M.lookup name tmap+ dumpConsM ("substInstance " ++ show isDummy ++ " " ++ show callStack ++ " " ++ show (name, callId) ++ " template lookup") template+ -- Reset the usCallIdRemap field so that it is ready for the next -- set of templates. modify $ \ s -> s { usCallIdRemap = IM.empty }@@ -336,11 +510,46 @@ -- unit-assignments as the first call. return [] else- foldM (substInstance (name:callStack)) [] instances+ foldM (substInstance False (name:callStack)) [] instances - -- Convert any remaining abstract parametric units into concrete ones.- return . instantiate (name, callId) $ output ++ template ++ template'+ dumpConsM ("instantiating " ++ show (name, callId) ++ ": (output ++ template) is") (output ++ template)+ dumpConsM ("instantiating " ++ show (name, callId) ++ ": (template') is") (template') + -- Get constraints for any imported variables+ let filterForVars (NPKVariable _) _ = True; filterForVars _ _ = False+ nmap <- M.filterWithKey filterForVars `fmap` gets usNameParamMap+ let importedVariables = [ ConEq (UnitVar vv) (foldUnits units) | (NPKVariable vv, units) <- M.toList nmap ]++ -- Convert abstract parametric units into concrete ones.++ let output' = -- Do not instantiate explicitly annotated polymorphic+ -- variables from current context when looking at dummy (name, callId)+ (if isDummy then output ++ template+ else instantiate callId (output ++ template)) ++++ -- Only instantiate explicitly annotated polymorphic+ -- variables from nested function/subroutine calls.+ instantiate callId template' ++++ -- any imported variables+ importedVariables++ dumpConsM ("final output for " ++ show (name, callId)) output'++ return output'++foldUnits units+ | null units = UnitlessVar+ | otherwise = foldl1 UnitMul units++-- | Generate constraints from a NameParamMap entry.+nameParamConstraints :: F.Name -> UnitSolver Constraints+nameParamConstraints fname = do+ let filterForName (NPKParam n _) _ = n == fname+ filterForName _ _ = False+ nlst <- (M.toList . M.filterWithKey filterForName) `fmap` gets usNameParamMap+ return [ ConEq (UnitParamPosAbs (fname, pos)) (foldUnits units) | (NPKParam _ pos, units) <- nlst ]+ -- | If given a usage of a parametric unit, rewrite the callId field -- to follow an existing mapping in the usCallIdRemap state field, or -- generate a new callId and add it to the usCallIdRemap state field.@@ -358,25 +567,46 @@ | Just i' <- IM.lookup i idMap -> return (UnitParamLitUse (l, i'), idMap) | otherwise -> genCallId >>= \ i' -> return (UnitParamLitUse (l, i'), IM.insert i i' idMap)- _ -> return (info, idMap)+ UnitParamEAPUse (v, i)+ | Just i' <- IM.lookup i idMap -> return (UnitParamEAPUse (v, i'), idMap)+ | otherwise -> genCallId >>= \ i' ->+ return (UnitParamEAPUse (v, i'), IM.insert i i' idMap) + _ -> return (info, idMap) --- | Convert a parametric template into a particular use-instantiate (name, callId) = transformBi $ \ info -> case info of++-- | Convert a parametric template into a particular use.+instantiate :: Data a => Int -> a -> a+instantiate callId = transformBi $ \ info -> case info of UnitParamPosAbs (name, position) -> UnitParamPosUse (name, position, callId) UnitParamLitAbs litId -> UnitParamLitUse (litId, callId) UnitParamVarAbs (fname, vname) -> UnitParamVarUse (fname, vname, callId)+ UnitParamEAPAbs vname -> UnitParamEAPUse (vname, callId) _ -> info +-- | Return a list of ProgramUnits that might be considered 'toplevel'+-- in the ProgramFile, e.g., possible exports. These must be analysed+-- independently of whether they are actually used in the same file,+-- because other files might use them.+topLevelFuncsAndSubs :: F.ProgramFile a -> [F.ProgramUnit a]+topLevelFuncsAndSubs (F.ProgramFile _ pus) = topLevel =<< pus+ where+ topLevel (F.PUModule _ _ _ _ (Just contains)) = topLevel =<< contains+ topLevel (F.PUMain _ _ _ _ (Just contains)) = topLevel =<< contains+ topLevel f@(F.PUFunction {}) = return f+ topLevel s@(F.PUSubroutine {}) = return s+ topLevel _ = []+ -------------------------------------------------- -- | Gather all constraints from the main blocks of the AST, as well as from the varUnitMap extractConstraints :: UnitSolver Constraints extractConstraints = do pf <- gets usProgramFile+ dmap <- (M.union (extractDeclMap pf) . combinedDeclMap . M.elems) `fmap` asks uoModFiles varUnitMap <- gets usVarUnitMap return $ [ con | b <- mainBlocks pf, con@(ConEq {}) <- universeBi b ] ++- [ ConEq (UnitVar v) u | (v, u) <- M.toList varUnitMap ]+ [ ConEq (toUnitVar dmap v) u | (v, u) <- M.toList varUnitMap ] -- | A list of blocks considered to be part of the 'main' program. mainBlocks :: F.ProgramFile UA -> [F.Block UA]@@ -392,6 +622,16 @@ [ () | UnitParamVarAbs _ <- universeBi info ] ++ [ () | UnitParamLitAbs _ <- universeBi info ] +-- | Does the constraint contain only Parametric elements?+isAllParametric :: Constraint -> Bool+isAllParametric = all f . universeBi+ where+ f i = case i of+ UnitParamPosAbs _ -> True+ UnitParamVarAbs _ -> True+ UnitParamLitAbs _ -> True+ _ -> False+ -------------------------------------------------- -- | Decorate the AST with unit info.@@ -403,9 +643,7 @@ propagateExp :: F.Expression UA -> UnitSolver (F.Expression UA) propagateExp e = fmap uoLiterals ask >>= \ lm -> case e of- F.ExpValue _ _ (F.ValVariable _) -> return e -- all variables should already be annotated- F.ExpValue _ _ (F.ValInteger _) -> return e -- all literal numbers should already be annotated- F.ExpValue _ _ (F.ValReal _) -> return e -- all literal numbers should already be annotated+ F.ExpValue _ _ _ -> return e -- all values should already be annotated F.ExpBinary _ _ F.Multiplication e1 e2 -> setF2 UnitMul (getUnitInfoMul lm e1) (getUnitInfoMul lm e2) F.ExpBinary _ _ F.Division e1 e2 -> setF2 UnitMul (getUnitInfoMul lm e1) (flip UnitPow (-1) `fmap` (getUnitInfoMul lm e2)) F.ExpBinary _ _ F.Exponentiation e1 e2 -> setF2 UnitPow (getUnitInfo e1) (constantExpression e2)@@ -413,7 +651,10 @@ | isOp RelOp o -> setF2C ConEq (getUnitInfo e1) (getUnitInfo e2) F.ExpFunctionCall {} -> propagateFunctionCall e F.ExpSubscript _ _ e1 _ -> return $ maybeSetUnitInfo (getUnitInfo e1) e- _ -> whenDebug (tell ("propagateExp: unhandled: " ++ show e)) >> return e+ F.ExpUnary _ _ _ e1 -> return $ maybeSetUnitInfo (getUnitInfo e1) e+ _ -> do+ whenDebug . tell $ "propagateExp: " ++ show (getSpan e) ++ " unhandled: " ++ show e+ return e where -- Shorter names for convenience functions. setF2 f u1 u2 = return $ maybeSetUnitInfoF2 f u1 u2 e@@ -422,30 +663,42 @@ propagateFunctionCall :: F.Expression UA -> UnitSolver (F.Expression UA) propagateFunctionCall e@(F.ExpFunctionCall a s f Nothing) = do- (info, _) <- callHelper f []- return . setUnitInfo info $ F.ExpFunctionCall a s f Nothing+ (info, _) <- callHelper f []+ let cons = intrinsicHelper info f []+ return . setConstraint (ConConj cons) . setUnitInfo info $ F.ExpFunctionCall a s f Nothing propagateFunctionCall e@(F.ExpFunctionCall a s f (Just (F.AList a' s' args))) = do (info, args') <- callHelper f args- return . setUnitInfo info $ F.ExpFunctionCall a s f (Just (F.AList a' s' args'))+ let cons = intrinsicHelper info f args'+ return . setConstraint (ConConj cons) . setUnitInfo info $ F.ExpFunctionCall a s f (Just (F.AList a' s' args')) propagateStatement :: F.Statement UA -> UnitSolver (F.Statement UA) propagateStatement stmt = case stmt of- F.StExpressionAssign _ _ e1 e2 -> do- return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) stmt+ F.StExpressionAssign _ _ e1 e2 -> literalAssignmentSpecialCase e1 e2 stmt F.StCall a s sub (Just (F.AList a' s' args)) -> do- (_, args') <- callHelper sub args- return $ F.StCall a s sub (Just (F.AList a' s' args'))+ (info, args') <- callHelper sub args+ let cons = intrinsicHelper info sub args'+ return . setConstraint (ConConj cons) $ F.StCall a s sub (Just (F.AList a' s' args')) F.StDeclaration {} -> transformBiM propagateDeclarator stmt _ -> return stmt propagateDeclarator :: F.Declarator UA -> UnitSolver (F.Declarator UA) propagateDeclarator decl = case decl of- F.DeclVariable _ _ e1 _ (Just e2) -> do- return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) decl- F.DeclArray _ _ e1 _ _ (Just e2) -> do- return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) decl+ F.DeclVariable _ _ e1 _ (Just e2) -> literalAssignmentSpecialCase e1 e2 decl+ F.DeclArray _ _ e1 _ _ (Just e2) -> literalAssignmentSpecialCase e1 e2 decl _ -> return decl +-- Allow literal assignment to overload the non-polymorphic+-- unit-assignment of the non-zero literal.+literalAssignmentSpecialCase e1 e2 ast+ | u2@(Just (UnitLiteral _)) <- getUnitInfo e2 = do+ return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) u2 ast+ | isLiteralNonZero e2 = do+ u2 <- genUnitLiteral+ return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (Just u2) ast+ | otherwise = do+ -- otherwise express the constraint between LHS and RHS of assignment.+ return $ maybeSetUnitConstraintF2 ConEq (getUnitInfo e1) (getUnitInfo e2) ast+ propagatePU :: F.ProgramUnit UA -> UnitSolver (F.ProgramUnit UA) propagatePU pu = do let name = puName pu@@ -458,16 +711,25 @@ -- explicit unit and the UnitParamPosAbs corresponding to the -- parameter. This way all other uses of the parameter get linked to -- the explicit unit annotation as well.- givenCons <- fmap catMaybes . forM (indexedParams pu) $ \ (i, param) -> do+ givenCons <- forM (indexedParams pu) $ \ (i, param) -> do case M.lookup param varMap of- Just (UnitParamPosAbs {}) -> return Nothing- Just u -> return . Just . ConEq u $ UnitParamPosAbs (name, i)- _ -> return Nothing+ Just (UnitParamPosAbs {}) -> return . ConEq (UnitParamVarAbs (name, param)) $ UnitParamPosAbs (name, i)+ Just u -> return . ConEq u $ UnitParamPosAbs (name, i)+ _ -> return . ConEq (UnitParamVarAbs (name, param)) $ UnitParamPosAbs (name, i) let cons = givenCons ++ bodyCons- modifyTemplateMap (M.insert name cons)- return (setConstraint (ConConj cons) pu)+ case pu of F.PUFunction {} -> modifyTemplateMap (M.insert name cons)+ F.PUSubroutine {} -> modifyTemplateMap (M.insert name cons)+ _ -> return () + -- Set the unitInfo field of a function program unit to be the same+ -- as the unitInfo of its result.+ let pu' = case (pu, indexedParams pu) of+ (F.PUFunction {}, (0, res):_) -> setUnitInfo (UnitParamPosAbs (name, 0) `fromMaybe` M.lookup res varMap) pu+ _ -> pu++ return (setConstraint (ConConj cons) pu')+ -------------------------------------------------- -- | Check if x contains an abstract parametric reference under the given name.@@ -489,6 +751,16 @@ let info = UnitParamPosUse (name, 0, callId) return (info, args') +-- FIXME: use this function to create a list of constraints on intrinsic call-sites...+intrinsicHelper (UnitParamPosUse (_, _, callId)) f@(F.ExpValue _ _ (F.ValIntrinsic _)) args+ | Just (retU, argUs) <- M.lookup sname intrinsicUnits = zipWith eachArg [0..numArgs] (retU:argUs)+ where+ numArgs = length args+ sname = srcName f+ vname = varName f+ eachArg i u = ConEq (UnitParamPosUse (vname, i, callId)) (instantiate callId u)+intrinsicHelper _ _ _ = []+ -- | Generate a unique identifier for a call-site. genCallId :: UnitSolver Int genCallId = do@@ -543,7 +815,8 @@ -- | Set the Constraint field on a piece of AST. setConstraint :: F.Annotated f => Constraint -> f UA -> f UA-setConstraint c = modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c }))+setConstraint (ConConj []) = id+setConstraint c = modifyAnnotation (onPrev (\ ua -> ua { unitConstraint = Just c })) -------------------------------------------------- @@ -573,11 +846,7 @@ F.PUSubroutine a s r n p b subs -> flip fmap (f b) $ \ b' -> F.PUSubroutine a s r n p b' subs F.PUFunction a s r rec n p res b subs -> flip fmap (f b) $ \ b' -> F.PUFunction a s r rec n p res b' subs F.PUBlockData a s n b -> flip fmap (f b) $ \ b' -> F.PUBlockData a s n b'---- Is it a literal, literally?-isLiteral (F.ExpValue _ _ (F.ValReal _)) = True-isLiteral (F.ExpValue _ _ (F.ValInteger _)) = True-isLiteral _ = False+ F.PUComment {} -> return pu -- no blocks -------------------------------------------------- @@ -652,6 +921,11 @@ -------------------------------------------------- +dumpConsM str = whenDebug . D.traceM . unlines . ([replicate 50 '-', str ++ ":"]++) . (++[replicate 50 '^']) . map f+ where+ f (ConEq u1 u2) = show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)+ f (ConConj cons) = intercalate " && " (map f cons)+ debugLogging :: UnitSolver () debugLogging = whenDebug $ do (tell . unlines . map (\ (ConEq u1 u2) -> " ***AbsConstraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2) ++ "\n")) =<< extractConstraints@@ -667,26 +941,36 @@ forM_ (universeBi pf) $ \ pu -> case pu of F.PUFunction {} | Just (ConConj cons) <- getConstraint pu ->- whenDebug . tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> " constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons+ tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> " constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons F.PUSubroutine {} | Just (ConConj cons) <- getConstraint pu ->- whenDebug . tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> " constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons+ tell . unlines $ (puName pu ++ ":"):map (\ (ConEq u1 u2) -> " constraint: " ++ show (flattenUnits u1) ++ " === " ++ show (flattenUnits u2)) cons _ -> return ()- let (unsolvedM, inconsists, colA) = constraintsToMatrix cons- let solvedM = rref unsolvedM- tell "\n--------------------------------------------------\n"- tell $ show colA+ let (lhsM, rhsM, _, lhsColA, rhsColA) = constraintsToMatrices cons+ tell "\n--------------------------------------------------\nLHS Cols:\n"+ tell $ show lhsColA+ tell "\n--------------------------------------------------\nRHS Cols:\n"+ tell $ show rhsColA+ tell "\n--------------------------------------------------\nLHS M:\n"+ tell $ show lhsM+ tell "\n--------------------------------------------------\nRHS M:\n"+ tell $ show rhsM+ tell "\n--------------------------------------------------\nSolved (RREF) M:\n"+ let augM = if H.rows rhsM == 0 || H.cols rhsM == 0 then lhsM else H.fromBlocks [[lhsM, rhsM]]+ tell . show . rref $ augM+ -- tell "\n--------------------------------------------------\nSolved (SVD) M:\n"+ -- tell $ show (H.linearSolveSVD lhsM rhsM)+ -- tell "\n--------------------------------------------------\nSingular Values:\n"+ -- tell $ show (H.singularValues lhsM) tell "\n--------------------------------------------------\n"- tell $ show unsolvedM+ tell $ "Rank LHS: " ++ show (H.rank lhsM) ++ "\n" tell "\n--------------------------------------------------\n"- tell . show $ (H.takeRows (H.rank solvedM) solvedM)+ let augA = if H.rows rhsM == 0 || H.cols rhsM == 0 then lhsM else H.fromBlocks [[lhsM, rhsM]]+ tell $ "Rank Augmented: " ++ show (H.rank augA) ++ "\n"+ tell "\n--------------------------------------------------\nGenUnitAssignments:\n"+ let unitAssignments = genUnitAssignments cons+ tell . unlines $ map (\ (u1s, u2) -> " ***UnitAssignment: " ++ show u1s ++ " === " ++ show (flattenUnits u2) ++ "\n") unitAssignments tell "\n--------------------------------------------------\n"- tell $ "Rank: " ++ show (H.rank solvedM) ++ "\n"- tell $ "Is inconsistent RREF? " ++ show (isInconsistentRREF solvedM) ++ "\n"- tell $ "Inconsistent rows: " ++ show (inconsistentConstraints cons) ++ "\n"- tell "--------------------------------------------------\n"- tell $ "Critical Variables: " ++ show (criticalVariables cons) ++ "\n"- tell $ "Infer Variables: " ++ show (inferVariables cons) ++ "\n" -------------------------------------------------- @@ -700,3 +984,85 @@ puSrcName pu | F.Named n <- FA.puSrcName pu = n | otherwise = "_nameless"++--------------------------------------------------++-- | name => (return-unit, parameter-units)+intrinsicUnits :: M.Map F.Name (UnitInfo, [UnitInfo])+intrinsicUnits =+ M.fromList+ [ ("abs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("iabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("dabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("cabs", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("aimag", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("aint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("dint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("anint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("dnint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("cmplx", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("conjg", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("dble", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("dim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+ , ("idim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+ , ("ddim", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+ , ("dprod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("ceiling", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("floor", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("int", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("ifix", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("idint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("max", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+ , ("min", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+ , ("min0", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+ , ("amin1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+ , ("dmin1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+ , ("amin0", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+ , ("min1", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")])) -- special case: arbitrary # of parameters+ , ("mod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+ , ("modulo", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+ , ("amod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+ , ("dmod", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+ , ("nint", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("real", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("float", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("sngl", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a")]))+ , ("sign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+ , ("isign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+ , ("dsign", (UnitParamEAPAbs ("'a", "'a"), [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'b", "'b")]))+ , ("present", (UnitParamEAPAbs ("'a", "'a"), [UnitlessVar]))+ , ("sqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2]))+ , ("dsqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2]))+ , ("csqrt", (UnitParamEAPAbs ("'a", "'a"), [UnitPow (UnitParamEAPAbs ("'a", "'a")) 2]))+ , ("exp", (UnitlessVar, [UnitlessVar]))+ , ("dexp", (UnitlessVar, [UnitlessVar]))+ , ("cexp", (UnitlessVar, [UnitlessVar]))+ , ("alog", (UnitlessVar, [UnitlessVar]))+ , ("dlog", (UnitlessVar, [UnitlessVar]))+ , ("clog", (UnitlessVar, [UnitlessVar]))+ , ("alog10", (UnitlessVar, [UnitlessVar]))+ , ("dlog10", (UnitlessVar, [UnitlessVar]))+ , ("sin", (UnitlessVar, [UnitlessVar]))+ , ("dsin", (UnitlessVar, [UnitlessVar]))+ , ("csin", (UnitlessVar, [UnitlessVar]))+ , ("cos", (UnitlessVar, [UnitlessVar]))+ , ("dcos", (UnitlessVar, [UnitlessVar]))+ , ("ccos", (UnitlessVar, [UnitlessVar]))+ , ("tan", (UnitlessVar, [UnitlessVar]))+ , ("dtan", (UnitlessVar, [UnitlessVar]))+ , ("asin", (UnitlessVar, [UnitlessVar]))+ , ("dasin", (UnitlessVar, [UnitlessVar]))+ , ("acos", (UnitlessVar, [UnitlessVar]))+ , ("dacos", (UnitlessVar, [UnitlessVar]))+ , ("atan", (UnitlessVar, [UnitlessVar]))+ , ("datan", (UnitlessVar, [UnitlessVar]))+ , ("atan2", (UnitlessVar, [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+ , ("datan2", (UnitlessVar, [UnitParamEAPAbs ("'a", "'a"), UnitParamEAPAbs ("'a", "'a")]))+ , ("sinh", (UnitlessVar, [UnitlessVar]))+ , ("dsinh", (UnitlessVar, [UnitlessVar]))+ , ("cosh", (UnitlessVar, [UnitlessVar]))+ , ("dcosh", (UnitlessVar, [UnitlessVar]))+ , ("tanh", (UnitlessVar, [UnitlessVar]))+ , ("dtanh", (UnitlessVar, [UnitlessVar])) ]++-- Others: reshape, merge need special handling
src/Camfort/Specification/Units/Monad.hs view
@@ -15,6 +15,7 @@ -} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {- | Defines the monad for the units-of-measure modules -}@@ -22,38 +23,31 @@ ( UA, VV, UnitSolver, UnitOpts(..), unitOpts0, UnitLogs, UnitState(..), LiteralsOpt(..), UnitException , whenDebug, modifyVarUnitMap, modifyGivenVarSet, modifyUnitAliasMap , VarUnitMap, GivenVarSet, UnitAliasMap, TemplateMap, CallIdMap- , modifyTemplateMap, modifyProgramFile, modifyProgramFileM, modifyCallIdRemapM- , runUnitSolver, evalUnitSolver, execUnitSolver )+ , modifyTemplateMap, modifyNameParamMap, modifyProgramFile, modifyProgramFileM, modifyCallIdRemapM+ , runUnitSolver, evalUnitSolver, execUnitSolver+ , CompiledUnits(..), NameParamMap, NameParamKey(..), emptyCompiledUnits ) where import Control.Monad.RWS.Strict import Control.Monad.Trans.Except+import Data.Binary (Binary)+import Data.Typeable (Typeable) import Data.Char (toLower) import Data.Data (Data) import Data.List (find, isPrefixOf)+import GHC.Generics (Generic) import qualified Data.Map.Strict as M import qualified Data.IntMap.Strict as IM import qualified Data.Set as S import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.AST as F+import Language.Fortran.Util.ModFile import Camfort.Specification.Units.Environment (UnitInfo, UnitAnnotation, Constraints(..), VV) import Camfort.Analysis.Annotations (Annotation, A, UA)+import qualified Data.ByteString.Char8 as B --------------------------------------------------- --- | The monad-type UnitSolver a = ExceptT UnitException (RWS UnitOpts UnitLogs UnitState) a-------------------------------------------------------- Not in use, but might be useful someday.-type UnitException = ()-------------------------------------------------------- Read-only options for the unit solver.- -- | Some options about how to handle literals. data LiteralsOpt = LitPoly -- ^ All literals are polymorphic.@@ -71,16 +65,56 @@ ms = [ ("poly", LitPoly), ("unitless", LitUnitless), ("mixed", LitMixed) , ("litpoly", LitPoly), ("litunitless", LitUnitless), ("litmixed", LitMixed) ] +-- | Options for the unit solver data UnitOpts = UnitOpts- { uoDebug :: Bool -- ^ debugging mode?- , uoLiterals :: LiteralsOpt -- ^ how to handle literals- , uoNameMap :: FAR.NameMap -- ^ map of unique names to original names+ { uoDebug :: Bool -- ^ debugging mode?+ , uoLiterals :: LiteralsOpt -- ^ how to handle literals+ , uoNameMap :: FAR.NameMap -- ^ map of unique names to original names+ , uoModFiles :: M.Map String ModFile -- ^ map of included modules }- deriving (Show, Read, Data, Eq, Ord)+ deriving (Show, Data, Eq, Ord) unitOpts0 :: UnitOpts-unitOpts0 = UnitOpts False LitMixed M.empty+unitOpts0 = UnitOpts False LitMixed M.empty M.empty +-- | Function/subroutine name -> associated, parametric polymorphic constraints+type TemplateMap = M.Map F.Name Constraints++-- | Things that can be exported from modules+data NameParamKey+ = NPKParam F.Name Int -- ^ Function/subroutine name, position of parameter+ | NPKVariable VV -- ^ variable+ deriving (Ord, Eq, Show, Data, Typeable, Generic)++instance Binary NameParamKey++-- | mapped to a list of units (to be multiplied together)+type NameParamMap = M.Map NameParamKey [UnitInfo]++-- | The data-structure stored in 'fortran-src mod files'+data CompiledUnits = CompiledUnits { cuTemplateMap :: TemplateMap+ , cuNameParamMap :: NameParamMap }+ deriving (Ord, Eq, Show, Data, Typeable, Generic)++instance Binary CompiledUnits++emptyCompiledUnits :: CompiledUnits+emptyCompiledUnits = CompiledUnits M.empty M.empty++--------------------------------------------------++-- | The monad+type UnitSolver a = ExceptT UnitException (RWS UnitOpts UnitLogs UnitState) a++--------------------------------------------------++-- Not in use, but might be useful someday.+type UnitException = ()++--------------------------------------------------++-- Read-only options for the unit solver.+ -- | Only run the argument if debugging mode enabled. whenDebug :: UnitSolver () -> UnitSolver () whenDebug m = fmap uoDebug ask >>= \ d -> when d m@@ -98,8 +132,6 @@ type GivenVarSet = S.Set F.Name -- | Alias name => definition type UnitAliasMap = M.Map String UnitInfo--- | Function/subroutine name -> associated, parametric polymorphic constraints-type TemplateMap = M.Map F.Name Constraints -- | Map of CallId to CallId type CallIdMap = IM.IntMap Int @@ -110,6 +142,7 @@ , usGivenVarSet :: GivenVarSet , usUnitAliasMap :: UnitAliasMap , usTemplateMap :: TemplateMap+ , usNameParamMap :: NameParamMap , usLitNums :: Int , usCallIds :: Int , usCallIdRemap :: CallIdMap@@ -121,6 +154,7 @@ , usGivenVarSet = S.empty , usUnitAliasMap = M.empty , usTemplateMap = M.empty+ , usNameParamMap = M.empty , usLitNums = 0 , usCallIds = 0 , usCallIdRemap = IM.empty@@ -138,6 +172,9 @@ modifyTemplateMap :: (TemplateMap -> TemplateMap) -> UnitSolver () modifyTemplateMap f = modify (\ s -> s { usTemplateMap = f (usTemplateMap s) })++modifyNameParamMap :: (NameParamMap -> NameParamMap) -> UnitSolver ()+modifyNameParamMap f = modify (\ s -> s { usNameParamMap = f (usNameParamMap s) }) modifyProgramFile :: (F.ProgramFile UA -> F.ProgramFile UA) -> UnitSolver () modifyProgramFile f = modify (\ s -> s { usProgramFile = f (usProgramFile s) })
src/Camfort/Specification/Units/Parser.y view
@@ -19,18 +19,19 @@ %tokentype { Token } %token- unit { TId "unit" }- id { TId $$ }- one { TNum "1" }- num { TNum $$ }- ',' { TComma }- '-' { TMinus }- '**' { TExponentiation }- '/' { TDivision }- '::' { TDoubleColon }- '=' { TEqual }- '(' { TLeftPar }- ')' { TRightPar }+ unit { TId "unit" }+ record { TRecord }+ id { TId $$ }+ one { TNum "1" }+ num { TNum $$ }+ ',' { TComma }+ '-' { TMinus }+ '**' { TExponentiation }+ '/' { TDivision }+ '::' { TDoubleColon }+ '=' { TEqual }+ '(' { TLeftPar }+ ')' { TRightPar } %left '/' %left '**'@@ -53,7 +54,15 @@ | one { Unitless } | '(' one ')' { Unitless } | '(' ')' { Unitless }+| record '(' RECORD_DECLS ')' { UnitRecord $3 } +RECORD_DECLS :: { [(String, UnitOfMeasure)] }+: RECORD_DECL ',' RECORD_DECLS { $1 : $3 }+| RECORD_DECL { [$1] }++RECORD_DECL :: { (String, UnitOfMeasure) }+: UEXP '::' id { ($3, $1) }+ UEXP_LEVEL1 :: { UnitOfMeasure } : UEXP_LEVEL1 UEXP_LEVEL2 { UnitProduct $1 $2 } | UEXP '/' UEXP_LEVEL2 { UnitQuotient $1 $3 }@@ -95,6 +104,7 @@ | UnitProduct UnitOfMeasure UnitOfMeasure | UnitQuotient UnitOfMeasure UnitOfMeasure | UnitExponentiation UnitOfMeasure UnitPower+ | UnitRecord [(String, UnitOfMeasure)] deriving Data instance Show UnitOfMeasure where@@ -103,6 +113,7 @@ show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2 show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2 show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")"+ show (UnitRecord recs) = "record (" ++ intercalate ", " (map (\ (n, u) -> n ++ " :: " ++ show u) recs) ++ ")" data UnitPower = UnitPowerInteger Integer@@ -123,6 +134,7 @@ | TEqual | TLeftPar | TRightPar+ | TRecord | TId String | TNum String deriving (Show)@@ -158,9 +170,10 @@ 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"+ | isLetter x || x == '\'' = aux (\ c -> isAlphaNum c || c `elem` ['\'','_','-'])+ (\ s -> if s == "record" then TRecord else TId s)+ | isNumber x = aux isNumber TNum+ | otherwise = failWith $ "Not valid unit syntax at " ++ show (x:xs) ++ "\n" where aux p cons = let (target, rest) = span p xs
src/Camfort/Specification/Units/Synthesis.hs view
@@ -14,7 +14,7 @@ limitations under the License. -} -{-# LANGUAGE PatternGuards, ScopedTypeVariables, ImplicitParams, DoAndIfThenElse, ConstraintKinds #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables, ImplicitParams, DoAndIfThenElse, ConstraintKinds, TupleSections #-} module Camfort.Specification.Units.Synthesis (runSynthesis)@@ -37,18 +37,21 @@ import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Util.Position as FU+import Language.Fortran.ParserMonad (FortranVersion(Fortran90)) import qualified Camfort.Specification.Units.Parser as P import Camfort.Analysis.CommentAnnotator import Camfort.Analysis.Annotations hiding (Unitless) import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad+import Camfort.Specification.Units.InferenceFrontend (puName, puSrcName) import qualified Debug.Trace as D -- | Insert unit declarations into the ProgramFile as comments. runSynthesis :: Char -> [(VV, UnitInfo)] -> UnitSolver [(VV, UnitInfo)] runSynthesis marker vars = do- modifyProgramFileM $ descendBiM (synthBlocks marker vars) -- descendBiM finds the head of lists+ -- descendBiM finds the head of lists+ modifyProgramFileM $ descendBiM (synthProgramUnits marker vars) <=< descendBiM (synthBlocks marker vars) return vars -- Should be invoked on the beginning of a list of blocks@@ -75,9 +78,9 @@ -- Create a zero-length span for the new comment node. let newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) -- Build the text of the comment with the unit annotation.- let txt = marker:" " ++ showUnitDecl (e, u)+ let txt = marker:" " ++ showUnitDecl (FA.srcName e, u) let space = FU.posColumn lp - 1- let newB = F.BlComment newA newSS . insertSpacing space $ commentText pf txt+ let newB = F.BlComment newA newSS . F.Comment . insertSpacing pf space $ commentText pf txt return $ Just newB where vname = FA.varName e@@ -86,14 +89,53 @@ return (b:reverse newBs ++ bs) synthBlock _ _ bs b = return (b:bs) +-- Should be invoked on the beginning of a list of program units+synthProgramUnits :: Char -> [(VV, UnitInfo)] -> [F.ProgramUnit UA] -> UnitSolver [F.ProgramUnit UA]+synthProgramUnits marker vars pus = do+ fmap reverse . foldM (synthProgramUnit marker vars) [] $ pus++-- Process an individual program unit while building up a list of+-- program units (in reverse order) to ultimately replace the original+-- list of program units. We're looking for functions, in particular,+-- in order to possibly insert a unit annotation before them.+synthProgramUnit :: Char -> [(VV, UnitInfo)] -> [F.ProgramUnit UA] -> F.ProgramUnit UA -> UnitSolver [F.ProgramUnit UA]+synthProgramUnit marker vars pus pu@(F.PUFunction a ss@(FU.SrcSpan lp up) _ _ _ _ mret _ _) = do+ pf <- usProgramFile `fmap` get+ gvSet <- usGivenVarSet `fmap` get+ let (vname, sname) = case mret of Just e -> (FA.varName e, FA.srcName e)+ Nothing -> (puName pu, puSrcName pu)+ case lookup (vname, sname) vars of+ -- if return var has a unit & not a member of the already-given variables+ Just u | vname `S.notMember` gvSet -> do+ let newA = a { FA.prevAnnotation = (FA.prevAnnotation a) {+ prevAnnotation = (prevAnnotation (FA.prevAnnotation a)) {+ refactored = Just lp } } }+ -- Create a zero-length span for the new comment node.+ let newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0})+ -- Build the text of the comment with the unit annotation.+ let txt = marker:" " ++ showUnitDecl (sname, u)+ let space = FU.posColumn lp - 1+ let newPU = F.PUComment newA newSS . F.Comment . insertSpacing pf space $ commentText pf txt++ -- recursively descend to find program units inside of current one+ fmap (:newPU:pus) $ descendBiM (synthProgramUnits marker vars) pu++ -- otherwise, nevermind, but still recursively descend to find+ -- program units inside of current one+ _ -> fmap (:pus) $ descendBiM (synthProgramUnits marker vars) pu+synthProgramUnit marker vars pus pu = fmap (:pus) $ descendBiM (synthProgramUnits marker vars) pu+ -- Insert the correct comment markers around the given text string, depending on Fortran version.--- FIXME: use Fortran meta information when I have finished adding it to ProgramFile. commentText :: F.ProgramFile UA -> String -> String-commentText _ text = "!" ++ text+commentText pf text | isModernFortran pf = "!" ++ text+ | otherwise = "c" ++ text -- Insert a given amount of spacing before the string.-insertSpacing :: Int -> String -> String-insertSpacing n = (replicate n ' ' ++)+insertSpacing :: F.ProgramFile UA -> Int -> String -> String+insertSpacing pf n | isModernFortran pf = (replicate n ' ' ++)+ | otherwise = id -- Pretty print a unit declaration.-showUnitDecl (e, u) = "unit(" ++ show u ++ ") :: " ++ FA.srcName e+showUnitDecl (sname, u) = "unit(" ++ show u ++ ") :: " ++ sname++isModernFortran (F.ProgramFile (F.MetaInfo { F.miVersion = v }) _ ) = v >= Fortran90
src/Camfort/Transformation/CommonBlockElim.hs view
@@ -68,7 +68,7 @@ (r ++ r', pfs'', pfM) where (pfs', (r, cg)) = runState (analyseAndRmCommons pfs) ("", [])- meta = F.MetaInfo PM.Fortran90+ meta = F.MetaInfo PM.Fortran90 "" (r', pfM) = introduceModules meta d cg pfs'' = updateUseDecls pfs' cg @@ -229,7 +229,7 @@ [(Filename, F.ProgramFile A)] -> [TLCommon A] -> [(Filename, F.ProgramFile A)] updateUseDecls fps tcs = map perPF fps where- perPF (f, p@(F.ProgramFile (F.MetaInfo v) _ _)) =+ perPF (f, p@(F.ProgramFile (F.MetaInfo v _) _)) = (f, transformBi (importIncludeCommons v) $ transformBi (matchPUnit v f) p) tcrs = mkTLCommonRenamers tcs @@ -335,6 +335,7 @@ getUnitStartPosition (F.PUFunction _ _ _ _ _ _ _ bs _) = FU.getSpan (head bs) getUnitStartPosition (F.PUBlockData _ s _ []) = s getUnitStartPosition (F.PUBlockData _ _ _ bs) = FU.getSpan (head bs)+getUnitStartPosition (F.PUComment _ s _) = s renamerToUse :: RenamerCoercer -> [(F.Name, F.Name)] renamerToUse Nothing = []@@ -419,7 +420,7 @@ mkModuleFile :: F.MetaInfo -> Directory -> TLCommon A -> (Report, (Filename, F.ProgramFile A)) mkModuleFile meta dir (_, (_, (name, varTys))) =- (r, (path, F.ProgramFile meta [([], mod)] []))+ (r, (path, F.pfSetFilename path $ F.ProgramFile meta [mod])) where modname = commonName name path = dir ++ modname ++ ".f90"
+ src/Camfort/Transformation/DataTypeIntroduction.hs view
@@ -0,0 +1,104 @@+{-+ Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}++module Camfort.Transformation.DataTypeIntroduction where++import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Analysis as FA+import qualified Language.Fortran.Analysis.DataFlow as FAD+import qualified Language.Fortran.Analysis.Renaming as FAR+import qualified Language.Fortran.Analysis.BBlocks as FAB+import qualified Language.Fortran.Analysis.Types as FAT+import qualified Language.Fortran.Util.Position as FU+import qualified Language.Fortran.ParserMonad as PM+import qualified Language.Fortran.PrettyPrint as PP++import qualified Data.Graph.Inductive.PatriciaTree as G+import qualified Data.Graph.Inductive.Graph as IGr+import qualified Data.Map.Lazy as M+import Data.Generics.Uniplate.Operations++import qualified Data.Set as S+import Control.Monad.State.Lazy++import Camfort.Helpers+import Camfort.Helpers.Syntax+import Camfort.Analysis.Annotations++import qualified Data.IntMap as IM++-- Array-subscript interference graphs, in a map from+-- the array variable to the interference graph+type IGraphs = M.Map F.Name (G.Gr F.Name Int)++-- Top-level+dataTypeIntro ::+ [(Filename, F.ProgramFile A)] -> (Report, [(Filename, F.ProgramFile A)])+dataTypeIntro pfs = (r, [])+ where+ r = buildInterferenceGraph pfs++-- Stub, coalesce LVA information+-- TODO, build interference graph+buildInterferenceGraph :: [(Filename, F.ProgramFile A)] -> String+buildInterferenceGraph = show . (foldr IM.union IM.empty) . map analysePerPF++-- Stub, generate LVA information+analysePerPF ::+ (Filename, F.ProgramFile A) -> FAD.InOutMap (S.Set F.Name)+analysePerPF (fname, pf) = undefined+ where+ -- (report, pf'') = transformBiM (perStmt lva) pf+ -- initialise analysis+ pf' = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ pf+ -- get map of program unit ==> basic block graph+ bbm = FAB.genBBlockMap pf'+ -- build the supergraph of global dependency+ sgr = FAB.genSuperBBGr bbm+ -- extract the supergraph itself+ gr = FAB.superBBGrGraph sgr+ -- live variables+ lva = FAD.liveVariableAnalysis gr++-- Core of the transformation happens here on assignment statements+--perStmt :: FAD.InOutMap -> S.Set F.Name+-- -> F.Statement (FA.Analysis A) -> State IGraphs (F.Statement (FA.Analysis A))+perStmt lva x =+ case (FA.insLabel (F.getAnnotation x)) of+ Just label -> case (IM.lookup label lva) of+ Just (lva_in, _) -> undefined -- transformBiM (perStmt lva_in) x++{-+perExpr :: FAD.InOutMap (S.Set F.Name)+ -> F.Expression (FA.Analysis A) -> State IGraphs (F.Expression (FA.Analysis A))+perExpr lva_in x@(F.ExpSubscript _ _ (F.ExpValue _ _ (F.ValVariable arrVar)) subs) = do+ let subscript_vars = [v | (F.ValVariable v) <- universeBi (F.aStrip subs) ]+ let intefering = [(v, w) | v <- subscript_vars,+ w <- subscript_vars, v `S.member` lva_in && w `S.member` lva_in]+ igraphs <- get+ case (M.lookup arrVar igraphs) of+ Just igraph -> return x+ -- TODO: update graph here+ Nothing -> do+ let g0 = IGr.mkGraph undefined -- [(0, u),(1, v)] [(0, 1, ())]+ let m = M.fromList [(arrVar, g0)]+ put (m `M.union` igraphs)+ return x+perExpr _ x = return x+-}
src/Main.hs view
@@ -17,20 +17,13 @@ module Main where -import Data.Generics.Uniplate.Operations import System.Console.GetOpt-import System.Directory import System.Environment-import System.IO -import Camfort.Analysis.Annotations hiding (Unitless) import Camfort.Helpers-import Camfort.Output-import Camfort.Input import Camfort.Functionality import Data.Text (pack, unpack, split)-import Data.Maybe {-| The entry point to CamFort. Displays user information, and handlers which functionality is being requested -}@@ -42,17 +35,29 @@ let (func : (inp : _)) = args in case lookup func functionality of Just (fun, _) -> do+ (opts, _) <- compilerOpts args+ (numReqArgs, outp) <-- if func `elem` outputNotRequired- then if length args >= 3 && (head (args !! 2) == '-')- then return (2, "")- else -- case where an unnecessary output is specified- return (3, "")- else if length args >= 3- then return (3, args !! 2)- else error $ usage ++ "This mode requires an output "- ++ "file/directory to be specified."- (opts, _) <- compilerOpts (drop numReqArgs args)+ if RefactorInPlace `elem` opts+ -- Does not check to see if an output directory+ -- is also specified since flags come last and therefore+ -- override any specification of an output directory+ -- (which would come earlier).+ then return (2, inp)+ else+ if func `elem` outputNotRequired+ then if length args >= 3 && (head (args !! 2) == '-')+ then return (2, "")+ else -- case where an unnecessary output is specified+ return (3, "")+ else if length args >= 3+ then return (3, args !! 2)+ else fail $ usage ++ "\nThis mode requires an output\+ \ file/directory to be specified\n\+ \ or use the --inplace flag to set\+ \ the ouput location to be the input\+ \ location."+ let excluded_files = map unpack . split (==',') . pack . getExcludes fun inp (excluded_files opts) outp opts Nothing -> putStrLn fullUsageInfo@@ -71,6 +76,8 @@ options = [ Option ['v','?'] ["version"] (NoArg Version) "show version number"+ , Option [] ["inplace"] (NoArg RefactorInPlace)+ "refactor in place (replaces input files)" , Option ['e'] ["exclude"] (ReqArg Excludes "FILES") "files to exclude (comma separated list, no spaces)" , Option ['l'] ["units-literals"] (ReqArg (Literals . read) "ID")@@ -78,6 +85,9 @@ , Option ['m'] ["stencil-inference-mode"] (ReqArg (StencilInferMode . read . (++ "Mode")) "ID") "stencil specification inference mode. ID = Do, Assign, or Both"+ , Option ['I'] ["include-dir"]+ (ReqArg IncludeDir "DIR")+ "directory to search for precompiled files" , Option [] ["debug"] (NoArg Debug) "enable debug mode" , Option [] ["doxygen"] (NoArg Doxygen)@@ -107,7 +117,8 @@ refactorings = [("common", (common, "common block elimination")), ("equivalence", (equivalences, "equivalence elimination")),- ("dead", (dead, "dead-code elimination"))]+ ("dead", (dead, "dead-code elimination")),+ ("datatype", (datatypes, "derived data type introduction"))] {-| List of analses provided by CamFort -} analyses :: [(String@@ -125,7 +136,8 @@ \units-of-measure for maximum coverage")), ("units-check", (unitsCheck, "unit-of-measure checking")), ("units-infer", (unitsInfer, "unit-of-measure inference")),- ("units-synth", (unitsSynth, "unit-of-measure synthesise specs.")) ]+ ("units-synth", (unitsSynth, "unit-of-measure synthesise specs.")),+ ("units-compile", (unitsCompile, "units-of-measure compile module information.")) ] -- * Usage and about information version = "0.902"
tests/Camfort/Analysis/CommentAnnotatorSpec.hs view
@@ -54,7 +54,7 @@ -- Some helper functions varGen x = ExpValue ea p (ValVariable x) intGen i = ExpValue ea p (ValInteger (show i))-wrapBlocks bs = ProgramFile (MetaInfo { miVersion = Fortran90 }) [ ([], pu) ] []+wrapBlocks bs = ProgramFile (MetaInfo { miVersion = Fortran90, miFilename = "<unknown>" }) [ pu ] where pu = PUModule ea p "my_module" bs Nothing @@ -67,56 +67,56 @@ pf2 = wrapBlocks bs2 bs2 =- [ BlComment ea p "something"+ [ BlComment ea p (Comment "something") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf2e = wrapBlocks bs2e bs2e =- [ BlComment (A (Just (bs2e !! 1)) (Just "hello")) p "something"+ [ BlComment (A (Just (bs2e !! 1)) (Just "hello")) p (Comment "something") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf3 = wrapBlocks bs3 bs3 =- [ BlComment ea p "mistral"- , BlComment ea p "orhan"- , BlComment ea p "jean-pierre"- , BlComment ea p "contrastin"+ [ BlComment ea p (Comment "mistral")+ , BlComment ea p (Comment "orhan")+ , BlComment ea p (Comment "jean-pierre")+ , BlComment ea p (Comment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf3e = wrapBlocks bs3e bs3e =- [ BlComment (A (Just (last bs3e)) (Just "!!!mistral")) p "mistral"- , BlComment (A (Just (last bs3e)) (Just "!!!orhan")) p "orhan"- , BlComment (A (Just (last bs3e)) (Just "!!!jean-pierre")) p "jean-pierre"- , BlComment (A (Just (last bs3e)) (Just "!!!contrastin")) p "contrastin"+ [ BlComment (A (Just (last bs3e)) (Just "!!!mistral")) p (Comment "mistral")+ , BlComment (A (Just (last bs3e)) (Just "!!!orhan")) p (Comment "orhan")+ , BlComment (A (Just (last bs3e)) (Just "!!!jean-pierre")) p (Comment "jean-pierre")+ , BlComment (A (Just (last bs3e)) (Just "!!!contrastin")) p (Comment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf4 = wrapBlocks bs4 bs4 =- [ BlComment ea p "mistral"- , BlComment ea p "contrastin"+ [ BlComment ea p (Comment "mistral")+ , BlComment ea p (Comment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing)- , BlComment ea p "dominic"- , BlComment ea p "orchard"+ , BlComment ea p (Comment "dominic")+ , BlComment ea p (Comment "orchard") , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ] pf4e = wrapBlocks bs4e bs4e =- [ BlComment (A (Just (bs4e !! 2)) (Just "!!!mistral")) p "mistral"- , BlComment (A (Just (bs4e !! 2)) (Just "!!!contrastin")) p "contrastin"+ [ BlComment (A (Just (bs4e !! 2)) (Just "!!!mistral")) p (Comment "mistral")+ , BlComment (A (Just (bs4e !! 2)) (Just "!!!contrastin")) p (Comment "contrastin") , BlStatement ea p Nothing (StPause ea p Nothing)- , BlComment (A (Just (last bs4e)) (Just "!!!dominic")) p "dominic"- , BlComment (A (Just (last bs4e)) (Just "!!!orchard")) p "orchard"+ , BlComment (A (Just (last bs4e)) (Just "!!!dominic")) p (Comment "dominic")+ , BlComment (A (Just (last bs4e)) (Just "!!!orchard")) p (Comment "orchard") , BlStatement ea p Nothing (StExpressionAssign ea p (varGen "x") (intGen 42)) ] pf5 = wrapBlocks bs5 bs5 =- [ BlComment ea p "comment 1"- , BlComment ea p "comment 2"+ [ BlComment ea p (Comment "comment 1")+ , BlComment ea p (Comment "comment 2") , BlStatement ea p Nothing (StPause ea p Nothing) ] pf5e = wrapBlocks bs5e bs5e =- [ BlComment (A (Just (last bs5e)) Nothing) p "comment 1"- , BlComment (A (Just (last bs5e)) Nothing) p "comment 2"+ [ BlComment (A (Just (last bs5e)) Nothing) p (Comment "comment 1")+ , BlComment (A (Just (last bs5e)) Nothing) p (Comment "comment 2") , BlStatement ea p Nothing (StPause ea p Nothing) ]
− tests/Camfort/Helpers/VecSpec.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}-module Camfort.Helpers.VecSpec where--import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck (Arbitrary(..), Gen(..))--import Camfort.Helpers.Vec--instance Arbitrary a => Arbitrary (Vec Z a) where- arbitrary = return Nil-instance (Arbitrary (Vec n a), Arbitrary a) => Arbitrary (Vec (S n) a) where- arbitrary = do x <- arbitrary :: Gen a- xs <- arbitrary :: Gen (Vec n a)- return $ Cons x xs--spec :: Spec-spec = - describe "Vector" $- it "TODO" - pending
tests/Camfort/Specification/Stencils/CheckSpec.hs view
@@ -6,6 +6,7 @@ import Camfort.Specification.Stencils.CheckBackend import Camfort.Specification.Stencils.CheckFrontend import qualified Camfort.Specification.Stencils.Grammar as SYN+import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.Syntax import Test.Hspec@@ -27,38 +28,38 @@ parseAndConvert "= stencil forward(depth=1, dim=1) :: x" `shouldBe` (Right $ Right [(["x"], Specification $- Multiple $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))])+ Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) it "parse and convert simple exact stencil (2)" $ parseAndConvert "= stencil forward(depth=1, dim=1) :: x, y, z" `shouldBe` (Right $ Right [(["x","y","z"], Specification $- Multiple $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))])+ Mult $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) - it "parse and convert simple exact stencil with irreflexive (2a)" $- parseAndConvert "= stencil centered(depth=1, dim=2, irreflexive) :: x, y, z"+ it "parse and convert simple exact stencil with nonpointed (2a)" $+ parseAndConvert "= stencil centered(depth=1, dim=2, nonpointed) :: x, y, z" `shouldBe` (Right $ Right [(["x","y","z"], Specification $- Multiple $ Exact (Spatial (Sum [Product [Centered 1 2 False]])))])+ Mult $ Exact (Spatial (Sum [Product [Centered 1 2 False]])))]) it "parse and convert simple upper bounded stencil (3)" $ parseAndConvert "= stencil atmost, forward(depth=1, dim=1) :: x" `shouldBe` (Right $ Right [(["x"], Specification $- Multiple $ Bound Nothing (Just $ Spatial+ Mult $ Bound Nothing (Just $ Spatial (Sum [Product [Forward 1 1 True]])))]) it "parse and convert simple lower bounded stencil (4)" $ parseAndConvert "= stencil atleast, backward(depth=2, dim=1) :: x" `shouldBe` (Right $ Right [(["x"], Specification $- Multiple $ Bound (Just $ Spatial+ Mult $ Bound (Just $ Spatial (Sum [Product [Backward 2 1 True]])) Nothing)]) it "parse and convert stencil requiring distribution (5)" $ parseAndConvert "= stencil atleast, readonce, (forward(depth=1, dim=1) * ((centered(depth=1, dim=2)) + backward(depth=3, dim=4))) :: frob" `shouldBe` (Right $ Right [(["frob"], Specification $- Single $ Bound (Just $ Spatial+ Once $ Bound (Just $ Spatial (Sum [Product [Forward 1 1 True, Centered 1 2 True], Product [Forward 1 1 True, Backward 3 4 True]])) Nothing)])
+ tests/Camfort/Specification/Stencils/ConsistencySpec.hs view
@@ -0,0 +1,37 @@+module Camfort.Specification.Stencils.ConsistencySpec (spec) where++import qualified Camfort.Helpers.Vec as V++import Camfort.Specification.Stencils.Model+import Camfort.Specification.Stencils.Consistency+import Camfort.Specification.Stencils.Syntax++import qualified Data.Set as S+import Algebra.Lattice++import Test.Hspec++spec :: Spec+spec =+ describe "Consistency spec" $ do+ let fivePointSpec = Specification . Once . Exact . Spatial $+ Sum [ Product [ Centered 1 1 True, Centered 0 2 True ]+ , Product [ Centered 1 2 True, Centered 0 1 True ] ]+ let offFivePoint =+ return (V.Cons (Offsets . S.fromList $ [-1])+ (V.Cons (Offsets . S.fromList $ [0]) V.Nil))+ \/+ return (V.Cons (Offsets . S.fromList $ [0])+ (V.Cons (Offsets . S.fromList $ [0]) V.Nil))+ \/+ return (V.Cons (Offsets . S.fromList $ [1])+ (V.Cons (Offsets . S.fromList $ [0]) V.Nil))+ \/+ return (V.Cons (Offsets . S.fromList $ [0])+ (V.Cons (Offsets . S.fromList $ [-1]) V.Nil))+ \/+ return (V.Cons (Offsets . S.fromList $ [0])+ (V.Cons (Offsets . S.fromList $ [1]) V.Nil))+ let fivePointIndices = Once offFivePoint+ it "finds read once five point stencil consistent with its indices" $+ fivePointSpec `consistent` fivePointIndices `shouldBe` Consistent
+ tests/Camfort/Specification/Stencils/DenotationalSemanticsSpec.hs view
@@ -0,0 +1,41 @@+module Camfort.Specification.Stencils.DenotationalSemanticsSpec (spec) where++import qualified Camfort.Helpers.Vec as V++import Camfort.Specification.Stencils.Model+import Camfort.Specification.Stencils.Consistency+import Camfort.Specification.Stencils.Syntax+import Camfort.Specification.Stencils.DenotationalSemantics++import qualified Data.Set as S+import Algebra.Lattice++import Test.Hspec++spec :: Spec+spec =+ describe "Denotational semantics spec" $ do+ let fivePointSpatial = Spatial $+ Sum [ Product [ Centered 1 1 True, Centered 0 2 True ]+ , Product [ Centered 1 2 True, Centered 0 1 True ] ]+ it "transforms five point spatial correctly to union normal form" $ do+ let regFivePoint = Right $+ return (V.Cons (IntervHoled (-1) 1 True)+ (V.Cons (IntervHoled 0 0 True) V.Nil))+ \/+ return (V.Cons (IntervHoled 0 0 True)+ (V.Cons (IntervHoled (-1) 1 True) V.Nil))+ shouldBe (regionsToIntervals (V.Succ (V.Succ V.Zero)) fivePointSpatial)+ regFivePoint++ it "handles interval to region example" $ do+ let reg =+ return (V.Cons (IntervHoled 0 0 True)+ (V.Cons (IntervHoled 0 1 False) V.Nil))+ \/+ return (V.Cons (IntervHoled 0 2 False)+ (V.Cons (IntervHoled 0 2 False) V.Nil))+ let spec = Right $ Spatial $+ Sum [ Product [ Centered 0 1 True, Forward 1 2 False ]+ , Product [ Forward 2 1 False, Forward 2 2 False ] ]+ intervalsToRegions reg `shouldBe` spec
tests/Camfort/Specification/Stencils/GrammarSpec.hs view
@@ -15,10 +15,10 @@ Right (SpecDec (Spatial [] (Or (Var "r1") (Var "r2"))) ["a"]) {- Should no longer be possible- it "just reflexive stencil" $- parse "= stencil reflexive(dims=1,2) :: a"+ it "just pointed stencil" $+ parse "= stencil pointed(dims=1,2) :: a" `shouldBe`- Right (SpecDec (Spatial [Reflexive [1, 2]] Nothing) ["a"])+ Right (SpecDec (Spatial [Pointed [1, 2]] Nothing) ["a"]) -} @@ -29,16 +29,16 @@ {- Should no longer be possible it "basic monfieid stencil (2)" $- parse "= stencil atleast, reflexive(dims=1,2), \+ parse "= stencil atleast, pointed(dims=1,2), \ \ forward(depth=1, dim=1) :: x" `shouldBe`- Right (SpecDec (Spatial [AtLeast,Reflexive [1,2]] (Just $ Forward 1 1)) ["x"])+ Right (SpecDec (Spatial [AtLeast,Pointed [1,2]] (Just $ Forward 1 1)) ["x"]) - it "basic stencil with reflexive and irreflexive" $- parse "= stencil atleast, reflexive(dims=2), \- \ irreflexive(dims=1), forward(depth=1, dim=1) :: frob"+ it "basic stencil with pointed and nonpointed" $+ parse "= stencil atleast, pointed(dims=2), \+ \ nonpointed(dims=1), forward(depth=1, dim=1) :: frob" `shouldBe`- Right (SpecDec (Spatial [AtLeast, Irreflexive [1], Reflexive [2]]+ Right (SpecDec (Spatial [AtLeast, Nonpointed [1], Pointed [2]] (Just $ Forward 1 1)) ["frob"]) -} @@ -53,33 +53,33 @@ Right (RegionDec "r" (Or (Forward 1 1 True) (Backward 2 2 True))) it "region defn irreflx syntactic permutation" $- parse "= region :: r = forward(irreflexive,dim=1,depth=1) + backward(depth=2,irreflexive,dim=2)"+ parse "= region :: r = forward(nonpointed,dim=1,depth=1) + backward(depth=2,nonpointed,dim=2)" `shouldBe` Right (RegionDec "r" (Or (Forward 1 1 False) (Backward 2 2 False))) {- Should no longer be possible it "complex stencil" $- parse "= stencil atleast, reflexive(dims=1,2), readonce, \+ parse "= stencil atleast, pointed(dims=1,2), readonce, \ \ (forward(depth=1, dim=1) + r) * backward(depth=3, dim=4) \ \ :: frob" `shouldBe`- Right (SpecDec (Spatial [AtLeast,ReadOnce,Reflexive [1,2]]+ Right (SpecDec (Spatial [AtLeast,ReadOnce,Pointed [1,2]] (Just $ And (Or (Forward 1 1) (Var "r")) (Backward 3 4))) ["frob"]) it "invalid stencil (atLeast/atMost)" $- parse "= stencil atleast, atmost, reflexive(dims=1,2), \+ parse "= stencil atleast, atmost, pointed(dims=1,2), \ \ forward(depth=1, dim=1) :: x" `shouldBe` (Left $ ProbablyAnnotation $ "Conflicting modifiers: cannot use 'atLeast' and 'atMost' together") - it "invalid stencil (reflexive/irreflexive on same dim)" $- parse "= stencil atleast, irreflexive(dims=2), reflexive(dims=1,2), \+ it "invalid stencil (pointed/nonpointed on same dim)" $+ parse "= stencil atleast, nonpointed(dims=2), pointed(dims=1,2), \ \ forward(depth=1, dim=1) :: x" `shouldBe` (Left $ ProbablyAnnotation $ "Conflicting modifiers: stencil marked as both\- \ irreflexive and reflexive in dimensions = 2")+ \ nonpointed and pointed in dimensions = 2") -}
+ tests/Camfort/Specification/Stencils/InferenceBackendSpec.hs view
@@ -0,0 +1,32 @@+module Camfort.Specification.Stencils.InferenceBackendSpec (spec) where++import Camfort.Specification.Stencils.InferenceBackend+import Camfort.Specification.Stencils.Syntax+import Camfort.Specification.Stencils.Model+import qualified Camfort.Helpers.Vec as V++import Test.Hspec++spec :: Spec+spec =+ describe "Inference backend" $ do+ describe "spans to approximate regions" $ do++ it "handles spans of a(i-2) + a(i) + a(i+2)" $ do+ let spans = [ (V.Cons (-2) V.Nil, V.Cons (-2) V.Nil)+ , (V.Cons 0 V.Nil, V.Cons 0 V.Nil)+ , (V.Cons 2 V.Nil, V.Cons 2 V.Nil) ]+ let region = Right $ Bound+ (Just . Spatial $ Sum [ Product [ Centered 0 1 True ]])+ (Just . Spatial $ Sum [ Product [ Centered 2 1 True ]])+ spansToApproxSpatial spans `shouldBe` region++ it "handles spans of a(i,0) + a(0,j)" $ do+ let spans = [ ( V.Cons 0 (V.Cons absoluteRep V.Nil)+ , V.Cons 0 (V.Cons absoluteRep V.Nil) )+ , ( V.Cons absoluteRep (V.Cons 0 V.Nil)+ , V.Cons absoluteRep (V.Cons 0 V.Nil) ) ]+ let region = Right . Exact . Spatial $+ Sum [ Product [ Centered 0 1 True ]+ , Product [ Centered 0 2 True ] ]+ spansToApproxSpatial spans `shouldBe` region
tests/Camfort/Specification/Stencils/ModelSpec.hs view
@@ -1,217 +1,151 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE DataKinds #-} module Camfort.Specification.Stencils.ModelSpec (spec) where -import Camfort.Helpers.Vec-import Camfort.Specification.Stencils-import Camfort.Specification.Stencils.Synthesis-import Camfort.Specification.Stencils.Model-import Camfort.Specification.Stencils.Syntax hiding (Spec)-import qualified Camfort.Specification.Stencils.Syntax as Syn--import Camfort.Analysis.Annotations-import qualified Language.Fortran.AST as F-import Language.Fortran.Util.Position+import Algebra.Lattice+import qualified Data.Set as S+import Data.List.NonEmpty+import qualified Camfort.Helpers.Vec as V -import Data.Bits-import Data.List-import Data.Set (toList)+import Camfort.Specification.Stencils.Model import Test.Hspec-import Test.QuickCheck-import Test.Hspec.QuickCheck spec :: Spec-spec = do- describe "Consistency of model vs access patterns" $ do- let singleOneDimSpec = Single $ Exact $ Spatial $ Sum- [ Product [ Forward 1 1 True ] ]- it "1D readOnce - positive" $ do- let acs = Single [[0], [1]]- consistent acs singleOneDimSpec `shouldBe` True-- it "1D readOnce - negative" $ do- let acs = Multiple [[0], [1]]- consistent acs singleOneDimSpec `shouldBe` False-- let reflCentOneDimSpec = Single $ Exact $ Spatial $ Sum- [ Product [ Centered 1 1 False ] ]- it "1D centered irreflexive - positive" $ do- let acs = Single [[-1], [1]]- consistent acs reflCentOneDimSpec `shouldBe` True-- let centeredAcs = Single [[-1], [0], [1]]- it "1D centered irreflexive - negative" $- consistent centeredAcs reflCentOneDimSpec `shouldBe` False-- it "1D centered irreflexive lower bound - positive" $ do- let spec = Single $ Bound- (Just $ Spatial $ Sum [ Product [ Centered 1 1 False ] ])- Nothing- consistent centeredAcs spec `shouldBe` True-- it "1D 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- (Just $ Spatial $ Sum [ Product [ Centered 1 1 False ] ])- consistent centeredAcs spec `shouldBe` False-- it "1D double bounded" $ do- let acs = Single [ [-3], [-2], [-1], [0], [1], [3] ]- let spec = Single $ Bound- (Just $ Spatial $ Sum [ Product [ Centered 1 1 True ] ])- (Just $ Spatial $ Sum [ Product [ Centered 1 3 True ] ])- consistent acs spec `shouldBe` True-- it "1D spec 3D access" $ do- let acs = Single [ [0,1,-2], [absoluteRep, 2,3] ]- let spec = Single $ Exact $- Spatial $ Sum [ Product [ Forward 2 2 False ] ]- consistent acs spec `shouldBe` True-- let twoDimSpec = Single $ Exact $- Spatial $ Sum [ Product [ Centered 0 1 True, Forward 1 2 True ] ]-- it "2 dimensional spec example" $ do- let acs = Single [ [0,0], [0,1] ]- consistent acs twoDimSpec `shouldBe` True-- it "Constant access not allowed in otherwise fine access pattern" $ do- let acs = Single [ [0,0], [0,1], [absoluteRep, absoluteRep] ]- consistent acs twoDimSpec `shouldBe` False-- describe "Stencils - Model" $ do- describe "Test soundness of model 1" modelHasLeftInverse- describe "Test soundness of model 2" $ modelHasApproxLeftInverse variations2- describe "Test soundness of model 3" $ modelHasApproxLeftInverse variations3-- describe "Consistency of model with paper" $ do- describe "Quickcheck" $ it "" $ property propPairwisePerm-- describe "Manual for absolute rep" $ do- it "Check absolute rep (0)" $- sort (pp [1,2,absoluteRep] [5,1,7])- `shouldBe` sort (pairwisePerm [1,2,absoluteRep] [5,1,7])-- it "Check absolute rep (1)" $- sort (pp [1,absoluteRep] [5,1])- `shouldBe` sort (pairwisePerm [1,absoluteRep] [5,1])-- it "Check absolute rep (2)" $- sort (pp [absoluteRep,2,absoluteRep] [absoluteRep,1,7])- `shouldBe` sort (pairwisePerm [absoluteRep,2,absoluteRep] [absoluteRep,1,7])---propPairwisePerm :: [Int] -> [Int] -> Bool-propPairwisePerm x y =- if length x == length y && length x < 16- then (sort . nub $ pp x y) == (sort . nub $ pairwisePerm x y)- else True--pp :: [Int] -> [Int] -> [[Int]]-pp x y =- let n = length x- in map (\i ->- map (\j -> ((x !! j) `times` not (testBit i j))- `plus`- ((y !! j) `times` testBit i j)- ) [0..(n-1)]- ) [0 :: Int .. ((2^n)-1)]- where times x True = x- times x False = 0- plus x y = x + y---variations :: [([[Int]], Syn.Multiplicity (Syn.Approximation Spatial))]-variations =- [ ([ [1], [0] ],- Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True]]))-- , ([ [absoluteRep,1], [absoluteRep,0] ],- Multiple $ Exact $ Spatial (Sum [Product [Forward 1 2 True]]))-- , ([ [1,1], [0,1], [1,0], [0,0] ],- Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 True]]))+spec =+ describe "Model spec" $ do+ let regFivePoint =+ return (V.Cons (IntervHoled (-1) 1 True)+ (V.Cons (IntervHoled 0 0 True) V.Nil))+ \/+ return (V.Cons (IntervHoled 0 0 True)+ (V.Cons (IntervHoled (-1) 1 True) V.Nil)) - , ([ [-1, 1], [0, 1] ],- Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Forward 1 2 False]]))+ describe "unfCompare" $ do+ let reg1 =+ return (V.Cons (IntervHoled 0 2 False) (V.Cons (IntervHoled 0 2 False) V.Nil))+ \/+ return (V.Cons (IntervHoled 0 1 True) (V.Cons (IntervHoled 0 2 False) V.Nil))+ let reg2 = return $ V.Cons (IntervHoled 0 2 True) (V.Cons (IntervHoled 0 2 False) V.Nil)+ it "compares equal regions" $+ unfCompare reg1 reg2 `shouldBe` EQ - , ([ [-1], [0] ],- Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True]]))+ let reg3 =+ reg2 \/ return (V.Cons (IntervHoled 0 3 False) (V.Cons (IntervHoled 0 0 True) V.Nil))+ it "compares greater regions" $+ unfCompare reg3 reg2 `shouldBe` GT - , ([ [absoluteRep,-1], [absoluteRep,0] ],- Multiple $ Exact $ Spatial (Sum [Product [Backward 1 2 True]]))+ let reg4 = reg1 \/ return (V.Cons IntervInfinite $ V.Cons IntervInfinite V.Nil)+ it "compares smaller regions" $+ unfCompare reg3 reg4 `shouldBe` LT - , ([ [-1,-1], [0,-1], [-1,0], [0,0] ],- Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 2 True]]))+ let prod1 = return $ V.Cons (Offsets . S.fromList $ [2,3,5])+ (V.Cons (Offsets . S.fromList $ [10, 15]) V.Nil)+ let prod2 = return $ V.Cons (Offsets . S.fromList $ [2,3,4,5])+ (V.Cons (Offsets . S.fromList $ [10, 12, 15]) V.Nil)+ it "compare equal offset products" $+ unfCompare prod1 prod2 `shouldBe` LT - , ( [ [0,-1], [1,-1], [0,0], [1,0], [1,1], [0,1], [2,-1], [2,0], [2,1] ],- Multiple $ Exact $ Spatial- (Sum [Product [ Forward 2 1 True, Centered 1 2 True ] ] ))+ let prod3 = prod1 \/+ return (V.Cons (Offsets . S.fromList $ [ 4 ])+ (V.Cons (Offsets . S.fromList $ [ 10, 12, 15 ]) V.Nil))+ \/+ return (V.Cons (Offsets . S.fromList $ [ 2, 3, 4, 5 ])+ (V.Cons (Offsets . S.fromList $ [ 12 ]) V.Nil))+ it "compare equal offset products" $+ unfCompare prod3 prod2 `shouldBe` EQ - , ( [ [-1,0], [-1,1], [0,0], [0,1], [1,1], [1,0], [-1,2], [0,2], [1,2] ],- Multiple $ Exact $ Spatial- (Sum [Product [ Forward 2 2 True, Centered 1 1 True ] ] ))- ]+ let regBack = return $+ V.Cons (IntervHoled (-1) 0 True) (V.Cons IntervInfinite V.Nil)+ let off = return $+ V.Cons (Offsets . S.fromList $ [-1, 0]) (V.Cons SetOfIntegers V.Nil)+ it "compare equal offset and interval" $+ unfCompare regBack off `shouldBe` EQ -variations2 :: [( Syn.Multiplicity (Syn.Approximation [[Int]])- , Int- , Syn.Multiplicity (Syn.Approximation Spatial) )]-variations2 =- [- -- Stencil which has some absolute component (not represented in the spec)- ( Multiple $ Exact [ [0, absoluteRep], [1, absoluteRep] ]- , 2- , Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True]])- )+ let offFivePoint =+ return (V.Cons (Offsets . S.fromList $ [-1])+ (V.Cons (Offsets . S.fromList $ [0]) V.Nil))+ \/+ return (V.Cons (Offsets . S.fromList $ [0])+ (V.Cons (Offsets . S.fromList $ [0]) V.Nil))+ \/+ return (V.Cons (Offsets . S.fromList $ [1])+ (V.Cons (Offsets . S.fromList $ [0]) V.Nil))+ \/+ return (V.Cons (Offsets . S.fromList $ [0])+ (V.Cons (Offsets . S.fromList $ [-1]) V.Nil))+ \/+ return (V.Cons (Offsets . S.fromList $ [0])+ (V.Cons (Offsets . S.fromList $ [1]) V.Nil))+ it "compare equal offset and interval" $+ unfCompare regFivePoint offFivePoint `shouldBe` EQ - -- Spec on bounds- , ( Multiple $ Bound Nothing (Just [ [0, absoluteRep], [1, absoluteRep]- , [2, absoluteRep] ])- , 2- , Multiple $ Bound Nothing- (Just $ Spatial (Sum [Product [Forward 2 1 True]]))- )- ]+ describe "optimisation" $ do+ it "eliminates subsumed products" $ do+ let regFivePointPlus =+ return (V.Cons (IntervHoled 0 1 True)+ (V.Cons (IntervHoled 0 0 True) V.Nil))+ \/+ regFivePoint+ \/+ return (V.Cons (IntervHoled 0 1 False)+ (V.Cons (IntervHoled 0 0 True) V.Nil))+ \/+ return (V.Cons (IntervHoled 0 0 True)+ (V.Cons (IntervHoled (-1) 0 True) V.Nil))+ optimise regFivePointPlus `shouldBe` regFivePoint -variations3 :: [( Syn.Multiplicity (Syn.Approximation [[Int]])- , Int- , Syn.Multiplicity (Syn.Approximation Spatial) )]-variations3 =- [- -- Spec on bounds- ( Multiple $- Bound Nothing (Just [ [0, absoluteRep, 0], [1, absoluteRep, 0]- , [2, absoluteRep, 0], [0, absoluteRep, 1]- , [1, absoluteRep, 1], [2, absoluteRep, 1]])- , 3- , Multiple $- Bound Nothing (Just $ Spatial (Sum [Product [ Forward 1 3 True- , Forward 2 1 True ]]))- )- ]+ it "applies union lemma" $ do+ let reg =+ return (V.Cons (IntervHoled (-1) 1 False)+ (V.Cons (IntervHoled (-2) 0 False)+ (V.Cons (IntervHoled (-2) 2 True) V.Nil)))+ \/+ return (V.Cons (IntervHoled 0 0 True)+ (V.Cons (IntervHoled (-2) 0 False)+ (V.Cons (IntervHoled (-2) 2 True) V.Nil)))+ \/+ return (V.Cons (IntervHoled (-1) 1 True)+ (V.Cons (IntervHoled 0 2 False)+ (V.Cons (IntervHoled (-2) 2 True) V.Nil)))+ let reg' =+ return (V.Cons (IntervHoled (-1) 1 True)+ (V.Cons (IntervHoled (-2) 2 False)+ (V.Cons (IntervHoled (-2) 2 True) V.Nil)))+ optimise reg `shouldBe` reg' -modelHasLeftInverse = mapM_ check (zip variations [0..])- where- check ((ixs, spec), n) =- it ("("++show n++")") $- sort mdl `shouldBe` sort ixs- where- mdl = toList . fromExact . fromMult . model' $ spec- model' = flip model $ length . head $ ixs+ it "another contains approximation" $ do+ let reg =+ return (V.Cons (IntervHoled 0 2 False)+ (V.Cons (IntervHoled 0 2 False) V.Nil))+ \/+ return (V.Cons (IntervHoled 0 2 False)+ (V.Cons (IntervHoled 0 2 False) V.Nil))+ \/+ return (V.Cons (IntervHoled 0 0 True)+ (V.Cons (IntervHoled 0 1 False) V.Nil))+ let reg' =+ return (V.Cons (IntervHoled 0 2 False)+ (V.Cons (IntervHoled 0 2 False) V.Nil))+ \/+ return (V.Cons (IntervHoled 0 0 True)+ (V.Cons (IntervHoled 0 1 False) V.Nil))+ optimise reg `shouldBe` reg' -modelHasApproxLeftInverse vars = mapM_ check (zip vars [(0 :: Int)..])- where- check ((ixs, dims, spec), n) =- it ("("++show n++")") $ mdl `shouldBe` fmap sort <$> ixs- where- mdl =- let ?globalDimensionality = dims- in fmap (sort . toList) <$> mkModel spec+ it "another subsumption example" $ do+ let reg =+ return (V.Cons (IntervHoled 0 2 True)+ (V.Cons (IntervHoled (-1) 1 True) V.Nil))+ \/+ return (V.Cons (IntervHoled (-1) 0 True)+ (V.Cons (IntervHoled 0 1 True) V.Nil))+ \/+ return (V.Cons (IntervHoled 0 2 True)+ (V.Cons (IntervHoled 0 1 True) V.Nil))+ let reg' =+ return (V.Cons (IntervHoled 0 2 True)+ (V.Cons (IntervHoled (-1) 1 True) V.Nil))+ \/+ return (V.Cons (IntervHoled (-1) 0 True)+ (V.Cons (IntervHoled 0 1 True) V.Nil))+ optimise reg `shouldBe` reg'
tests/Camfort/Specification/StencilsSpec.hs view
@@ -4,13 +4,15 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeOperators #-} module Camfort.Specification.StencilsSpec (spec) where +import GHC.TypeLits+ import Control.Monad.Writer.Strict hiding (Sum, Product) import Data.List -import Camfort.Functionality import Camfort.Helpers.Vec import Camfort.Input import Camfort.Specification.Stencils@@ -19,14 +21,11 @@ import Camfort.Specification.Stencils.InferenceBackend import Camfort.Specification.Stencils.InferenceFrontend import Camfort.Specification.Stencils.Syntax hiding (Spec)-import Camfort.Analysis.Annotations import qualified Language.Fortran.AST as F-import Language.Fortran.Util.Position import 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@@ -36,32 +35,10 @@ import Test.Hspec import Test.QuickCheck-import Test.Hspec.QuickCheck spec :: Spec spec = describe "Stencils" $ do- describe "Idempotence of spanBounding" $ do- it "(0)" $ property $ prop_spanBoundingIdem zeroN- it "(1)" $ property $ prop_spanBoundingIdem oneN- it "(2)" $ property $ prop_spanBoundingIdem twoN- it "(3)" $ property $ prop_spanBoundingIdem threeN- it "(4)" $ property $ prop_spanBoundingIdem fourN-- describe "Associativity of spanBounding" $ do- it "(0)" $ property $ prop_spanBoundingAssoc zeroN- it "(1)" $ property $ prop_spanBoundingAssoc oneN- it "(2)" $ property $ prop_spanBoundingAssoc twoN- it "(3)" $ property $ prop_spanBoundingAssoc threeN- it "(4)" $ property $ prop_spanBoundingAssoc fourN-- describe "Un-permutable permutations on vectors" $ do- it "(0)" $ property $ prop_perms_invertable zeroN- it "(1)" $ property $ prop_perms_invertable oneN- it "(2)" $ property $ prop_perms_invertable twoN- it "(3)" $ property $ prop_perms_invertable threeN- it "(4)" $ property $ prop_perms_invertable fourN- describe "Some checks on containing spans" $ do it "(0)" $ containedWithin (Cons 1 (Cons 1 Nil), Cons 2 (Cons 2 Nil)) (Cons 0 (Cons 0 Nil), Cons 3 (Cons 3 Nil))@@ -98,32 +75,32 @@ ] :: [Vec (S (S (S Z))) Int]) it "composeRegions (1,0)-(1,0) span and (2,0)-(2,0) span" $- shouldBe (composeConsecutiveSpans+ shouldBe (coalesce (Cons 1 (Cons 0 Nil), Cons 1 (Cons 0 Nil)) (Cons 2 (Cons 0 Nil), Cons 2 (Cons 0 Nil)))- [(Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil))]+ $ Just (Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil)) it "composeRegions failing on (1,0)-(2,0) span and (4,0)-(5,0) span" $- shouldBe (composeConsecutiveSpans+ shouldBe (coalesce (Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil)) (Cons 4 (Cons 0 Nil), Cons 5 (Cons 0 Nil)))- []+ Nothing it "composeRegions failing on (1,0)-(2,0) span and (3,1)-(3,1) span" $- shouldBe (composeConsecutiveSpans+ shouldBe (coalesce (Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil)) (Cons 3 (Cons 1 Nil), Cons 3 (Cons 1 Nil)))- []+ Nothing it "five point stencil 2D" $ -- Sort the expected value for the sake of easy equality- shouldBe (inferMinimalVectorRegions fivepoint)+ shouldBe (sort $ inferMinimalVectorRegions fivepoint) (sort [ (Cons (-1) (Cons 0 Nil), Cons 1 (Cons 0 Nil)) , (Cons 0 (Cons (-1) Nil), Cons 0 (Cons 1 Nil)) ]) it "seven point stencil 3D" $ shouldBe- (inferMinimalVectorRegions sevenpoint)+ (sort $ inferMinimalVectorRegions sevenpoint) (sort [ (Cons (-1) (Cons 0 (Cons 0 Nil)), Cons 1 (Cons 0 (Cons 0 Nil))) , (Cons 0 (Cons (-1) (Cons 0 Nil)), Cons 0 (Cons 1 (Cons 0 Nil)))@@ -133,32 +110,32 @@ it "five point stencil 2D" $ inferFromIndices (VL fivepoint) `shouldBe`- (Specification $ Single $ Exact $ Spatial- (Sum [ Product [ Centered 0 1 True, Centered 1 2 True]- , Product [ Centered 0 2 True, Centered 1 1 True]+ (Specification $ Once $ Exact $ Spatial+ (Sum [ Product [ Centered 1 1 True, Centered 0 2 True]+ , Product [ Centered 0 1 True, Centered 1 2 True] ])) it "seven point stencil 2D" $ inferFromIndices (VL sevenpoint) `shouldBe`- (Specification $ Single $ Exact $ Spatial- (Sum [ Product [ Centered 0 1 True, Centered 0 2 True, Centered 1 3 True]- , Product [ Centered 0 1 True, Centered 0 3 True, Centered 1 2 True]- , Product [ Centered 0 2 True, Centered 0 3 True, Centered 1 1 True]+ (Specification $ Once $ Exact $ Spatial+ (Sum [ Product [ Centered 1 1 True, Centered 0 2 True, Centered 0 3 True]+ , Product [ Centered 0 1 True, Centered 1 2 True, Centered 0 3 True]+ , Product [ Centered 0 1 True, Centered 0 2 True, Centered 1 3 True] ])) it "five point stencil 2D with blip" $ inferFromIndices (VL fivepointErr) `shouldBe`- (Specification $ Single $ Exact $ Spatial- (Sum [ Product [ Forward 1 1 True, Forward 1 2 True],+ (Specification $ Once $ Exact $ Spatial+ (Sum [ Product [ Centered 1 1 True, Centered 0 2 True], Product [ Centered 0 1 True, Centered 1 2 True],- Product [ Centered 0 2 True, Centered 1 1 True] ]))+ Product [ Forward 1 1 True, Forward 1 2 True] ])) it "centered forward" $ inferFromIndices (VL centeredFwd) `shouldBe`- (Specification $ Single $ Exact $ Spatial+ (Specification $ Once $ Exact $ Spatial (Sum [ Product [ Forward 1 1 True , Centered 1 2 True] ])) @@ -182,29 +159,29 @@ [Neighbour "i" 0, Neighbour "j" 0] [[offsetToIx "i" 1, offsetToIx "j" 1], [offsetToIx "i" 0, offsetToIx "j" 0]]- `shouldBe` (Just $ Specification $ Single $ Exact+ `shouldBe` (Just $ Specification $ Once $ Exact (Spatial (Sum [Product [Forward 1 1 False, Forward 1 2 False], Product [Centered 0 1 True, Centered 0 2 True]]))) it "consistent (2) a(i,c,j) = b(i,j+1) + b(i,j) \- \:: forward(depth=1,dim=2)*reflexive(dim=1)" $+ \:: forward(depth=1,dim=2)*pointed(dim=1)" $ indicesToSpec' ["i", "j"] [Neighbour "i" 0, Constant (F.ValInteger "0"), Neighbour "j" 0] [[offsetToIx "i" 0, offsetToIx "j" 1], [offsetToIx "i" 0, offsetToIx "j" 0]]- `shouldBe` (Just $ Specification $ Single $ Exact+ `shouldBe` (Just $ Specification $ Once $ Exact (Spatial- (Sum [Product [Forward 1 2 True, Centered 0 1 True]])))+ (Sum [Product [Centered 0 1 True, Forward 1 2 True]]))) it "consistent (3) a(i+1,c,j) = b(j,i+1) + b(j,i) \- \:: backward(depth=1,dim=2)*reflexive(dim=1)" $+ \:: backward(depth=1,dim=2)*pointed(dim=1)" $ indicesToSpec' ["i", "j"] [Neighbour "i" 1, Constant (F.ValInteger "0"), Neighbour "j" 0] [[offsetToIx "j" 0, offsetToIx "i" 1], [offsetToIx "j" 0, offsetToIx "i" 0]]- `shouldBe` (Just $ Specification $ Single $ Exact+ `shouldBe` (Just $ Specification $ Once $ Exact (Spatial- (Sum [Product [Backward 1 2 True, Centered 0 1 True]])))+ (Sum [Product [Centered 0 1 True, Backward 1 2 True]]))) it "consistent (4) a(i+1,j) = b(0,i+1) + b(0,i) \ \:: backward(depth=1,dim=2)" $@@ -212,28 +189,26 @@ [Neighbour "i" 1, Neighbour "j" 0] [[offsetToIx "j" absoluteRep, offsetToIx "i" 1], [offsetToIx "j" absoluteRep, offsetToIx "i" 0]]- `shouldBe` (Just $ Specification $ Single $ Exact+ `shouldBe` (Just $ Specification $ Once $ Exact (Spatial (Sum [Product [Backward 1 2 True]]))) it "consistent (5) a(i) = b(i,i+1) \- \:: reflexive(dim=1)*forward(depth=1,dim=2,irreflexive)" $+ \:: pointed(dim=1)*forward(depth=1,dim=2,nonpointed)" $ indicesToSpec' ["i", "j"] [Neighbour "i" 0] [[offsetToIx "i" 0, offsetToIx "i" 1]]- `shouldBe` (Just $ Specification $ Single $ Exact+ `shouldBe` (Just $ Specification $ Once $ Exact (Spatial- (Sum [Product [Forward 1 2 False,- Centered 0 1 True]])))+ (Sum [Product [Centered 0 1 True,+ Forward 1 2 False]]))) it "consistent (6) a(i) = b(i) + b(0) \- \:: reflexive(dim=1)" $+ \:: pointed(dim=1)" $ indicesToSpec' ["i", "j"] [Neighbour "i" 0] [[offsetToIx "i" 0], [offsetToIx "i" absoluteRep]]- `shouldBe` (Just $ Specification $ Single $ Exact- (Spatial- (Sum [Product [Centered 0 1 True]])))+ `shouldBe` Nothing it "inconsistent (1) RHS" $ indicesToSpec' ["i", "j"]@@ -272,18 +247,18 @@ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` "\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) 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\- \(42:8)-(42:37) stencil readOnce, (reflexive(dim=1))*(reflexive(dim=2)) :: a"+ \(26:8)-(26:29) stencil readOnce, (pointed(dim=1))*(pointed(dim=2)) :: a\n\+ \(24:8)-(24:53) stencil readOnce, (pointed(dim=1))*(centered(depth=1, dim=2)) \+ \+ (centered(depth=1, dim=1))*(pointed(dim=2)) :: a\n\+ \(41:8)-(41:94) stencil readOnce, (centered(depth=1, dim=2)) \+ \+ (centered(depth=1, dim=1)) :: a" it "stencil check" $ fst (callAndSummarise (\f p -> (check f p, p)) program) `shouldBe` "\ntests/fixtures/Specification/Stencils/example2.f\n\- \(23:1)-(23:86) Correct.\n(31:1)-(31:56) Correct."+ \(23:1)-(23:82) Correct.\n(31:1)-(31:56) Correct." it "stencil synth" $ (B.unpack . runIdentity@@ -311,33 +286,7 @@ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` "\ntests/fixtures/Specification/Stencils/example4.f\n\- \(6:8)-(6:33) stencil (reflexive(dim=1)) :: x"---{- Properties of `spanBoundingBox`: idempotent and associative -}-prop_spanBoundingIdem :: Natural n -> Span (Vec n Int) -> Bool-prop_spanBoundingIdem w x = spanBoundingBox x x == normaliseSpan x--prop_spanBoundingAssoc :: Natural n -> Span (Vec n Int)- -> Span (Vec n Int)- -> Span (Vec n Int) -> Bool-prop_spanBoundingAssoc w x y z =- (==) (spanBoundingBox x (spanBoundingBox y z))- (spanBoundingBox (spanBoundingBox x y) z)--{- Permutations that come with 'unpermute' functions are invertable -}-prop_perms_invertable :: (Permutable n) => Natural n -> Vec n Int -> Bool-prop_perms_invertable w xs =- replicate (fact (lengthV xs)) xs == map (\(xs, f) -> f xs) (permutationsV xs)- where- fact 0 = 1- fact n = n * fact (n - 1)--zeroN = Zero-oneN = Succ zeroN-twoN = Succ oneN-threeN = Succ twoN-fourN = Succ threeN+ \(6:8)-(6:33) stencil readOnce, (pointed(dim=1)) :: x" -- Indices for the 2D five point stencil (deliberately in an odd order) fivepoint = [ Cons (-1) (Cons 0 Nil), Cons 0 (Cons (-1) Nil)@@ -362,7 +311,7 @@ , Cons 1 (Cons 1 Nil) ] :: [ Vec (S (S Z)) Int ] {- Construct arbtirary vectors and test up to certain sizes -}-instance Arbitrary a => Arbitrary (Vec Z a) where+instance {-# OVERLAPPING #-} Arbitrary a => Arbitrary (Vec Z a) where arbitrary = return Nil instance (Arbitrary (Vec n a), Arbitrary a) => Arbitrary (Vec (S n) a) where@@ -384,68 +333,68 @@ variations = [ ( [ [0,0] ]- , Single $ Exact $ Spatial (Sum [Product [ Centered 0 1 True, Centered 0 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [ Centered 0 1 True, Centered 0 2 True]]) ) , ( [ [1,0] ]- , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 False, Centered 0 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [Forward 1 1 False, Centered 0 2 True]]) ) , ( [ [1,0], [0,0], [0,0] ]- , Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Centered 0 2 True]])+ , Mult $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Centered 0 2 True]]) ) , ( [ [0,1], [0,0] ]- , Single $ Exact $ Spatial (Sum [Product [Forward 1 2 True, Centered 0 1 True]])+ , Once $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Forward 1 2 True]]) ) , ( [ [1,1], [0,1], [1,0], [0,0] ]- , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 True]]) ) , ( [ [-1,0], [0,0] ]- , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Centered 0 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Centered 0 2 True]]) ) , ( [ [0,-1], [0,0], [0,-1] ]- , Multiple $ Exact $ Spatial (Sum [Product [Backward 1 2 True, Centered 0 1 True]])+ , Mult $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Backward 1 2 True]]) ) , ( [ [-1,-1], [0,-1], [-1,0], [0,0], [0, -1] ]- , Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 2 True]])+ , Mult $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 2 True]]) ) , ( [ [0,-1], [1,-1], [0,0], [1,0], [1,1], [0,1] ]- , Single $ Exact $ Spatial $ Sum [ Product [ Forward 1 1 True, Centered 1 2 True] ]+ , Once $ Exact $ Spatial $ Sum [ Product [ Forward 1 1 True, Centered 1 2 True] ] ) -- Stencil which is non-contiguous in one direction , ( [ [0, 4], [1, 4] ]- , Single $ Bound (Just (Spatial (Sum [ Product [ Forward 1 1 True ] ])))- (Just (Spatial (Sum [ Product [ Forward 1 1 True- , Forward 4 2 True ] ])))+ , Once $ Bound Nothing+ (Just (Spatial (Sum [ Product [ Forward 1 1 True+ , Forward 4 2 False ] ]))) ) ] variationsRel = [ -- Stencil which has non-relative indices in one dimension (Neighbour "i" 0, Constant (F.ValInteger "0"), [ [0, absoluteRep], [1, absoluteRep] ]- , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 True]])+ , Once $ Exact $ Spatial (Sum [Product [Forward 1 1 True]]) ) , (Neighbour "i" 1, Neighbour "j" 0, [ [0,0] ]- , Single $ Exact $ Spatial (Sum [Product [ Backward 1 1 False, Centered 0 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [ Backward 1 1 False, Centered 0 2 True]]) ) , (Neighbour "i" 0, Neighbour "j" 1, [ [0,1] ]- , Single $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 0 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 0 2 True]]) ) , (Neighbour "i" 1, Neighbour "j" (-1), [ [1,0], [0,0], [0,0] ]- , Multiple $ Exact $ Spatial (Sum [Product [Forward 1 2 False, Backward 1 1 True]])+ , Mult $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Forward 1 2 False]]) ) , (Neighbour "i" 0, Neighbour "j" (-1), [ [0,1], [0,0] ]- , Single $ Exact $ Spatial (Sum [Product [Forward 2 2 False, Centered 0 1 True]])+ , Once $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Forward 2 2 False]]) ) -- [0,1] [0,0] [0,-1] , (Neighbour "i" 1, Neighbour "j" 0, [ [1,1], [1,0], [1,-1] ]- , Single $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 1 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 1 2 True]]) ) , (Neighbour "i" 1, Neighbour "j" 0, [ [-2,0], [-1,0] ]- , Single $ Bound (Just (Spatial (Sum [Product [ Centered 0 2 True ]])))- (Just (Spatial (Sum [Product [ Backward 3 1 True- , Centered 0 2 True ]]))))+ , Once $ Bound Nothing+ (Just (Spatial (Sum [Product [ Backward 3 1 False+ , Centered 0 2 True ]])))) , (Constant (F.ValInteger "0"), Neighbour "j" 0, [ [absoluteRep,1], [absoluteRep,0], [absoluteRep,-1] ]- , Single $ Exact $ Spatial (Sum [Product [Centered 1 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [Centered 1 2 True]]) ) ] @@ -465,13 +414,13 @@ variations3D = [ ( [ [-1,0,-1], [0,0,-1], [-1,0,0], [0,0,0] ]- , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Centered 0 2 True, Backward 1 3 True]]) ) , ( [ [1,1,0], [0,1,0] ]- , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 False, Centered 0 3 True]])+ , Once $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 False, Centered 0 3 True]]) ) , ( [ [-1,0,-1], [0,0,-1], [-1,0,0], [0,0,0] ]- , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]])+ , Once $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Centered 0 2 True, Backward 1 3 True]]) ) ]
tests/Camfort/Specification/UnitsSpec.hs view
@@ -4,8 +4,11 @@ import qualified Data.ByteString.Char8 as B import Language.Fortran.Parser.Any+import Language.Fortran.ParserMonad (fromRight)+import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Renaming as FAR+import Data.Generics.Uniplate.Operations import Camfort.Input import Camfort.Functionality import Camfort.Output@@ -56,32 +59,73 @@ uOpts = unitOpts0 { uoNameMap = FAR.extractNameMap pf', uoDebug = True, uoLiterals = litMode } (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m +runUnitInference litMode pf = case r of+ Right vars -> ([ (FA.varName e, u) | e <- declVariables pf'+ , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ]+ , usConstraints state)+ _ -> ([], usConstraints state)+ where+ pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf+ uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode }+ (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> fmap chooseImplicitNames runInferVariables++declVariables :: F.ProgramFile UA -> [F.Expression UA]+declVariables pf = flip mapMaybe (universeBi pf) $ \ d -> case d of+ F.DeclVariable _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ -> Just v+ F.DeclArray _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just v+ _ -> Nothing++ spec :: Spec spec = do+ let showClean = show . nub . sort . head . rights . (:[]) . fst describe "Unit Inference Frontend" $ do describe "Literal Mode" $ do it "litTest1 Mixed" $ do- head (fromJust (head (rights [fst (runUnits LitMixed litTest1 runInconsistentConstraints)]))) `shouldSatisfy`- conParamEq (ConEq (UnitName "a") (UnitMul (UnitName "a") (UnitVar ("j", "j"))))+ (fromJust (head (rights [fst (runUnits LitMixed litTest1 runInconsistentConstraints)]))) `shouldSatisfy`+ any (conParamEq (ConEq (UnitVar ("k", "k")) (UnitMul (UnitVar ("j", "j")) (UnitVar ("j", "j"))))) it "litTest1 Poly" $ do- head (fromJust (head (rights [fst (runUnits LitPoly litTest1 runInconsistentConstraints)]))) `shouldSatisfy`- conParamEq (ConEq (UnitName "a") (UnitMul (UnitName "a") (UnitVar ("j", "j"))))+ (fromJust (head (rights [fst (runUnits LitPoly litTest1 runInconsistentConstraints)]))) `shouldSatisfy`+ any (conParamEq (ConEq (UnitVar ("k", "k")) (UnitMul (UnitVar ("j", "j")) (UnitVar ("j", "j"))))) it "litTest1 Unitless" $ do- head (fromJust (head (rights [fst (runUnits LitUnitless litTest1 runInconsistentConstraints)]))) `shouldSatisfy`- conParamEq (ConEq (UnitName "a") (UnitVar ("k", "k")))+ (fromJust (head (rights [fst (runUnits LitUnitless litTest1 runInconsistentConstraints)]))) `shouldSatisfy`+ any (conParamEq (ConEq UnitlessLit (UnitVar ("j", "j"))))+ it "Polymorphic non-zero literal is not OK" $ do+ head (rights [fst (runUnits LitMixed inconsist1 runInconsistentConstraints)]) `shouldSatisfy` isJust+ describe "Polymorphic functions" $ do it "squarePoly1" $ do- show (sort (head (rights [fst (runUnits LitMixed squarePoly1 runInferVariables)]))) `shouldBe`- show (sort [(("a", "a"),UnitName "m"),(("b", "b"), UnitName "s"),(("x", "x"),UnitPow (UnitName "m") 2.0),(("y", "y"),UnitPow (UnitName "s") 2.0)])+ showClean (runUnits LitMixed squarePoly1 (fmap chooseImplicitNames runInferVariables)) `shouldBe`+ "[((\"a\",\"a\"),m),((\"b\",\"b\"),s),((\"m\",\"m\"),'b),((\"n\",\"n\"),'a),((\"square\",\"square\"),('a)**2),((\"squarep\",\"squarep\"),('b)**2),((\"x\",\"x\"),m**2),((\"y\",\"y\"),s**2)]" describe "Recursive functions" $ do it "Recursive Addition is OK" $ do- show (sort (head (rights [fst (runUnits LitMixed recursive1 runInferVariables)]))) `shouldBe`- show (sort [(("y", "y"),UnitName "m"),(("z", "z"), UnitName "m")])+ showClean (runUnits LitMixed recursive1 (fmap chooseImplicitNames runInferVariables)) `shouldBe`+ "[((\"b\",\"b\"),'a),((\"n\",\"n\"),1),((\"r\",\"r\"),'a),((\"x\",\"x\"),1),((\"y\",\"y\"),m),((\"z\",\"z\"),m)]" describe "Recursive functions" $ do it "Recursive Multiplication is not OK" $ do- head (fromJust (head (rights [fst (runUnits LitMixed recursive2 runInconsistentConstraints)]))) `shouldSatisfy`- conParamEq (ConEq (UnitParamPosAbs ("recur", 0)) (UnitParamPosAbs ("recur", 2)))+ (fromJust (head (rights [fst (runUnits LitMixed recursive2 runInconsistentConstraints)]))) `shouldSatisfy`+ any (conParamEq (ConEq (UnitParamPosAbs ("recur", 0)) (UnitParamPosAbs ("recur", 2))))+ describe "Explicitly annotated parametric polymorphic unit variables" $ do+ it "inside-outside" $ do+ showClean (runUnits LitMixed insideOutside runInferVariables) `shouldBe`+ "[((\"inside\",\"inside\"),('a)**2),((\"k\",\"k\"),'a),((\"m\",\"m\"),('a)**2),((\"outside\",\"outside\"),('a)**2),((\"x\",\"x\"),'a),((\"y\",\"y\"),'a)]"+ it "eapVarScope" $ do+ show (sort (fst (runUnitInference LitMixed eapVarScope))) `shouldBe`+ "[(\"f\",('a)**3),(\"g\",'a),(\"j\",'a),(\"k\",('a)**3),(\"x\",'a),(\"y\",'a)]"+ it "eapVarApp" $ do+ show (sort (fst (runUnitInference LitMixed eapVarApp))) `shouldBe`+ "[(\"f\",('a)**2),(\"fj\",'a),(\"fk\",('a)**2),(\"fl\",('a)**4),(\"fx\",'a),(\"g\",'b),(\"gm\",'b),(\"gn\",'b),(\"gx\",'b),(\"h\",m**2),(\"hx\",m),(\"hy\",m**2)]" + describe "Implicit parametric polymorphic unit variables" $ do+ it "inferPoly1" $ do+ show (sort (fst (runUnitInference LitMixed inferPoly1))) `shouldBe`+ "[(\"fst\",'a),(\"id\",'c),(\"snd\",'d),(\"sqr\",('f)**2),(\"x1\",'c),(\"x2\",'f),(\"x3\",'a),(\"x4\",'e),(\"y3\",'b),(\"y4\",'d)]"++ describe "Intrinsic functions" $ do+ it "sqrtPoly" $ do+ show (sort (fst (runUnitInference LitMixed sqrtPoly))) `shouldBe`+ "[(\"a\",m**2),(\"b\",s**4),(\"c\",j**2),(\"n\",'a),(\"x\",m),(\"y\",s),(\"z\",j)]"+ describe "Unit Inference Backend" $ do describe "Flatten constraints" $ do it "testCons1" $ do@@ -111,7 +155,7 @@ criticalVariables testCons5 `shouldSatisfy` null describe "Infer Variables" $ do it "testCons5" $ do- inferVariables testCons5 `shouldBe` testCons5_infer+ show (inferVariables testCons5) `shouldBe` show testCons5_infer describe "Check that (restricted) double to ratios is consistent" $ do it "test all in -10/-10 ... 10/10, apart from /0" $ do and [testDoubleToRationalSubset x y | x <- [-10..10], y <- [-10..10]]@@ -193,7 +237,7 @@ else True -------------------------------------------------- -litTest1 = flip fortranParser "litTest1.f90" . B.pack $ unlines+litTest1 = flip fortranParser' "litTest1.f90" . B.pack $ unlines [ "program main" , " != unit(a) :: x" , " real :: x, j, k"@@ -204,7 +248,7 @@ , " x = x * j ! inconsistent" , "end program main" ] -squarePoly1 = flip fortranParser "squarePoly1.f90" . B.pack $ unlines+squarePoly1 = flip fortranParser' "squarePoly1.f90" . B.pack $ unlines [ "! Demonstrates parametric polymorphism through functions-calling-functions." , "program squarePoly" , " implicit none"@@ -227,7 +271,7 @@ , " end function" , "end program" ] -recursive1 = flip fortranParser "recursive1.f90" . B.pack $ unlines+recursive1 = flip fortranParser' "recursive1.f90" . B.pack $ unlines [ "program main" , " != unit(m) :: y" , " integer :: x = 5, y = 2, z"@@ -244,7 +288,7 @@ , " end function recur" , "end program main" ] -recursive2 = flip fortranParser "recursive2.f90" . B.pack $ unlines+recursive2 = flip fortranParser' "recursive2.f90" . B.pack $ unlines [ "program main" , " != unit(m) :: y" , " integer :: x = 5, y = 2, z"@@ -260,3 +304,130 @@ , " end if" , " end function recur" , "end program main" ]++insideOutside = flip fortranParser' "insideOutside.f90" . B.pack $ unlines+ [ "module insideOutside"+ , "contains"+ , " function outside(x)"+ , " != unit 'a :: x"+ , " real :: x, k, m, outside"+ , " k = x"+ , " outside = inside(k) * 2"+ , " m = outside"+ , " contains"+ , " function inside(y)"+ , " != unit 'a ** 2 :: inside"+ , " real :: y, inside"+ , " inside = y * y"+ , " end function inside"+ , " end function outside"+ , "end module insideOutside" ]++eapVarScope = flip fortranParser' "eapVarScope.f90" . B.pack $ unlines+ [ "module eapVarScope"+ , "contains"+ , " function f(x)"+ , " != unit 'a :: x"+ , " real :: x, k, f"+ , " k = g(x) * g(x * x)"+ , " f = k"+ , " end function f"+ , " function g(y)"+ , " != unit 'a :: y"+ , " real :: y, j, g"+ , " j = y"+ , " g = j"+ , " end function g"+ , "end module eapVarScope" ]++eapVarApp = flip fortranParser' "eapVarApp.f90" . B.pack $ unlines+ [ "module eapVarApp"+ , "contains"+ , " function f(fx)"+ , " != unit 'a :: fx"+ , " real :: fx, fj, fk, fl, f"+ , " fj = fx"+ , " fk = g(fj*fj)"+ , " fl = fj * g(fj * fj * fj)"+ , " f = fk"+ , " end function f"+ , " function g(gx)"+ , " != unit 'b :: gx"+ , " real :: gx, gn, gm, g"+ , " gm = gx"+ , " gn = gm"+ , " g = gn"+ , " end function g"+ , " function h(hx)"+ , " != unit m :: hx"+ , " real :: hx, h, hy"+ , " hy = f(hx)"+ , " h = hy"+ , " end function h"+ , "end module eapVarApp" ]++inferPoly1 = flip fortranParser' "inferPoly1.f90" . B.pack $ unlines+ [ "module inferPoly1"+ , "contains"+ , " function id(x1)"+ , " real :: x1, id"+ , " id = x1"+ , " end function id"+ , " function sqr(x2)"+ , " real :: x2, sqr"+ , " sqr = x2 * x2"+ , " end function sqr"+ , " function fst(x3,y3)"+ , " real :: x3, y3, fst"+ , " fst = x3"+ , " end function fst"+ , " function snd(x4,y4)"+ , " real :: x4, y4, snd"+ , " snd = y4"+ , " end function snd"+ , "end module inferPoly1" ]++-- This should be inconsistent because of the use of the literal "10"+-- in the parametric polymorphic function sqr.+inconsist1 = flip fortranParser' "inconsist1.f90" . B.pack $ unlines+ [ "program inconsist1"+ , " implicit none"+ , " real :: a, b"+ , " != unit(m) :: x"+ , " real :: x = 1"+ , " != unit(s) :: t"+ , " real :: t = 2"+ , " a = sqr(x) "+ , " b = sqr(t)"+ , " contains "+ , " real function sqr(y)"+ , " real :: y"+ , " real :: z = 10"+ , " sqr = y * y + z"+ , " end function"+ , "end program inconsist1" ]++-- Test intrinsic function sqrt()+sqrtPoly = flip fortranParser' "sqrtPoly.f90" . B.pack $ unlines+ [ "program sqrtPoly"+ , " implicit none"+ , " != unit m :: x"+ , " real :: x"+ , " != unit s :: y"+ , " real :: y"+ , " != unit J :: z"+ , " real :: z"+ , " integer :: a"+ , " integer :: b"+ , " integer :: c"+ , " x = sqrt(a)"+ , " y = sqrt(sqrt(b))"+ , " z = sqrt(square(sqrt(c)))"+ , "contains"+ , " real function square(n)"+ , " real :: n"+ , " square = n * n"+ , " end function square"+ , "end program sqrtPoly" ]++fortranParser' = \x -> fromRight . (fortranParser x)
tests/fixtures/Specification/Stencils/example2.f view
@@ -20,7 +20,7 @@ if (.true.) then c= region :: r2 = centered(depth=1, dim=2) x = a(i-1,j) + a(i,j) + a(i+1,j) + abs(0)-c= stencil readOnce, (reflexive(dim=1))*r2 + (reflexive(dim=2))*r1 :: a +c= stencil readOnce, (pointed(dim=1))*r2 + (pointed(dim=2))*r1 :: a b(i,j) = (x + a(i,j-1) + a(i,j+1)) / 5.0 c No specification should be inferred here b(0,0) = a(i, j)@@ -38,7 +38,7 @@ 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(mod(i,imax),1) + a(mod(i+1,imax) ,1) + a(mod(i-1,imax),1) + a(1,j) + x a(i,j) = a(i,j) + a(1,1) end if end do