camfort 0.804 → 0.900
raw patch · 62 files changed
+2269/−7882 lines, 62 filesdep −comonaddep −fclabelsdep −generic-derivingdep ~fortran-srcnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies removed: comonad, fclabels, generic-deriving, haskell-src, language-fortran, template-haskell
Dependency ranges changed: fortran-src
API changes (from Hackage documentation)
- Camfort.Analysis.Annotations: Functor :: ReduceType -> LoopType
- Camfort.Analysis.Annotations: Gather :: ReduceType -> ReduceType -> AccessPatternType -> LoopType
- Camfort.Analysis.Annotations: Irregular :: AccessPatternType
- Camfort.Analysis.Annotations: NoReduce :: ReduceType
- Camfort.Analysis.Annotations: Reduce :: ReduceType
- Camfort.Analysis.Annotations: Regular :: AccessPatternType
- Camfort.Analysis.Annotations: RegularAndConstants :: AccessPatternType
- Camfort.Analysis.Annotations: Scatter :: ReduceType -> AccessPatternType -> LoopType
- Camfort.Analysis.Annotations: Undecidable :: AccessPatternType
- Camfort.Analysis.Annotations: [lives] :: Annotation -> ([Access], [Access])
- Camfort.Analysis.Annotations: [successorStmts] :: Annotation -> [Int]
- Camfort.Analysis.Annotations: data AccessPatternType
- Camfort.Analysis.Annotations: data LoopType
- Camfort.Analysis.Annotations: data ReduceType
- Camfort.Analysis.Annotations: liveIn :: Annotation -> [Access]
- Camfort.Analysis.Annotations: liveOut :: Annotation -> [Access]
- Camfort.Analysis.CallGraph: type DefSites = [(String, String)]
- Camfort.Analysis.IntermediateReps: ArrayA :: String -> [Expr p] -> AccessP p
- Camfort.Analysis.IntermediateReps: VarA :: String -> AccessP p
- Camfort.Analysis.IntermediateReps: accessToVarName :: AccessP a -> Variable
- Camfort.Analysis.IntermediateReps: data AccessP p
- Camfort.Analysis.IntermediateReps: instance Data.Data.Data p => Data.Data.Data (Camfort.Analysis.IntermediateReps.AccessP p)
- Camfort.Analysis.IntermediateReps: instance GHC.Classes.Eq p => GHC.Classes.Eq (Camfort.Analysis.IntermediateReps.AccessP p)
- Camfort.Analysis.IntermediateReps: instance GHC.Show.Show (Camfort.Analysis.IntermediateReps.AccessP ())
- Camfort.Analysis.IntermediateReps: type Access = AccessP ()
- Camfort.Analysis.LVA: gen :: Fortran Annotation -> [Access]
- Camfort.Analysis.LVA: kill :: Fortran Annotation -> [Access]
- Camfort.Analysis.LVA: lva :: Program Annotation -> Program Annotation
- Camfort.Analysis.LVA: lva1 :: Zipper (ProgUnit Annotation) -> Zipper (ProgUnit Annotation)
- Camfort.Analysis.LVA: lvaOnUnit :: ProgUnit Annotation -> ProgUnit Annotation
- Camfort.Analysis.Syntax: AnnotationFree :: t -> AnnotationFree t
- Camfort.Analysis.Syntax: [Blocks] :: QueryCmd (Block Annotation)
- Camfort.Analysis.Syntax: [Decls] :: QueryCmd (Decl Annotation)
- Camfort.Analysis.Syntax: [Exprs] :: QueryCmd (Expr Annotation)
- Camfort.Analysis.Syntax: [Locs] :: QueryCmd Access
- Camfort.Analysis.Syntax: [Vars] :: QueryCmd (Expr Annotation)
- Camfort.Analysis.Syntax: [annotationBound] :: AnnotationFree t -> t
- Camfort.Analysis.Syntax: accesses :: Data from => from -> [AccessP ()]
- Camfort.Analysis.Syntax: af :: t -> AnnotationFree t
- Camfort.Analysis.Syntax: affineMatch :: (Read t1, Num t1) => Expr t -> Maybe (Variable, t1)
- Camfort.Analysis.Syntax: binders :: forall a t. (Data (t a), Typeable (t a), Data a, Typeable a) => t a -> [String]
- Camfort.Analysis.Syntax: class Successors t
- Camfort.Analysis.Syntax: data AnnotationFree t
- Camfort.Analysis.Syntax: data QueryCmd t
- Camfort.Analysis.Syntax: eraseSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a
- Camfort.Analysis.Syntax: freeVariables :: (Data (t a), Data a) => t a -> [String]
- Camfort.Analysis.Syntax: from :: forall t synTyp. (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp]
- Camfort.Analysis.Syntax: getSubName :: ProgUnit p -> Maybe String
- Camfort.Analysis.Syntax: instance (GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree a), GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree b)) => GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (a, b))
- Camfort.Analysis.Syntax: instance Camfort.Analysis.Syntax.Successors Language.Fortran.Fortran
- Camfort.Analysis.Syntax: instance GHC.Base.Monoid GHC.Types.Int
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (Camfort.Analysis.IntermediateReps.AccessP ()))
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (Language.Fortran.Attr p))
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (Language.Fortran.BaseType p))
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (Language.Fortran.Expr a))
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (Language.Fortran.Fraction p))
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (Language.Fortran.IntentAttr p))
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (Language.Fortran.MeasureUnitSpec p))
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (Language.Fortran.SubName p))
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree (Language.Fortran.Type a))
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree GHC.Types.Char)
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree GHC.Types.Int)
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree a) => GHC.Classes.Eq (Camfort.Analysis.Syntax.AnnotationFree [a])
- Camfort.Analysis.Syntax: instance GHC.Classes.Eq p => GHC.Classes.Ord (Language.Fortran.Expr p)
- Camfort.Analysis.Syntax: instance GHC.Classes.Ord (Camfort.Analysis.IntermediateReps.AccessP ())
- Camfort.Analysis.Syntax: instance GHC.Show.Show t => GHC.Show.Show (Camfort.Analysis.Syntax.AnnotationFree t)
- Camfort.Analysis.Syntax: isConstant :: Expr p -> Bool
- Camfort.Analysis.Syntax: lhsExpr :: Fortran Annotation -> [Expr Annotation]
- Camfort.Analysis.Syntax: lower :: [Char] -> [Char]
- Camfort.Analysis.Syntax: numberStmts :: ProgUnit Annotation -> ProgUnit Annotation
- Camfort.Analysis.Syntax: rhsExpr :: Fortran Annotation -> [Expr Annotation]
- Camfort.Analysis.Syntax: setCompactSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a
- Camfort.Analysis.Syntax: successors :: (Successors t, Eq a, Typeable a) => Zipper (ProgUnit a) -> [t a]
- Camfort.Analysis.Syntax: successorsRoot :: Successors t => t a -> [t a]
- Camfort.Analysis.Syntax: topFrom :: forall t synTyp. (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp]
- Camfort.Analysis.Syntax: unaf :: AnnotationFree t -> t
- Camfort.Analysis.Syntax: varExprToAccess :: Expr a -> Maybe Access
- Camfort.Analysis.Syntax: varExprToAccesses :: Expr a -> [Access]
- Camfort.Analysis.Syntax: varExprToVariable :: Expr a -> Maybe Variable
- Camfort.Analysis.Syntax: variables :: Data from => from -> [[Char]]
- Camfort.Analysis.Types: arrayElementType :: Type p -> Type p
- Camfort.Analysis.Types: bounds :: [Expr t] -> [(Expr t, Expr t)]
- Camfort.Analysis.Types: boundsP :: [Expr t] -> Bool
- Camfort.Analysis.Types: buildTypeEnv :: (Show a, Typeable a, Data a) => Block a -> State (TypeEnv a) (Block a)
- Camfort.Analysis.Types: eqType :: Variable -> Variable -> TypeEnv t -> Bool
- Camfort.Analysis.Types: gtypes :: forall a t. (Show a, Data (t a), Typeable (t a), Data a, Typeable a) => t a -> TypeEnv a
- Camfort.Analysis.Types: isArrayType :: (TypeEnv t) -> Variable -> Bool
- Camfort.Analysis.Types: lowercase :: [Char] -> [Char]
- Camfort.Analysis.Types: quicktest :: Type t -> Bool
- Camfort.Analysis.Types: tenvLookup :: Variable -> TypeEnv t -> Maybe (Type t)
- Camfort.Analysis.Types: toArrayType :: Type p -> [Expr p] -> Type p
- Camfort.Analysis.Types: type TypeEnv t = [(Variable, Type t)]
- Camfort.Analysis.Types: type TypeEnvStack t = [TypeEnv t]
- Camfort.Analysis.Types: typeAnnotations :: (Show a, Typeable a, Data a) => Program a -> State (TypeEnv a) (Program a)
- Camfort.Analysis.Types: typeEnv :: (Show a, Typeable a, Data a) => Block a -> TypeEnv a
- Camfort.Functionality: asts :: [Char] -> [Filename] -> t1 -> t -> IO ()
- Camfort.Functionality: callAndSummarise :: (Monoid a, Foldable t) => (t1 -> t3 -> (a, a1)) -> t (t1, t2, t3) -> (a, [a1])
- Camfort.Functionality: commonToArgs :: [Char] -> [Filename] -> FileOrDir -> t -> IO ()
- Camfort.Functionality: doAnalysisReportForpar :: ([(Filename, ProgramFile A)] -> (String, t1)) -> FileOrDir -> [Filename] -> t -> IO ()
- Camfort.Functionality: doAnalysisSummaryForpar :: (Monoid s, Show' s) => (Filename -> ProgramFile A -> (s, ProgramFile A)) -> FileOrDir -> [Filename] -> Maybe FileOrDir -> IO ()
- Camfort.Functionality: doRefactorForpar :: ([(Filename, ProgramFile A)] -> (String, [(Filename, ProgramFile Annotation)])) -> FileOrDir -> [Filename] -> FileOrDir -> IO ()
- Camfort.Functionality: flexReadFile :: String -> IO ByteString
- Camfort.Functionality: lvaA :: [Char] -> [Filename] -> t1 -> t -> IO ()
- Camfort.Functionality: mkOutputFileForpar :: [(Filename, SourceText, a)] -> [(Filename, ProgramFile Annotation)] -> [(Filename, SourceText, ProgramFile Annotation)]
- Camfort.Functionality: readForparseSrcDir :: FileOrDir -> [Filename] -> IO [(Filename, SourceText, ProgramFile A)]
- Camfort.Functionality: readForparseSrcFile :: Filename -> IO (Filename, SourceText, ProgramFile A)
- Camfort.Functionality: stencilsVarFlowCycles :: [Char] -> [Filename] -> t1 -> t -> IO ()
- Camfort.Functionality: typeStructuring :: [Char] -> [Filename] -> FileOrDir -> t -> IO ()
- Camfort.Helpers: lineCol :: SrcLoc -> (Int, Int)
- Camfort.Helpers: spanLineCol :: SrcSpan -> ((Int, Int), (Int, Int))
- Camfort.Input: doAnalysis :: (Program A -> Program Annotation) -> FileOrDir -> [Filename] -> IO ()
- Camfort.Input: doAnalysisReport' :: ([(Filename, Program A)] -> (String, t1)) -> FileOrDir -> [Filename] -> t -> IO ()
- Camfort.Input: parse :: Filename -> IO (Program ())
- Camfort.Output: PR :: (Program a) -> PR a
- Camfort.Output: data PR a
- Camfort.Output: instance Camfort.Output.OutputFiles (Camfort.Helpers.Filename, Camfort.Helpers.SourceText, Language.Fortran.Program Camfort.Analysis.Annotations.Annotation)
- Camfort.Output: instance Camfort.PrettyPrint.PrettyPrint (Camfort.Output.PR Camfort.Analysis.Annotations.Annotation)
- Camfort.Output: instance Camfort.PrettyPrint.PrettyPrint (Language.Fortran.AST.ProgramFile Camfort.Analysis.Annotations.Annotation)
- Camfort.Output: instance Data.Data.Data a => Data.Data.Data (Camfort.Output.PR a)
- Camfort.Output: outputAnalysisFiles :: FileOrDir -> [Program Annotation] -> [Filename] -> IO ()
- Camfort.Output: refactorArgName :: Monad m => SourceText -> ArgName Annotation -> StateT SrcLoc m (SourceText, Bool)
- Camfort.Output: refactorDecl :: SourceText -> Decl Annotation -> StateT SrcLoc (State Int) (SourceText, Bool)
- Camfort.Output: refactorFortran :: Monad m => SourceText -> Fortran Annotation -> StateT SrcLoc m (SourceText, Bool)
- Camfort.Output: refactorUses :: SourceText -> Uses Annotation -> StateT SrcLoc (State Int) (SourceText, Bool)
- Camfort.Output: refactoringForPar :: (Typeable a) => a -> SourceText -> StateT SrcLoc Identity (SourceText, Bool)
- Camfort.Output: refactoringLF :: (Typeable a) => a -> SourceText -> StateT SrcLoc (State Int) (SourceText, Bool)
- Camfort.Output: srcSpanToSrcLocs :: SrcSpan -> (SrcLoc, SrcLoc)
- Camfort.PrettyPrint: HTMLPP :: HTMLPP
- Camfort.PrettyPrint: annotationMark :: Tagged d => t -> d Annotation -> [Char] -> [Char]
- Camfort.PrettyPrint: breakUp :: [Char] -> [Char]
- Camfort.PrettyPrint: class PrettyPrint p
- Camfort.PrettyPrint: colors :: [[Char]]
- Camfort.PrettyPrint: countToColor :: Int -> [Char]
- Camfort.PrettyPrint: data HTMLPP
- Camfort.PrettyPrint: instance (Language.Fortran.Pretty.Indentor (Language.Fortran.Decl p), Language.Fortran.Pretty.PrintSlave (Language.Fortran.DataForm p) Camfort.PrettyPrint.HTMLPP) => Language.Fortran.Pretty.PrintSlave (Language.Fortran.Decl p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance (Language.Fortran.Pretty.PrintIndSlave (Language.Fortran.Fortran p) Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.PrintSlave p Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.Indentor (Language.Fortran.Fortran p)) => Language.Fortran.Pretty.PrintSlave (Language.Fortran.Fortran p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance (Language.Fortran.Pretty.PrintSlave (Language.Fortran.Decl p) Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.Indentor (Language.Fortran.Decl p)) => Language.Fortran.Pretty.PrintSlave (Language.Fortran.InterfaceSpec p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance (Language.Fortran.Pretty.PrintSlave (Language.Fortran.Decl p) Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.PrintIndSlave (Language.Fortran.Fortran p) Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.PrintSlave p Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.Indentor (Language.Fortran.Decl p), Language.Fortran.Pretty.Indentor (Language.Fortran.Fortran p)) => Language.Fortran.Pretty.PrintSlave (Language.Fortran.ProgUnit p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance (Language.Fortran.Pretty.PrintSlave (Language.Fortran.Decl p) Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.PrintSlave (Language.Fortran.DataForm p) Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.PrintIndSlave (Language.Fortran.Fortran p) Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.PrintSlave p Camfort.PrettyPrint.HTMLPP, Language.Fortran.Pretty.Indentor (Language.Fortran.Fortran p), Language.Fortran.Pretty.Indentor (Language.Fortran.Decl p)) => Language.Fortran.Pretty.PrintSlave (Language.Fortran.Block p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.Indentor (Language.Fortran.Fortran GHC.Types.Bool)
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PPVersion Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintIndSlave (Language.Fortran.Fortran Camfort.Analysis.Annotations.Annotation) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintIndSlave (Language.Fortran.Fortran Camfort.PrettyPrint.A1) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintMaster (Language.Fortran.Program Camfort.Analysis.Annotations.Annotation) Language.Fortran.Pretty.DefaultPP => Camfort.PrettyPrint.PrettyPrint (Language.Fortran.Program Camfort.Analysis.Annotations.Annotation)
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.Arg p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.ArgList p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.ArgName p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.Attr p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.BaseType p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.BinOp p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.DataForm p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.DataForm p) Camfort.PrettyPrint.HTMLPP => Language.Fortran.Pretty.PrintSlave (Language.Fortran.Expr p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.DataForm p) Camfort.PrettyPrint.HTMLPP => Language.Fortran.Pretty.PrintSlave (Language.Fortran.SubName p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.Decl Camfort.Analysis.Annotations.Annotation) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.Decl p) Camfort.PrettyPrint.HTMLPP => Language.Fortran.Pretty.PrintSlave (Language.Fortran.Implicit p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.Fraction p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.GSpec p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.MeasureUnitSpec p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.Spec p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.Type p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.UnaryOp p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.Uses p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave (Language.Fortran.VarName p) Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave Camfort.Analysis.Annotations.Annotation Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave GHC.Types.Bool Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Pretty.PrintSlave Language.Fortran.SrcLoc Camfort.PrettyPrint.HTMLPP
- Camfort.PrettyPrint: instance Language.Fortran.Tagged p => Language.Fortran.Pretty.Indentor (p Camfort.Analysis.Annotations.Annotation)
- Camfort.PrettyPrint: keyword :: [Text]
- Camfort.PrettyPrint: nearbyClose :: (Num a, Eq a) => [Char] -> a -> Bool
- Camfort.PrettyPrint: outputAnn :: Annotation -> Bool -> Int -> [Char] -> [Char]
- Camfort.PrettyPrint: outputHTML :: forall p. (Data p, Typeable p, PrintSlave p HTMLPP, PrintSlave (Decl p) HTMLPP, PrintIndSlave (Fortran p) HTMLPP, Indentor (Decl p), Indentor (Fortran p)) => ProgUnit p -> String
- Camfort.PrettyPrint: outputHTMLA :: ProgUnit Annotation -> String
- Camfort.PrettyPrint: prettyPrint :: PrettyPrint p => p -> SourceText
- Camfort.PrettyPrint: prettyp :: [Char] -> [Char]
- Camfort.PrettyPrint: prettyp' :: [Char] -> Int -> [Bool] -> [Char]
- Camfort.PrettyPrint: row :: Foldable t => t [Char] -> [Char]
- Camfort.PrettyPrint: showUse' :: Uses p -> String
- Camfort.PrettyPrint: type A1 = Bool
- Camfort.Specification.Stencils: findVarFlowCycles :: Data a => ProgramFile a -> [(Name, Name)]
- Camfort.Specification.Stencils.CheckFrontend: compareInferredToDeclared :: [([Name], Specification)] -> SpecDecls -> Bool
- Camfort.Specification.Stencils.Grammar: Temporal :: [String] -> Bool -> Spec
- Camfort.Specification.Stencils.InferenceFrontend: findVarFlowCycles :: Data a => ProgramFile a -> [(Name, Name)]
- Camfort.Specification.Stencils.InferenceFrontend: findVarFlowCycles' :: Data a => ProgramFile (Analysis a) -> [(Name, Name)]
- Camfort.Specification.Stencils.InferenceFrontend: type Cycles = [(Name, Name)]
- Camfort.Specification.Stencils.Model: eqByModel :: Specification -> Specification -> Bool
- Camfort.Specification.Stencils.Model: instance Camfort.Specification.Stencils.Model.Model (Camfort.Specification.Stencils.Syntax.Result Camfort.Specification.Stencils.Syntax.Spatial)
- Camfort.Specification.Stencils.Model: mkMultiset :: Ord a => [a] -> Map a Bool
- Camfort.Specification.Stencils.Model: type Multiset a = Map a Bool
- Camfort.Specification.Stencils.Syntax: Dependency :: [String] -> Bool -> Temporal
- Camfort.Specification.Stencils.Syntax: [modLinearity] :: Spatial -> Linearity
- Camfort.Specification.Stencils.Syntax: [region] :: Spatial -> RegionSum
- Camfort.Specification.Stencils.Syntax: data Result a
- Camfort.Specification.Stencils.Syntax: data Temporal
- Camfort.Specification.Stencils.Syntax: emptySpatialSpec :: Spatial
- Camfort.Specification.Stencils.Syntax: emptySpec :: Specification
- Camfort.Specification.Stencils.Syntax: instance Camfort.Specification.Stencils.Syntax.RegionRig (Camfort.Specification.Stencils.Syntax.Result Camfort.Specification.Stencils.Syntax.Spatial)
- Camfort.Specification.Stencils.Syntax: instance Camfort.Specification.Stencils.Syntax.RegionRig Camfort.Specification.Stencils.Syntax.Linearity
- Camfort.Specification.Stencils.Syntax: instance Data.Data.Data Camfort.Specification.Stencils.Syntax.Temporal
- Camfort.Specification.Stencils.Syntax: instance Data.Data.Data a => Data.Data.Data (Camfort.Specification.Stencils.Syntax.Result a)
- Camfort.Specification.Stencils.Syntax: instance GHC.Base.Functor Camfort.Specification.Stencils.Syntax.Result
- Camfort.Specification.Stencils.Syntax: instance GHC.Classes.Eq Camfort.Specification.Stencils.Syntax.Temporal
- Camfort.Specification.Stencils.Syntax: instance GHC.Classes.Eq a => GHC.Classes.Eq (Camfort.Specification.Stencils.Syntax.Result a)
- Camfort.Specification.Stencils.Syntax: instance GHC.Show.Show (Camfort.Specification.Stencils.Syntax.Result Camfort.Specification.Stencils.Syntax.Spatial)
- Camfort.Specification.Stencils.Syntax: instance GHC.Show.Show Camfort.Specification.Stencils.Syntax.Temporal
- Camfort.Specification.Stencils.Syntax: instance GHC.Show.Show a => GHC.Show.Show (Camfort.Specification.Stencils.Syntax.Result a)
- Camfort.Specification.Stencils.Syntax: specPlus :: Specification -> Specification -> Maybe Specification
- Camfort.Specification.Stencils.Synthesis: ixExprToSubscript :: Name -> [Index (Analysis A)] -> Expression (Analysis A)
- Camfort.Specification.Stencils.Synthesis: lineCol :: Position -> (Int, Int)
- Camfort.Specification.Stencils.Synthesis: offsetToIxWithIVs :: [Variable] -> Name -> Int -> Index (Analysis A)
- Camfort.Specification.Stencils.Synthesis: spanLineCol :: SrcSpan -> ((Int, Int), (Int, Int))
- Camfort.Specification.Stencils.Synthesis: synthesise :: Specification -> Name -> [Name] -> [Expression (Analysis A)]
- Camfort.Transformation.CommonBlockElim: addToBlock :: Block A -> [Fortran A] -> Block A
- Camfort.Transformation.CommonBlockElim: addToProgUnit :: ProgUnit A -> [Fortran A] -> ProgUnit A
- Camfort.Transformation.CommonBlockElim: allCoherentCommonsP :: [TLCommon A] -> (Report, Bool)
- Camfort.Transformation.CommonBlockElim: analyseCommons :: [(Filename, Program A)] -> State (Report, [TLCommon A]) [(Filename, Program A)]
- Camfort.Transformation.CommonBlockElim: coherentCommonsP :: TLCommon A -> TLCommon A -> (Report, Bool)
- Camfort.Transformation.CommonBlockElim: collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A)
- Camfort.Transformation.CommonBlockElim: mkUseStatements :: SrcLoc -> [(TCommon A, RenamerCoercer)] -> Uses A
- Camfort.Transformation.CommonBlockElim: onCommonBlock :: (TCommon A -> TCommon A) -> TLCommon A -> TLCommon A
- Camfort.Transformation.CommonBlockElim: prependStatements :: Maybe SrcSpan -> Fortran A -> [Fortran A] -> Fortran A
- Camfort.Transformation.CommonBlockElim: useSrcLoc :: ProgUnit A -> SrcLoc
- Camfort.Transformation.CommonBlockElim: useSrcLocB :: Block t -> SrcLoc
- Camfort.Transformation.CommonBlockElimToCalls: collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A)
- Camfort.Transformation.CommonBlockElimToCalls: commonElimToCalls :: Directory -> [(Filename, Program A)] -> (Report, [(Filename, Program A)])
- Camfort.Transformation.CommonBlockElimToCalls: extendArgs :: Bool -> (SrcLoc, SrcLoc) -> [(String, t)] -> ArgName Annotation
- Camfort.Transformation.CommonBlockElimToCalls: extendArgs' :: (SrcLoc, b) -> [(String, t)] -> ArgName Annotation
- Camfort.Transformation.CommonBlockElimToCalls: extendCalls :: String -> String -> [TLCommon A] -> Fortran A -> (Report, Fortran A)
- Camfort.Transformation.CommonBlockElimToCalls: introduceCalls :: [TLCommon A] -> (Filename, Program A) -> (Report, (Filename, Program A))
- Camfort.Transformation.CommonBlockElimToCalls: nonNullArgs :: ArgName t -> Bool
- Camfort.Transformation.CommonBlockElimToCalls: select :: [Maybe String] -> [TCommon A] -> [(Variable, Type A)]
- Camfort.Transformation.CommonBlockElimToCalls: toArgList :: A -> SrcSpan -> [(Variable, Type A)] -> Expr A
- Camfort.Transformation.DeadCode: elimDead :: Bool -> Fortran Annotation -> (Report, Fortran Annotation)
- Camfort.Transformation.DeadCode: elimEmptyFseq :: Fortran Annotation -> Fortran Annotation
- Camfort.Transformation.DerivedTypeIntro: arrayAccessToProjection :: Fortran A -> Graph Access Variable -> Fortran A
- Camfort.Transformation.DerivedTypeIntro: binEdge :: (Show v, Ord v, Ord a) => [(Set v, WeightedGraph v a)] -> WeightedEdge v a -> [(Set v, WeightedGraph v a)]
- Camfort.Transformation.DerivedTypeIntro: calculateWeights :: (Eq (AnnotationFree a), Eq (AnnotationFree v), Ord a, Ord v) => Graph v a -> WeightedGraph v a
- Camfort.Transformation.DerivedTypeIntro: correctManualImpl :: (Data t, Eq p) => [(Variable, (Integer, Integer))] -> t -> [((AccessP p, AccessP p), Variable)] -> Bool
- Camfort.Transformation.DerivedTypeIntro: decomposeWeightedGraph :: forall v a. (Show v, Ord v, Ord a) => WeightedGraph v a -> [WeightedGraph v a]
- Camfort.Transformation.DerivedTypeIntro: elimProjectionDefs :: Fortran A -> Graph Access Variable -> Fortran A
- Camfort.Transformation.DerivedTypeIntro: findMatch :: t -> t1 -> [(t2, t3)] -> [((b, b), t4)] -> [b]
- Camfort.Transformation.DerivedTypeIntro: getVertex :: Eq t => t -> [((t, t), a)] -> Maybe a
- Camfort.Transformation.DerivedTypeIntro: inventName :: WeightedGraph Access Variable -> State Int String
- Camfort.Transformation.DerivedTypeIntro: isVertex :: Eq a => a -> [((a, a), t)] -> Bool
- Camfort.Transformation.DerivedTypeIntro: listToSymmRelation :: [a] -> [(a, a)]
- Camfort.Transformation.DerivedTypeIntro: locsFromArrayIndex :: Data t => t -> [(Variable, Access)]
- Camfort.Transformation.DerivedTypeIntro: mkTyDecl :: SrcSpan -> Variable -> Type Annotation -> Decl Annotation
- Camfort.Transformation.DerivedTypeIntro: mkTypeDef :: TypeEnv Annotation -> SrcSpan -> WeightedGraph Access Variable -> State Int (Decl Annotation, String)
- Camfort.Transformation.DerivedTypeIntro: mode :: String -> Char
- Camfort.Transformation.DerivedTypeIntro: swap :: ((t2, t1), t) -> ((t1, t2), t)
- Camfort.Transformation.DerivedTypeIntro: toInterferenceGraph :: [[(Variable, Access)]] -> Graph Access Variable
- Camfort.Transformation.DerivedTypeIntro: type Graph v a = [((v, v), a)]
- Camfort.Transformation.DerivedTypeIntro: type WeightedEdge v a = ((v, v), (a, Int))
- Camfort.Transformation.DerivedTypeIntro: type WeightedGraph v a = [WeightedEdge v a]
- Camfort.Transformation.DerivedTypeIntro: typeStruct :: [(Filename, Program Annotation)] -> (Report, [(Filename, Program Annotation)])
- Camfort.Transformation.DerivedTypeIntro: typeStructPerProgram :: ProgUnit Annotation -> (Report, ProgUnit Annotation)
- Camfort.Transformation.DerivedTypeIntro: vertices :: [((b, b), t)] -> [b]
- Camfort.Transformation.EquivalenceElim: addCopy :: (?fname :: String) => TypeEnv Annotation -> Fortran Annotation -> State RfEqState (Fortran Annotation)
- Camfort.Transformation.EquivalenceElim: equivalents :: (?fname :: String) => Expr Annotation -> State RfEqState [Expr Annotation]
- Camfort.Transformation.EquivalenceElim: rmEquivalences :: (?fname :: String) => (Block Annotation) -> State RfEqState (Block Annotation)
- Camfort.Transformation.EquivalenceElim: type RfEqState = ([[Expr Annotation]], Int, Report)
- Camfort.Transformation.Syntax: afterEnd :: SrcSpan -> SrcSpan
- Camfort.Transformation.Syntax: applyRenaming :: (Typeable (t A), Data (t A)) => Renamer -> (t A) -> (t A)
- Camfort.Transformation.Syntax: caml :: [Char] -> [Char]
- Camfort.Transformation.Syntax: class Renaming r
- Camfort.Transformation.Syntax: decCol :: SrcLoc -> SrcLoc
- Camfort.Transformation.Syntax: decLine :: SrcLoc -> SrcLoc
- Camfort.Transformation.Syntax: dropLine :: SrcSpan -> SrcSpan
- Camfort.Transformation.Syntax: dropLine' :: SrcSpan -> SrcLoc
- Camfort.Transformation.Syntax: hasRenaming :: Renaming r => Variable -> r -> Bool
- Camfort.Transformation.Syntax: incCol :: SrcLoc -> SrcLoc
- Camfort.Transformation.Syntax: incLine :: SrcLoc -> SrcLoc
- Camfort.Transformation.Syntax: instance Camfort.Transformation.Syntax.Renaming Camfort.Transformation.Syntax.RenamerCoercer
- Camfort.Transformation.Syntax: instance Camfort.Transformation.Syntax.Renaming [Camfort.Transformation.Syntax.RenamerCoercer]
- Camfort.Transformation.Syntax: linesCovered :: SrcLoc -> SrcLoc -> Int
- Camfort.Transformation.Syntax: minaa :: SrcLoc -> SrcLoc
- Camfort.Transformation.Syntax: nullLoc :: SrcLoc
- Camfort.Transformation.Syntax: nullSpan :: SrcSpan
- Camfort.Transformation.Syntax: reassociate :: Fortran Annotation -> Fortran Annotation
- Camfort.Transformation.Syntax: refactorSpan :: SrcSpan -> SrcSpan
- Camfort.Transformation.Syntax: refactorSpanN :: Int -> SrcSpan -> SrcSpan
- Camfort.Transformation.Syntax: srcLineCol :: SrcLoc -> (Int, Int)
- Camfort.Transformation.Syntax: toCol0 :: SrcLoc -> SrcLoc
- Camfort.Transformation.Syntax: type Renamer = Map Variable Variable
- Camfort.Transformation.Syntax: type RenamerCoercer = Maybe (Map Variable (Maybe Variable, Maybe (Type A, Type A)))
- Camfort.Traverse: annotation :: Tagged g => g a -> a
- Camfort.Traverse: class RComonad t
- Camfort.Traverse: class RFunctor t
- Camfort.Traverse: class Refill d
- Camfort.Traverse: everywhere :: (Zipper a -> Zipper a) -> Zipper a -> Zipper a
- Camfort.Traverse: extendBi :: (Biplate (from a) (to a), RComonad to) => (to a -> a) -> (from a) -> (from a)
- Camfort.Traverse: extendBi' :: (Biplate (from a) (to a), Comonad to) => (to a -> a) -> (from a) -> (from a)
- Camfort.Traverse: instance Camfort.Traverse.RComonad Language.Fortran.Fortran
- Camfort.Traverse: instance Camfort.Traverse.Refill Language.Fortran.Fortran
- Camfort.Traverse: reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a]
- Camfort.Traverse: refill :: Refill d => d a -> a -> d a
- Camfort.Traverse: rextend :: RComonad t => (t a -> a) -> t a -> t a
- Camfort.Traverse: rextract :: RComonad t => t a -> a
- Camfort.Traverse: rfmap :: RFunctor t => (a -> a) -> t a -> t a
- Camfort.Traverse: zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a)
+ Camfort.Analysis.Annotations: [deleteNode] :: Annotation -> Bool
+ Camfort.Functionality: Doxygen :: Flag
+ Camfort.Functionality: Ford :: Flag
+ Camfort.Functionality: instance GHC.Classes.Eq Camfort.Functionality.Flag
+ Camfort.Helpers: everywhere :: (Zipper a -> Zipper a) -> Zipper a -> Zipper a
+ Camfort.Helpers: reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a]
+ Camfort.Helpers: zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a)
+ Camfort.Helpers.Syntax: AnnotationFree :: t -> AnnotationFree t
+ Camfort.Helpers.Syntax: [annotationBound] :: AnnotationFree t -> t
+ Camfort.Helpers.Syntax: af :: t -> AnnotationFree t
+ Camfort.Helpers.Syntax: afterAligned :: SrcSpan -> Position
+ Camfort.Helpers.Syntax: caml :: [Char] -> [Char]
+ Camfort.Helpers.Syntax: data AnnotationFree t
+ Camfort.Helpers.Syntax: deleteLine :: SrcSpan -> SrcSpan
+ Camfort.Helpers.Syntax: dropLine :: SrcSpan -> SrcSpan
+ Camfort.Helpers.Syntax: extractVariable :: Expression a -> Maybe Name
+ Camfort.Helpers.Syntax: instance (GHC.Classes.Eq (Camfort.Helpers.Syntax.AnnotationFree a), GHC.Classes.Eq (Camfort.Helpers.Syntax.AnnotationFree b)) => GHC.Classes.Eq (Camfort.Helpers.Syntax.AnnotationFree (a, b))
+ Camfort.Helpers.Syntax: instance GHC.Base.Monoid GHC.Types.Int
+ Camfort.Helpers.Syntax: instance GHC.Classes.Eq (Camfort.Helpers.Syntax.AnnotationFree Language.Fortran.AST.BaseType)
+ Camfort.Helpers.Syntax: instance GHC.Classes.Eq (Camfort.Helpers.Syntax.AnnotationFree a) => GHC.Classes.Eq (Camfort.Helpers.Syntax.AnnotationFree [a])
+ Camfort.Helpers.Syntax: instance GHC.Classes.Eq a => GHC.Classes.Eq (Camfort.Helpers.Syntax.AnnotationFree (Language.Fortran.AST.Expression a))
+ Camfort.Helpers.Syntax: instance GHC.Show.Show t => GHC.Show.Show (Camfort.Helpers.Syntax.AnnotationFree t)
+ Camfort.Helpers.Syntax: linesCovered :: Position -> Position -> Int
+ Camfort.Helpers.Syntax: lower :: [Char] -> [Char]
+ Camfort.Helpers.Syntax: toCol0 :: Position -> Position
+ Camfort.Helpers.Syntax: unaf :: AnnotationFree t -> t
+ Camfort.Input: callAndSummarise :: (Monoid a1, Foldable t1) => (t3 -> t2 -> (a1, a)) -> t1 (t3, t, t2) -> (a1, [a])
+ Camfort.Input: doRefactorAndCreate :: ([(Filename, ProgramFile A)] -> (String, [(Filename, ProgramFile A)], [(Filename, ProgramFile A)])) -> FileOrDir -> [Filename] -> FileOrDir -> IO String
+ Camfort.Input: flexReadFile :: String -> IO ByteString
+ Camfort.Input: reassociateSourceText :: [(Filename, SourceText, a)] -> [(Filename, ProgramFile Annotation)] -> [(Filename, SourceText, ProgramFile Annotation)]
+ Camfort.Output: isNewFile :: OutputFiles t => t -> Bool
+ Camfort.Output: refactorBlocks :: FortranVersion -> SourceText -> Block Annotation -> StateT Position (State Int) (SourceText, Bool)
+ Camfort.Output: refactorStatements :: FortranVersion -> SourceText -> Statement A -> StateT Position (State Int) (SourceText, Bool)
+ Camfort.Output: refactorSyntax :: (Typeable s, Annotated s, Spanned (s A), IndentablePretty (s A)) => FortranVersion -> SourceText -> s A -> StateT Position (State Int) (SourceText, Bool)
+ Camfort.Output: refactoring :: Typeable a => FortranVersion -> a -> SourceText -> StateT Position Identity (SourceText, Bool)
+ Camfort.Specification.Stencils.CheckFrontend: checkOffsetsAgainstSpec :: [(Variable, Multiplicity [[Int]])] -> [(Variable, Specification)] -> Bool
+ Camfort.Specification.Stencils.InferenceBackend: inferCore :: (IsNatural n, Permutable n) => [Vec n Int] -> Approximation Spatial
+ Camfort.Specification.Stencils.InferenceFrontend: genOffsets :: Params => InductionVarMapByASTBlock -> [Neighbour] -> [Block (Analysis A)] -> Writer EvalLog [(Variable, (Bool, [[Int]]))]
+ Camfort.Specification.Stencils.InferenceFrontend: indicesToRelativisedOffsets :: InductionVarMapByASTBlock -> Variable -> [Neighbour] -> [[Index (Analysis Annotation)]] -> Writer EvalLog (Maybe (Bool, [[Int]]))
+ Camfort.Specification.Stencils.InferenceFrontend: strength :: Monad m => (a, m b) -> m (a, b)
+ Camfort.Specification.Stencils.Model: consistent :: Multiplicity [[Int]] -> Multiplicity (Approximation Spatial) -> Bool
+ 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.Syntax: Multiple :: a -> Multiplicity a
+ Camfort.Specification.Stencils.Syntax: Single :: a -> Multiplicity a
+ Camfort.Specification.Stencils.Syntax: data Approximation a
+ Camfort.Specification.Stencils.Syntax: data Multiplicity a
+ Camfort.Specification.Stencils.Syntax: fromMult :: Multiplicity a -> a
+ 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.Units.Environment: pprintConstr :: Constraint -> String
+ Camfort.Specification.Units.Environment: pprintUnitInfo :: UnitInfo -> String
+ Camfort.Specification.Units.Environment: type VV = (Name, Name)
+ Camfort.Specification.Units.Monad: type VV = (Name, Name)
+ Camfort.Transformation.CommonBlockElim: addToProgramUnit :: FortranVersion -> ProgramUnit A -> [Statement A] -> ProgramUnit A
+ Camfort.Transformation.CommonBlockElim: allCoherentCommons :: [TLCommon A] -> (Report, Bool)
+ Camfort.Transformation.CommonBlockElim: analyseAndRmCommons :: [(Filename, ProgramFile A)] -> CommonState [(Filename, ProgramFile A)]
+ Camfort.Transformation.CommonBlockElim: analysePerPF :: (Filename, ProgramFile A) -> CommonState (Filename, ProgramFile A)
+ Camfort.Transformation.CommonBlockElim: analysePerPU :: TypeEnv -> Filename -> ProgramUnit A1 -> CommonState (ProgramUnit A1)
+ Camfort.Transformation.CommonBlockElim: applyRenaming :: (Typeable (t A), Data (t A)) => NameMap -> t A -> t A
+ Camfort.Transformation.CommonBlockElim: class Renaming r
+ Camfort.Transformation.CommonBlockElim: coherentCommons :: TLCommon A -> TLCommon A -> (Report, Bool)
+ Camfort.Transformation.CommonBlockElim: coherentCommons' :: [(Name, BaseType)] -> [(Name, BaseType)] -> (Report, Bool)
+ Camfort.Transformation.CommonBlockElim: collectAndRmCommons :: TypeEnv -> Filename -> ProgramUnitName -> Block A1 -> CommonState (Block A1)
+ Camfort.Transformation.CommonBlockElim: commonNameFromAST :: Maybe (Expression t) -> Maybe Name
+ Camfort.Transformation.CommonBlockElim: getUnitStartPosition :: ProgramUnit A -> SrcSpan
+ Camfort.Transformation.CommonBlockElim: hasRenaming :: Renaming r => Name -> r -> Bool
+ Camfort.Transformation.CommonBlockElim: instance Camfort.Transformation.CommonBlockElim.Renaming Camfort.Transformation.CommonBlockElim.RenamerCoercer
+ Camfort.Transformation.CommonBlockElim: instance Camfort.Transformation.CommonBlockElim.Renaming [Camfort.Transformation.CommonBlockElim.RenamerCoercer]
+ Camfort.Transformation.CommonBlockElim: mkUseStatementBlocks :: SrcSpan -> [(TCommon A, RenamerCoercer)] -> [Block A]
+ Camfort.Transformation.CommonBlockElim: type A1 = Analysis Annotation
+ Camfort.Transformation.CommonBlockElim: type CommonState = State (Report, [TLCommon A])
+ Camfort.Transformation.CommonBlockElim: type NameMap = Map Name Name
+ Camfort.Transformation.CommonBlockElim: type RenamerCoercer = Maybe (Map Name (Maybe Name, Maybe (BaseType, BaseType)))
+ Camfort.Transformation.DeadCode: deadCode' :: Bool -> InOutMap (Set Name) -> ProgramFile (Analysis A) -> (Report, ProgramFile (Analysis A))
+ Camfort.Transformation.DeadCode: perStmt :: Bool -> InOutMap (Set Name) -> Statement (Analysis A) -> (Report, Statement (Analysis A))
+ Camfort.Transformation.EquivalenceElim: addCopysPerBlock :: TypeEnv -> Block A1 -> State RmEqState [Block A1]
+ Camfort.Transformation.EquivalenceElim: addCopysPerBlockGroup :: TypeEnv -> [Block A1] -> State RmEqState [Block A1]
+ Camfort.Transformation.EquivalenceElim: equalTypes :: Eq b => Map Name b -> Expression a1 -> Expression a -> Maybe b
+ Camfort.Transformation.EquivalenceElim: equivalentsToExpr :: Expression A1 -> State RmEqState [Expression A1]
+ Camfort.Transformation.EquivalenceElim: mkCopy :: TypeEnv -> Position -> Expression A1 -> Expression A1 -> Block A1
+ Camfort.Transformation.EquivalenceElim: perBlockRmEquiv :: Block A1 -> State RmEqState (Block A1)
+ Camfort.Transformation.EquivalenceElim: perStatementRmEquiv :: Statement A1 -> State RmEqState (Statement A1)
+ Camfort.Transformation.EquivalenceElim: type A1 = Analysis Annotation
+ Camfort.Transformation.EquivalenceElim: type RmEqState = ([[Expression A1]], Int, Report)
- Camfort.Analysis.Annotations: A :: ([Access], [Access]) -> Int -> Int -> Maybe SrcLoc -> [Int] -> Bool -> Maybe (Either Specification (Either RegionEnv SpecDecls)) -> Maybe (Block (Analysis Annotation)) -> Annotation
+ Camfort.Analysis.Annotations: A :: Int -> Int -> Maybe Position -> Bool -> Bool -> Maybe (Either Specification (Either RegionEnv SpecDecls)) -> Maybe (Block (Analysis Annotation)) -> Annotation
- Camfort.Analysis.Annotations: [refactored] :: Annotation -> Maybe SrcLoc
+ Camfort.Analysis.Annotations: [refactored] :: Annotation -> Maybe Position
- Camfort.Functionality: stencilsSynth :: Data t => [Char] -> [Filename] -> FileOrDir -> [t] -> IO ()
+ Camfort.Functionality: stencilsSynth :: [Char] -> [Filename] -> FileOrDir -> [Flag] -> IO ()
- Camfort.Input: doAnalysisReport :: ([(Filename, Program A)] -> (String, t1)) -> FileOrDir -> [Filename] -> t -> IO ()
+ Camfort.Input: doAnalysisReport :: ([(Filename, ProgramFile A)] -> r) -> (r -> IO out) -> FileOrDir -> [Filename] -> IO out
- Camfort.Input: doAnalysisSummary :: (Monoid s, Show s) => (Program A -> s) -> FileOrDir -> [Filename] -> IO ()
+ Camfort.Input: doAnalysisSummary :: (Monoid s, Show' s) => (Filename -> ProgramFile A -> (s, ProgramFile A)) -> FileOrDir -> [Filename] -> Maybe FileOrDir -> IO ()
- Camfort.Input: doRefactor :: ([(Filename, Program A)] -> (String, [(Filename, Program Annotation)])) -> FileOrDir -> [Filename] -> FileOrDir -> IO String
+ Camfort.Input: doRefactor :: ([(Filename, ProgramFile A)] -> (String, [(Filename, ProgramFile A)])) -> FileOrDir -> [Filename] -> FileOrDir -> IO String
- Camfort.Input: readParseSrcDir :: FileOrDir -> [Filename] -> IO [(Filename, String, Program A)]
+ Camfort.Input: readParseSrcDir :: FileOrDir -> [Filename] -> IO [(Filename, SourceText, ProgramFile A)]
- Camfort.Input: readParseSrcFile :: Filename -> IO (Filename, String, Program A)
+ Camfort.Input: readParseSrcFile :: Filename -> IO (Filename, SourceText, ProgramFile A)
- Camfort.Output: class OutputFiles t where outputFiles inp outp pdata = do { outIsDir <- isDirectory outp; inIsDir <- isDirectory inp; inIsFile <- doesFileExist inp; if outIsDir then do { createDirectoryIfMissing True outp; putStrLn $ "Writing refactored files to directory: " ++ outp ++ "/"; isdir <- isDirectory inp; let inSrc = if isdir then inp else getDir inp; mapM_ (\ x -> let f' = changeDir outp inSrc (outputFile x) in do { checkDir f'; putStrLn $ "Writing " ++ f'; writeFile f' (mkOutputText outp x) }) pdata } else if inIsDir || length pdata > 1 then error $ "Error: attempting to output multiple files, but the given output destination is a single file. \n\ \Please specify an output directory" else if inIsFile then do { putStrLn $ "Writing refactored file to: " ++ outp; putStrLn $ "Writing " ++ outp; writeFile outp (mkOutputText outp (head pdata)) } else let outSrc = getDir outp in do { createDirectoryIfMissing True outSrc; putStrLn $ "Writing refactored file to: " ++ outp; putStrLn $ "Writing " ++ outp; writeFile outp (mkOutputText outp (head pdata)) } }
+ Camfort.Output: class OutputFiles t where outputFiles inp outp pdata = do { outIsDir <- isDirectory outp; inIsDir <- isDirectory inp; inIsFile <- doesFileExist inp; if outIsDir then do { createDirectoryIfMissing True outp; putStrLn $ "Writing refactored files to directory: " ++ outp ++ "/"; isdir <- isDirectory inp; let inSrc = if isdir then inp else getDir inp; forM_ pdata (\ x -> let f' = changeDir outp inSrc (outputFile x) in do { checkDir f'; putStrLn $ "Writing " ++ f'; writeFile f' (mkOutputText outp x) }) } else forM_ pdata (\ x -> do { let out = if isNewFile x then outputFile x else outp; putStrLn $ "Writing " ++ out; writeFile out (mkOutputText outp x) }) }
- Camfort.Reprint: enter :: Monad m => Refactoring m -> Zipper a -> SourceText -> StateT SrcLoc m SourceText
+ Camfort.Reprint: enter :: Monad m => Refactoring m -> Zipper a -> SourceText -> StateT Position m SourceText
- Camfort.Reprint: enterDown :: Monad m => Refactoring m -> Zipper a -> SourceText -> StateT SrcLoc m SourceText
+ Camfort.Reprint: enterDown :: Monad m => Refactoring m -> Zipper a -> SourceText -> StateT Position m SourceText
- Camfort.Reprint: enterRight :: Monad m => Refactoring m -> Zipper a -> SourceText -> StateT SrcLoc m SourceText
+ Camfort.Reprint: enterRight :: Monad m => Refactoring m -> Zipper a -> SourceText -> StateT Position m SourceText
- Camfort.Reprint: reprint :: (Monad m, Data p, PrettyPrint p) => Refactoring m -> p -> SourceText -> m SourceText
+ Camfort.Reprint: reprint :: (Monad m, Data p) => Refactoring m -> p -> SourceText -> m SourceText
- Camfort.Reprint: takeBounds :: (SrcLoc, SrcLoc) -> SourceText -> (SourceText, SourceText)
+ Camfort.Reprint: takeBounds :: (Position, Position) -> SourceText -> (SourceText, SourceText)
- 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.Reprint: type Refactoring m = forall b. Typeable b => b -> SourceText -> StateT SrcLoc m (SourceText, Refactored)
+ Camfort.Reprint: type Refactoring m = forall b. Typeable b => b -> SourceText -> StateT Position m (SourceText, Refactored)
- Camfort.Specification.Stencils: infer :: InferMode -> Filename -> ProgramFile Annotation -> (String, ProgramFile Annotation)
+ Camfort.Specification.Stencils: infer :: InferMode -> Char -> Filename -> ProgramFile Annotation -> (String, ProgramFile Annotation)
- Camfort.Specification.Stencils: synth :: InferMode -> [(Filename, ProgramFile A)] -> (String, [(Filename, ProgramFile Annotation)])
+ Camfort.Specification.Stencils: synth :: InferMode -> Char -> [(Filename, ProgramFile A)] -> (String, [(Filename, ProgramFile Annotation)])
- Camfort.Specification.Stencils.InferenceBackend: fromRegionsToSpec :: IsNatural n => [Span (Vec n Int)] -> Result Spatial
+ Camfort.Specification.Stencils.InferenceBackend: fromRegionsToSpec :: IsNatural n => [Span (Vec n Int)] -> Approximation Spatial
- Camfort.Specification.Stencils.InferenceBackend: simplify :: Result Spatial -> Result Spatial
+ Camfort.Specification.Stencils.InferenceBackend: simplify :: Approximation Spatial -> Approximation Spatial
- Camfort.Specification.Stencils.InferenceBackend: toSpec1D :: Dimension -> Int -> Int -> Result Spatial
+ Camfort.Specification.Stencils.InferenceBackend: toSpec1D :: Dimension -> Int -> Int -> Approximation Spatial
- Camfort.Specification.Stencils.InferenceBackend: toSpecND :: Span (Vec n Int) -> Result Spatial
+ Camfort.Specification.Stencils.InferenceBackend: toSpecND :: Span (Vec n Int) -> Approximation Spatial
- Camfort.Specification.Stencils.InferenceFrontend: perBlockInfer :: Params => InferMode -> Block (Analysis A) -> Inferer (Block (Analysis A))
+ Camfort.Specification.Stencils.InferenceFrontend: perBlockInfer :: Params => InferMode -> Char -> Block (Analysis A) -> Inferer (Block (Analysis A))
- Camfort.Specification.Stencils.InferenceFrontend: runInferer :: InductionVarMapByASTBlock -> Cycles -> ProgramUnitName -> Inferer a -> (a, [LogLine])
+ Camfort.Specification.Stencils.InferenceFrontend: runInferer :: InductionVarMapByASTBlock -> FlowsGraph A -> Inferer a -> (a, [LogLine])
- Camfort.Specification.Stencils.InferenceFrontend: stencilInference :: NameMap -> InferMode -> ProgramFile (Analysis A) -> (ProgramFile (Analysis A), [LogLine])
+ Camfort.Specification.Stencils.InferenceFrontend: stencilInference :: NameMap -> InferMode -> Char -> ProgramFile (Analysis A) -> (ProgramFile (Analysis A), [LogLine])
- Camfort.Specification.Stencils.InferenceFrontend: type Inferer = WriterT [LogLine] (ReaderT (Cycles, ProgramUnitName) (State InferState))
+ Camfort.Specification.Stencils.InferenceFrontend: type Inferer = WriterT [LogLine] (ReaderT (FlowsGraph A) (State InferState))
- Camfort.Specification.Stencils.Model: model :: Result Spatial -> Result (Multiset [Int])
+ Camfort.Specification.Stencils.Model: model :: Multiplicity (Approximation Spatial) -> Int -> Multiplicity (Approximation (Set [Int]))
- Camfort.Specification.Stencils.Syntax: Bound :: (Maybe a) -> (Maybe a) -> Result a
+ Camfort.Specification.Stencils.Syntax: Bound :: (Maybe a) -> (Maybe a) -> Approximation a
- Camfort.Specification.Stencils.Syntax: Exact :: a -> Result a
+ Camfort.Specification.Stencils.Syntax: Exact :: a -> Approximation a
- Camfort.Specification.Stencils.Syntax: Spatial :: Linearity -> RegionSum -> Spatial
+ Camfort.Specification.Stencils.Syntax: Spatial :: RegionSum -> Spatial
- Camfort.Specification.Stencils.Syntax: Specification :: (Either (Result Spatial) Temporal) -> Specification
+ Camfort.Specification.Stencils.Syntax: Specification :: (Multiplicity (Approximation Spatial)) -> Specification
- Camfort.Specification.Stencils.Syntax: fromExact :: Result a -> a
+ Camfort.Specification.Stencils.Syntax: fromExact :: Approximation a -> a
- Camfort.Specification.Stencils.Syntax: lowerBound :: a -> Result a
+ Camfort.Specification.Stencils.Syntax: lowerBound :: a -> Approximation 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.Stencils.Syntax: upperBound :: a -> Result a
+ Camfort.Specification.Stencils.Syntax: upperBound :: a -> Approximation a
- Camfort.Specification.Units: checkUnits :: UnitOpts -> (Filename, ProgramFile Annotation) -> (Report, (Filename, ProgramFile Annotation))
+ Camfort.Specification.Units: checkUnits :: UnitOpts -> (Filename, ProgramFile Annotation) -> Report
- Camfort.Specification.Units: inferCriticalVariables :: UnitOpts -> (Filename, ProgramFile Annotation) -> (Report, (Filename, ProgramFile Annotation))
+ Camfort.Specification.Units: inferCriticalVariables :: UnitOpts -> (Filename, ProgramFile Annotation) -> (Report, Int)
- Camfort.Specification.Units: inferUnits :: UnitOpts -> (Filename, ProgramFile Annotation) -> (Report, (Filename, ProgramFile Annotation))
+ Camfort.Specification.Units: inferUnits :: UnitOpts -> (Filename, ProgramFile Annotation) -> Report
- Camfort.Specification.Units: synthesiseUnits :: UnitOpts -> (Filename, ProgramFile Annotation) -> (Report, (Filename, ProgramFile Annotation))
+ Camfort.Specification.Units: synthesiseUnits :: UnitOpts -> Char -> (Filename, ProgramFile Annotation) -> (Report, (Filename, ProgramFile Annotation))
- Camfort.Specification.Units.Environment: UnitVar :: String -> UnitInfo
+ Camfort.Specification.Units.Environment: UnitVar :: VV -> UnitInfo
- Camfort.Specification.Units.InferenceBackend: inferVariables :: Constraints -> [(String, UnitInfo)]
+ Camfort.Specification.Units.InferenceBackend: inferVariables :: Constraints -> [(VV, UnitInfo)]
- Camfort.Specification.Units.InferenceFrontend: runInferVariables :: UnitSolver [(String, UnitInfo)]
+ Camfort.Specification.Units.InferenceFrontend: runInferVariables :: UnitSolver [(VV, UnitInfo)]
- Camfort.Specification.Units.Monad: type VarUnitMap = Map Name UnitInfo
+ Camfort.Specification.Units.Monad: type VarUnitMap = Map VV UnitInfo
- Camfort.Specification.Units.Synthesis: runSynthesis :: [(String, UnitInfo)] -> UnitSolver [(String, UnitInfo)]
+ Camfort.Specification.Units.Synthesis: runSynthesis :: Char -> [(VV, UnitInfo)] -> UnitSolver [(VV, UnitInfo)]
- Camfort.Transformation.CommonBlockElim: cmpTConBNames :: TCommon A -> TCommon A -> Ordering
+ Camfort.Transformation.CommonBlockElim: cmpTConBNames :: TCommon a -> TCommon a -> Ordering
- Camfort.Transformation.CommonBlockElim: cmpTLConBNames :: TLCommon A -> TLCommon A -> Ordering
+ Camfort.Transformation.CommonBlockElim: cmpTLConBNames :: TLCommon a -> TLCommon a -> Ordering
- Camfort.Transformation.CommonBlockElim: cmpTLConFName :: TLCommon A -> TLCommon A -> Ordering
+ Camfort.Transformation.CommonBlockElim: cmpTLConFName :: TLCommon a -> TLCommon a -> Ordering
- Camfort.Transformation.CommonBlockElim: cmpTLConPName :: TLCommon A -> TLCommon A -> Ordering
+ Camfort.Transformation.CommonBlockElim: cmpTLConPName :: TLCommon a -> TLCommon a -> Ordering
- Camfort.Transformation.CommonBlockElim: cmpVarName :: TLCommon A -> TLCommon A -> Ordering
+ Camfort.Transformation.CommonBlockElim: cmpVarName :: TLCommon a -> TLCommon a -> Ordering
- Camfort.Transformation.CommonBlockElim: commonElimToModules :: Directory -> [(Filename, Program A)] -> (Report, [(Filename, Program A)])
+ Camfort.Transformation.CommonBlockElim: commonElimToModules :: Directory -> [(Filename, ProgramFile A)] -> (Report, [(Filename, ProgramFile A)], [(Filename, ProgramFile A)])
- Camfort.Transformation.CommonBlockElim: introduceModules :: Directory -> [TLCommon A] -> (Report, [(Filename, Program A)])
+ Camfort.Transformation.CommonBlockElim: introduceModules :: MetaInfo -> Directory -> [TLCommon A] -> (Report, [(Filename, ProgramFile A)])
- Camfort.Transformation.CommonBlockElim: mkModule :: String -> [(Variable, Type A)] -> String -> ProgUnit A
+ Camfort.Transformation.CommonBlockElim: mkModule :: String -> [(Name, BaseType)] -> String -> ProgramUnit A
- Camfort.Transformation.CommonBlockElim: mkModuleFile :: Directory -> (TLCommon A) -> (Report, (Filename, Program A))
+ Camfort.Transformation.CommonBlockElim: mkModuleFile :: MetaInfo -> Directory -> TLCommon A -> (Report, (Filename, ProgramFile A))
- Camfort.Transformation.CommonBlockElim: renamerToUse :: RenamerCoercer -> [(Variable, Variable)]
+ Camfort.Transformation.CommonBlockElim: renamerToUse :: RenamerCoercer -> [(Name, Name)]
- Camfort.Transformation.CommonBlockElim: type TCommon p = (Maybe String, [(Variable, Type p)])
+ Camfort.Transformation.CommonBlockElim: type TCommon p = (Maybe Name, [(Name, BaseType)])
- Camfort.Transformation.CommonBlockElim: type TLCommon p = (Filename, (String, TCommon p))
+ Camfort.Transformation.CommonBlockElim: type TLCommon p = (Filename, (Name, TCommon p))
- Camfort.Transformation.CommonBlockElim: updateUseDecls :: [(Filename, Program A)] -> [TLCommon A] -> [(Filename, Program A)]
+ Camfort.Transformation.CommonBlockElim: updateUseDecls :: [(Filename, ProgramFile A)] -> [TLCommon A] -> [(Filename, ProgramFile A)]
- Camfort.Transformation.DeadCode: deadCode :: Bool -> (Filename, Program Annotation) -> (Report, (Filename, Program Annotation))
+ Camfort.Transformation.DeadCode: deadCode :: Bool -> (Filename, ProgramFile A) -> (Report, (Filename, ProgramFile A))
- Camfort.Transformation.EquivalenceElim: refactorEquivalences :: (Filename, Program Annotation) -> (Report, (Filename, Program Annotation))
+ Camfort.Transformation.EquivalenceElim: refactorEquivalences :: (Filename, ProgramFile A) -> (Report, (Filename, ProgramFile A))
Files
- camfort.cabal +12/−38
- dist/build/Camfort/Specification/Stencils/Grammar.hs +0/−883
- dist/build/Camfort/Specification/Units/Parser.hs +0/−759
- dist/build/Camfort/camfort-tmp/Camfort/Specification/Stencils/Grammar.hs +0/−883
- dist/build/Camfort/camfort-tmp/Camfort/Specification/Units/Parser.hs +0/−759
- src/Camfort/Analysis/Annotations.hs +22/−45
- src/Camfort/Analysis/CallGraph.hs +0/−36
- src/Camfort/Analysis/CommentAnnotator.hs +3/−3
- src/Camfort/Analysis/IntermediateReps.hs +0/−40
- src/Camfort/Analysis/LVA.hs +0/−113
- src/Camfort/Analysis/Syntax.hs +0/−393
- src/Camfort/Analysis/Types.hs +0/−109
- src/Camfort/Functionality.hs +57/−155
- src/Camfort/Helpers.hs +53/−10
- src/Camfort/Helpers/Syntax.hs +127/−0
- src/Camfort/Input.hs +101/−116
- src/Camfort/Output.hs +141/−191
- src/Camfort/PrettyPrint.hs +0/−315
- src/Camfort/Reprint.hs +40/−39
- src/Camfort/Specification/Stencils.hs +15/−12
- src/Camfort/Specification/Stencils/Annotation.hs +1/−1
- src/Camfort/Specification/Stencils/CheckBackend.hs +14/−11
- src/Camfort/Specification/Stencils/CheckFrontend.hs +43/−37
- src/Camfort/Specification/Stencils/Grammar.hs +0/−1131
- src/Camfort/Specification/Stencils/Grammar.y +53/−27
- src/Camfort/Specification/Stencils/InferenceBackend.hs +27/−27
- src/Camfort/Specification/Stencils/InferenceFrontend.hs +60/−57
- src/Camfort/Specification/Stencils/Model.hs +60/−70
- src/Camfort/Specification/Stencils/Syntax.hs +59/−108
- src/Camfort/Specification/Stencils/Synthesis.hs +2/−27
- src/Camfort/Specification/Units.hs +88/−53
- src/Camfort/Specification/Units/Environment.hs +16/−6
- src/Camfort/Specification/Units/InferenceBackend.hs +2/−2
- src/Camfort/Specification/Units/InferenceFrontend.hs +86/−38
- src/Camfort/Specification/Units/Monad.hs +6/−6
- src/Camfort/Specification/Units/Parser.y +3/−2
- src/Camfort/Specification/Units/Synthesis.hs +16/−21
- src/Camfort/Transformation/CommonBlockElim.hs +336/−225
- src/Camfort/Transformation/CommonBlockElimToCalls.hs +0/−178
- src/Camfort/Transformation/DeadCode.hs +58/−28
- src/Camfort/Transformation/DerivedTypeIntro.hs +0/−259
- src/Camfort/Transformation/EquivalenceElim.hs +125/−66
- src/Camfort/Transformation/Syntax.hs +0/−127
- src/Camfort/Traverse.hs +0/−183
- src/Main.hs +14/−14
- tests/Camfort/Analysis/CommentAnnotatorSpec.hs +2/−2
- tests/Camfort/Specification/Stencils/CheckSpec.hs +42/−66
- tests/Camfort/Specification/Stencils/GrammarSpec.hs +8/−3
- tests/Camfort/Specification/Stencils/ModelSpec.hs +123/−47
- tests/Camfort/Specification/Stencils/example2.f +45/−0
- tests/Camfort/Specification/Stencils/example3.f +31/−0
- tests/Camfort/Specification/Stencils/example4.f +8/−0
- tests/Camfort/Specification/StencilsSpec.hs +90/−102
- tests/Camfort/Specification/Units/ex1.f90 +29/−0
- tests/Camfort/Specification/Units/ex2.f90 +11/−0
- tests/Camfort/Specification/Units/ex3.f90 +14/−0
- tests/Camfort/Specification/Units/param.f90 +10/−0
- tests/Camfort/Specification/UnitsSpec.hs +159/−33
- tests/Camfort/Transformation/CommonSpec.hs +21/−18
- tests/Camfort/Transformation/EquivalenceElimSpec.hs +6/−8
- tests/Camfort/Transformation/samples/common.f90 +10/−0
- tests/Camfort/Transformation/samples/equiv.f90 +20/−0
camfort.cabal view
@@ -1,5 +1,5 @@ name: camfort-version: 0.804+version: 0.900 synopsis: CamFort - Cambridge Fortran infrastructure description: CamFort is a tool for the analysis, transformation, verification of Fortran code. @@ -12,11 +12,15 @@ stability: experimental build-type: Simple-category: Language, tools+category: Language cabal-version: >= 1.18 tested-with: GHC >= 7.8 +extra-source-files: tests/Camfort/Specification/Stencils/*.f+ tests/Camfort/Specification/Units/*.f90+ tests/Camfort/Transformation/samples/*.f90+ source-repository head type: git location: https://github.com/camfort/camfort@@ -25,13 +29,8 @@ main-is: Main.hs hs-source-dirs: src other-modules: Camfort.Analysis.Annotations- Camfort.Analysis.CallGraph Camfort.Analysis.CommentAnnotator- Camfort.Analysis.IntermediateReps- Camfort.Analysis.LVA Camfort.Analysis.Simple- Camfort.Analysis.Syntax- Camfort.Analysis.Types Camfort.Specification.Stencils.Annotation Camfort.Specification.Stencils.CheckBackend Camfort.Specification.Stencils.CheckFrontend@@ -50,30 +49,21 @@ Camfort.Specification.Units.Parser Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim- Camfort.Transformation.CommonBlockElimToCalls Camfort.Transformation.DeadCode- Camfort.Transformation.DerivedTypeIntro Camfort.Transformation.EquivalenceElim- Camfort.Transformation.Syntax Camfort.Helpers+ Camfort.Helpers.Syntax Camfort.Helpers.Vec Camfort.Functionality Camfort.Input Camfort.Output Camfort.Reprint- Camfort.PrettyPrint- Camfort.Traverse Main build-depends: base >= 4.6 && < 5, ghc-prim >= 0.3.1.0, containers >= 0.5.0.0,- template-haskell >=2.4,- generic-deriving >=1.5.5, uniplate >= 1.6.10,- comonad >= 3,- fclabels >= 2,- haskell-src >= 1.0.1, syz >= 0.2, syb >= 0.4, matrix >=0.2.2,@@ -83,11 +73,10 @@ text >= 0.11.2.3, array >= 0.4, directory >= 1.2,- language-fortran >= 0.5.1, transformers >= 0.4, GenericPretty >= 1.2, QuickCheck >= 2.8,- fortran-src >= 0.1.0.2,+ fortran-src >= 0.1.0.3, filepath, fgl >= 5.5, bytestring >= 0.10@@ -97,13 +86,8 @@ hs-source-dirs: src build-tools: alex, happy exposed-modules: Camfort.Analysis.Annotations- Camfort.Analysis.CallGraph Camfort.Analysis.CommentAnnotator- Camfort.Analysis.IntermediateReps- Camfort.Analysis.LVA Camfort.Analysis.Simple- Camfort.Analysis.Syntax- Camfort.Analysis.Types Camfort.Specification.Stencils.Annotation Camfort.Specification.Stencils.CheckBackend Camfort.Specification.Stencils.CheckFrontend@@ -122,29 +106,20 @@ Camfort.Specification.Units.Parser Camfort.Specification.Units.Synthesis Camfort.Transformation.CommonBlockElim- Camfort.Transformation.CommonBlockElimToCalls Camfort.Transformation.DeadCode- Camfort.Transformation.DerivedTypeIntro Camfort.Transformation.EquivalenceElim- Camfort.Transformation.Syntax Camfort.Helpers+ Camfort.Helpers.Syntax Camfort.Helpers.Vec Camfort.Functionality Camfort.Input Camfort.Output Camfort.Reprint- Camfort.PrettyPrint- Camfort.Traverse build-depends: base >= 4.6 && < 5, ghc-prim >= 0.3.1.0, containers >= 0.5.0.0,- template-haskell >=2.4,- generic-deriving >=1.5.5, uniplate >= 1.6.10,- comonad >= 3,- fclabels >= 2,- haskell-src >= 1.0.1, syz >= 0.2, syb >= 0.4, matrix >=0.2.2,@@ -153,11 +128,10 @@ text >= 0.11.2.3, array >= 0.4, directory >= 1.2,- language-fortran >= 0.5.1, transformers >= 0.4, vector >= 0.1, GenericPretty >= 1.2,- fortran-src >= 0.1.0.2,+ fortran-src >= 0.1.0.3, filepath, bytestring >= 0.10, fgl >= 5.5@@ -182,10 +156,10 @@ directory >= 1.2, hspec >= 2.2, QuickCheck >= 2.8,- fortran-src >= 0.1.0.2,+ fortran-src >= 0.1.0.3, uniplate >= 1.6.10, mtl >= 2.1,- bytestring >= 0.10, + bytestring >= 0.10, array >= 0.4, hmatrix >= 0.15, camfort
− dist/build/Camfort/Specification/Stencils/Grammar.hs
@@ -1,883 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}--- -*- Mode: Haskell -*--{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}-module Camfort.Specification.Stencils.Grammar-( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where--import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace)-import Data.List (intersect, sort, isPrefixOf)-import Data.Data--import Debug.Trace--import Camfort.Analysis.CommentAnnotator-import Camfort.Specification.Stencils.Syntax (showL)-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts-import Control.Applicative(Applicative(..))-import Control.Monad (ap)---- parser produced by Happy Version 1.19.5--newtype HappyAbsSyn = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = Happy_GHC_Exts.Any-#else-type HappyAny = forall a . a-#endif-happyIn4 :: (Specification) -> (HappyAbsSyn )-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn ) -> (Specification)-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-happyIn5 :: ((String, Region)) -> (HappyAbsSyn )-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn ) -> ((String, Region))-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: (Region) -> (HappyAbsSyn )-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn ) -> (Region)-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: (Bool) -> (HappyAbsSyn )-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn ) -> (Bool)-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: (Spec) -> (HappyAbsSyn )-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn ) -> (Spec)-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: (Mod) -> (HappyAbsSyn )-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn ) -> (Mod)-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyIn10 :: ([Mod]) -> (HappyAbsSyn )-happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn ) -> ([Mod])-happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut10 #-}-happyIn11 :: (Mod) -> (HappyAbsSyn )-happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn ) -> (Mod)-happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut11 #-}-happyIn12 :: ([String]) -> (HappyAbsSyn )-happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn12 #-}-happyOut12 :: (HappyAbsSyn ) -> ([String])-happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut12 #-}-happyInTok :: (Token) -> (HappyAbsSyn )-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn ) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x36\x00\x61\x00\x00\x00\x5d\x00\x5a\x00\xfe\xff\x23\x00\x5c\x00\x18\x00\x4b\x00\x0b\x00\x00\x00\x59\x00\x00\x00\x00\x00\x58\x00\x57\x00\x56\x00\x55\x00\x00\x00\x18\x00\x54\x00\x53\x00\x07\x00\x52\x00\x50\x00\x4f\x00\x4e\x00\x4c\x00\x23\x00\x00\x00\x2d\x00\x18\x00\x1f\x00\x51\x00\x18\x00\x18\x00\x00\x00\x4d\x00\x00\x00\x47\x00\x1f\x00\x4a\x00\x49\x00\x48\x00\x46\x00\x45\x00\x00\x00\x18\x00\x1f\x00\x44\x00\x43\x00\x41\x00\x40\x00\x3b\x00\x00\x00\x2e\x00\x42\x00\x3f\x00\x3e\x00\x00\x00\x3a\x00\x35\x00\x34\x00\x00\x00\x33\x00\x32\x00\x30\x00\x3d\x00\x3d\x00\x3d\x00\x29\x00\x00\x00\x28\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x2f\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x39\x00\x37\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x2b\x00\x00\x00\x1e\x00\x20\x00\x13\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x0a\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xec\xff\x00\x00\x00\x00\x00\x00\xe9\xff\xeb\xff\x00\x00\xe8\xff\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\xea\xff\xe9\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf7\xff\xfd\xff\xe5\xff\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xfc\xff\xf1\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\x00\x00\x00\x00\xf2\xff\xf2\xff\xf2\xff\x00\x00\xf3\xff\x00\x00\x00\x00\xf9\xff\xfa\xff\xfb\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x03\x00\x04\x00\x02\x00\x06\x00\x07\x00\x03\x00\x06\x00\x07\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x03\x00\x10\x00\x04\x00\x03\x00\x06\x00\x07\x00\x02\x00\x16\x00\x02\x00\x0b\x00\x0c\x00\x0d\x00\x12\x00\x13\x00\x10\x00\x04\x00\x08\x00\x17\x00\x06\x00\x07\x00\x16\x00\x02\x00\x0b\x00\x0c\x00\x0d\x00\x08\x00\x02\x00\x10\x00\x04\x00\x05\x00\x06\x00\x07\x00\x02\x00\x16\x00\x00\x00\x01\x00\x12\x00\x13\x00\x06\x00\x07\x00\x12\x00\x13\x00\x01\x00\x02\x00\x08\x00\x02\x00\x02\x00\x05\x00\x01\x00\x17\x00\x17\x00\x17\x00\x11\x00\x05\x00\x11\x00\x11\x00\x17\x00\xff\xff\x09\x00\x09\x00\x15\x00\x15\x00\x09\x00\x11\x00\xff\xff\x03\x00\x15\x00\xff\xff\x11\x00\x11\x00\x0f\x00\x11\x00\x09\x00\xff\xff\x10\x00\x0a\x00\x0a\x00\x0a\x00\x15\x00\x17\x00\x15\x00\x15\x00\x15\x00\x13\x00\x10\x00\x10\x00\x02\x00\x10\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x14\x00\x14\x00\xff\xff\x19\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x0c\x00\x0d\x00\x1d\x00\x0e\x00\x0f\x00\x47\x00\x1e\x00\x1f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x49\x00\x14\x00\x0d\x00\x4a\x00\x0e\x00\x0f\x00\x31\x00\x15\x00\x25\x00\x10\x00\x11\x00\x12\x00\x24\x00\x25\x00\x14\x00\x0d\x00\x37\x00\x30\x00\x1e\x00\x1f\x00\x15\x00\x26\x00\x10\x00\x11\x00\x12\x00\x27\x00\x06\x00\x14\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x29\x00\x15\x00\x04\x00\x02\x00\x24\x00\x25\x00\x0e\x00\x0f\x00\x24\x00\x25\x00\x06\x00\x04\x00\x2e\x00\x17\x00\x21\x00\x20\x00\x02\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x49\x00\x46\x00\x47\x00\x41\x00\x00\x00\x3e\x00\x3f\x00\x42\x00\x43\x00\x40\x00\x39\x00\x00\x00\x0c\x00\x44\x00\x00\x00\x3a\x00\x3b\x00\x3d\x00\x3c\x00\x2b\x00\x00\x00\x29\x00\x2c\x00\x2d\x00\x2e\x00\x34\x00\x33\x00\x35\x00\x36\x00\x37\x00\x25\x00\x29\x00\x29\x00\x04\x00\x17\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x23\x00\x16\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (1, 26) [- (1 , happyReduce_1),- (2 , happyReduce_2),- (3 , happyReduce_3),- (4 , happyReduce_4),- (5 , happyReduce_5),- (6 , happyReduce_6),- (7 , happyReduce_7),- (8 , happyReduce_8),- (9 , happyReduce_9),- (10 , happyReduce_10),- (11 , happyReduce_11),- (12 , happyReduce_12),- (13 , happyReduce_13),- (14 , happyReduce_14),- (15 , happyReduce_15),- (16 , happyReduce_16),- (17 , happyReduce_17),- (18 , happyReduce_18),- (19 , happyReduce_19),- (20 , happyReduce_20),- (21 , happyReduce_21),- (22 , happyReduce_22),- (23 , happyReduce_23),- (24 , happyReduce_24),- (25 , happyReduce_25),- (26 , happyReduce_26)- ]--happy_n_terms = 26 :: Int-happy_n_nonterms = 9 :: Int--happyReduce_1 = happySpecReduce_1 0# happyReduction_1-happyReduction_1 happy_x_1- = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4- (RegionDec (fst happy_var_1) (snd happy_var_1)- )}--happyReduce_2 = happyReduce 4# 0# happyReduction_2-happyReduction_2 (happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOut8 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn4- (SpecDec happy_var_2 happy_var_4- ) `HappyStk` happyRest}}--happyReduce_3 = happyReduce 5# 1# happyReduction_3-happyReduction_3 (happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut6 happy_x_5 of { happy_var_5 -> - happyIn5- ((happy_var_3, happy_var_5)- ) `HappyStk` happyRest}}--happyReduce_4 = happyReduce 10# 2# happyReduction_4-happyReduction_4 (happy_x_10 `HappyStk`- happy_x_9 `HappyStk`- happy_x_8 `HappyStk`- happy_x_7 `HappyStk`- happy_x_6 `HappyStk`- happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6- (Forward (read happy_var_5) (read happy_var_8) happy_var_9- ) `HappyStk` happyRest}}}--happyReduce_5 = happyReduce 10# 2# happyReduction_5-happyReduction_5 (happy_x_10 `HappyStk`- happy_x_9 `HappyStk`- happy_x_8 `HappyStk`- happy_x_7 `HappyStk`- happy_x_6 `HappyStk`- happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6- (Backward (read happy_var_5) (read happy_var_8) happy_var_9- ) `HappyStk` happyRest}}}--happyReduce_6 = happyReduce 10# 2# happyReduction_6-happyReduction_6 (happy_x_10 `HappyStk`- happy_x_9 `HappyStk`- happy_x_8 `HappyStk`- happy_x_7 `HappyStk`- happy_x_6 `HappyStk`- happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6- (Centered (read happy_var_5) (read happy_var_8) happy_var_9- ) `HappyStk` happyRest}}}--happyReduce_7 = happyReduce 6# 2# happyReduction_7-happyReduction_7 (happy_x_6 `HappyStk`- happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - happyIn6- (Centered 0 (read happy_var_5) True- ) `HappyStk` happyRest}--happyReduce_8 = happySpecReduce_3 2# happyReduction_8-happyReduction_8 happy_x_3- happy_x_2- happy_x_1- = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6- (Or happy_var_1 happy_var_3- )}}--happyReduce_9 = happySpecReduce_3 2# happyReduction_9-happyReduction_9 happy_x_3- happy_x_2- happy_x_1- = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6- (And happy_var_1 happy_var_3- )}}--happyReduce_10 = happySpecReduce_3 2# happyReduction_10-happyReduction_10 happy_x_3- happy_x_2- happy_x_1- = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6- (happy_var_2- )}--happyReduce_11 = happySpecReduce_1 2# happyReduction_11-happyReduction_11 happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6- (Var happy_var_1- )}--happyReduce_12 = happySpecReduce_1 3# happyReduction_12-happyReduction_12 happy_x_1- = happyIn7- (False- )--happyReduce_13 = happySpecReduce_0 3# happyReduction_13-happyReduction_13 = happyIn7- (True- )--happyReduce_14 = happyReduce 4# 4# happyReduction_14-happyReduction_14 (happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn8- (Temporal happy_var_3 False- ) `HappyStk` happyRest}--happyReduce_15 = happyReduce 5# 4# happyReduction_15-happyReduction_15 (happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn8- (Temporal happy_var_3 True- ) `HappyStk` happyRest}--happyReduce_16 = happySpecReduce_3 4# happyReduction_16-happyReduction_16 happy_x_3- happy_x_2- happy_x_1- = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn8- (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3- )}}}--happyReduce_17 = happySpecReduce_2 4# happyReduction_17-happyReduction_17 happy_x_2- happy_x_1- = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn8- (Spatial [happy_var_1] happy_var_2- )}}--happyReduce_18 = happySpecReduce_2 4# happyReduction_18-happyReduction_18 happy_x_2- happy_x_1- = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn8- (Spatial [happy_var_1] happy_var_2- )}}--happyReduce_19 = happySpecReduce_1 4# happyReduction_19-happyReduction_19 happy_x_1- = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn8- (Spatial [] happy_var_1- )}--happyReduce_20 = happySpecReduce_1 5# happyReduction_20-happyReduction_20 happy_x_1- = happyIn9- (ReadOnce- )--happyReduce_21 = happySpecReduce_2 6# happyReduction_21-happyReduction_21 happy_x_2- happy_x_1- = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn10- (happy_var_1 : happy_var_2- )}}--happyReduce_22 = happySpecReduce_1 6# happyReduction_22-happyReduction_22 happy_x_1- = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10- ([happy_var_1]- )}--happyReduce_23 = happySpecReduce_1 7# happyReduction_23-happyReduction_23 happy_x_1- = happyIn11- (AtMost- )--happyReduce_24 = happySpecReduce_1 7# happyReduction_24-happyReduction_24 happy_x_1- = happyIn11- (AtLeast- )--happyReduce_25 = happySpecReduce_2 8# happyReduction_25-happyReduction_25 happy_x_2- happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn12- (happy_var_1 : happy_var_2- )}}--happyReduce_26 = happySpecReduce_1 8# happyReduction_26-happyReduction_26 happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn12- ([happy_var_1]- )}--happyNewToken action sts stk [] =- happyDoAction 25# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =- let cont i = happyDoAction i tk action sts stk tks in- case tk of {- TId "stencil" -> cont 1#;- TId "region" -> cont 2#;- TId "readonce" -> cont 3#;- TId "reflexive" -> cont 4#;- TId "irreflexive" -> cont 5#;- TId "atmost" -> cont 6#;- TId "atleast" -> cont 7#;- TId "dims" -> cont 8#;- TId "dim" -> cont 9#;- TId "depth" -> cont 10#;- TId "forward" -> cont 11#;- TId "backward" -> cont 12#;- TId "centered" -> cont 13#;- TId "dependency" -> cont 14#;- TId "mutual" -> cont 15#;- TId happy_dollar_dollar -> cont 16#;- TNum happy_dollar_dollar -> cont 17#;- TPlus -> cont 18#;- TStar -> cont 19#;- TDoubleColon -> cont 20#;- TEqual -> cont 21#;- TLParen -> cont 22#;- TRParen -> cont 23#;- TComma -> cont 24#;- _ -> happyError' (tk:tks)- }--happyError_ 25# tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)--happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b-happyThen = (>>=)-happyReturn :: () => a -> Either AnnotationParseError a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> Either AnnotationParseError a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> Either AnnotationParseError a-happyError' = happyError--parseSpec tks = happySomeParser where- happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))--happySeq = happyDontSeq---data Specification- = RegionDec String Region- | SpecDec Spec [String]- deriving (Show, Eq, Ord, Typeable, Data)--data Region- = Forward Int Int Bool- | Backward Int Int Bool- | Centered Int Int Bool- | Or Region Region- | And Region Region- | Var String- deriving (Show, Eq, Ord, Typeable, Data)--data Spec- = Spatial [Mod] Region- | Temporal [String] Bool- deriving (Show, Eq, Ord, Typeable, Data)--data Mod- = AtLeast- | AtMost- | ReadOnce- deriving (Show, Eq, Ord, Typeable, Data)------------------------------------------------------data Token- = TDoubleColon- | TStar- | TPlus- | TEqual- | TComma- | TLParen- | TRParen- | TId String- | TNum String- deriving (Show)--addToTokens :: Token -> String -> Either AnnotationParseError [ Token ]-addToTokens tok rest = do- tokens <- lexer' rest- return $ tok : tokens--stripLeadingWhiteSpace (' ':xs) = stripLeadingWhiteSpace xs-stripLeadingWhiteSpace ('\t':xs) = stripLeadingWhiteSpace xs-stripLeadingWhiteSpace ('\n':xs) = stripLeadingWhiteSpace xs-stripLeadingWhiteSpace xs = xs---lexer :: String -> Either AnnotationParseError [ Token ]-lexer input | length (stripLeadingWhiteSpace input) >= 2 =- case stripLeadingWhiteSpace input of- -- Check the leading character is '=' for specification- '=':input' ->- -- First test to see if the input looks like an actual- -- specification of either a stencil or region- if (input' `hasPrefix` "stencil" || input' `hasPrefix` "region")- then lexer' input'- else Left NotAnnotation- _ -> Left NotAnnotation- where- hasPrefix [] str = False- hasPrefix (' ':xs) str = hasPrefix xs str- hasPrefix xs str = isPrefixOf str xs-lexer _ = Left NotAnnotation---lexer' :: String -> Either AnnotationParseError [ Token ]-lexer' [] = return []-lexer' (' ':xs) = lexer' xs-lexer' ('\t':xs) = lexer' xs-lexer' (':':':':xs) = addToTokens TDoubleColon xs-lexer' ('*':xs) = addToTokens TStar xs-lexer' ('+':xs) = addToTokens TPlus xs-lexer' ('=':xs) = addToTokens TEqual xs--- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead.-lexer' (',':xs)- | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs')- | otherwise = addToTokens TComma xs-lexer' ('(':xs) = addToTokens TLParen xs-lexer' (')':xs) = addToTokens TRParen xs-lexer' (x:xs)- | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_'- | isNumber x = aux TNum isNumber- | otherwise- = failWith $ "Not an indentifier " ++ show x- where- aux f p = (f target :) `fmap` lexer' rest- where (target, rest) = span p (x:xs)-lexer' x- = failWith $ "Not a valid piece of stencil syntax " ++ show x-------------------------------------------------------- specParser :: String -> Either AnnotationParseError Specification-specParser :: AnnotationParser Specification-specParser src = do- tokens <- lexer src- parseSpec tokens >>= modValidate---- Check whether modifiers are used correctly-modValidate :: Specification -> Either AnnotationParseError Specification-modValidate (SpecDec (Spatial mods r) vars) =- do mods' <- modValidate' $ sort mods- return $ SpecDec (Spatial mods' r) vars-- where modValidate' [] = return $ []-- modValidate' (AtLeast : AtLeast : xs)- = failWith "Duplicate 'atLeast' modifier; use at most one."-- modValidate' (AtMost : AtMost : xs)- = failWith "Duplicate 'atMost' modifier; use at most one."-- modValidate' (ReadOnce : ReadOnce : xs)- = failWith "Duplicate 'readOnce' modifier; use at most one."-- modValidate' (AtLeast : AtMost : xs)- = failWith $ "Conflicting modifiers: cannot use 'atLeast' and "- ++ "'atMost' together"-- modValidate' (x : xs)- = do xs' <- modValidate' xs- return $ x : xs'-modValidate x = return x--happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = failWith $ "Could not parse specification at: " ++ show t-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<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,759 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}--- -*- Mode: Haskell -*---{-# LANGUAGE DeriveDataTypeable #-}-module Camfort.Specification.Units.Parser ( unitParser- , UnitStatement(..)- , UnitOfMeasure(..)- , UnitPower(..)- ) where--import Camfort.Analysis.CommentAnnotator-import Data.Data-import Data.List-import Data.Char (isLetter, isNumber, isAlphaNum, toLower)-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts-import Control.Applicative(Applicative(..))-import Control.Monad (ap)---- parser produced by Happy Version 1.19.5--newtype HappyAbsSyn = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = Happy_GHC_Exts.Any-#else-type HappyAny = forall a . a-#endif-happyIn4 :: (UnitStatement) -> (HappyAbsSyn )-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn ) -> (UnitStatement)-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-happyIn5 :: (Maybe [String]) -> (HappyAbsSyn )-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn ) -> (Maybe [String])-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: ([String]) -> (HappyAbsSyn )-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn ) -> ([String])-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: (UnitOfMeasure) -> (HappyAbsSyn )-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn ) -> (UnitOfMeasure)-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: (UnitOfMeasure) -> (HappyAbsSyn )-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn ) -> (UnitOfMeasure)-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: (UnitOfMeasure) -> (HappyAbsSyn )-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn ) -> (UnitOfMeasure)-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyIn10 :: (UnitPower) -> (HappyAbsSyn )-happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn ) -> (UnitPower)-happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut10 #-}-happyIn11 :: (Integer) -> (HappyAbsSyn )-happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn ) -> (Integer)-happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut11 #-}-happyIn12 :: (String) -> (HappyAbsSyn )-happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn12 #-}-happyOut12 :: (HappyAbsSyn ) -> (String)-happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut12 #-}-happyInTok :: (Token) -> (HappyAbsSyn )-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn ) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x44\x00\x41\x00\x0f\x00\x3c\x00\x05\x00\x2b\x00\x04\x00\x3d\x00\x00\x00\x00\x00\x3f\x00\xff\xff\x3b\x00\x01\x00\x34\x00\x00\x00\x35\x00\x10\x00\x36\x00\x0f\x00\x00\x00\x04\x00\x3a\x00\x00\x00\x39\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x19\x00\x0f\x00\x00\x00\x00\x00\x33\x00\xfd\xff\x00\x00\x38\x00\x00\x00\x19\x00\x00\x00\x2c\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x37\x00\x00\x00\x27\x00\x00\x00\x27\x00\x22\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1d\x00\x00\x00\x30\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x28\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xf8\xff\xf2\xff\xef\xff\xf7\xff\x00\x00\x00\x00\x00\x00\xf8\xff\xf7\xff\xf5\xff\x00\x00\x00\x00\xf4\xff\x00\x00\xfe\xff\x00\x00\x00\x00\xfc\xff\xf9\xff\xf3\xff\xf1\xff\xee\xff\xeb\xff\xe8\xff\xe9\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf0\xff\xfd\xff\x00\x00\xea\xff\x00\x00\xfa\xff\x00\x00\xed\xff\x00\x00\xec\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x02\x00\x02\x00\x08\x00\x02\x00\x02\x00\x03\x00\x0c\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x09\x00\x0b\x00\x0b\x00\x02\x00\x03\x00\x03\x00\x04\x00\x08\x00\x06\x00\x03\x00\x04\x00\x05\x00\x0b\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x06\x00\x03\x00\x04\x00\x05\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x07\x00\x08\x00\x07\x00\x08\x00\x03\x00\x04\x00\x08\x00\x09\x00\x05\x00\x05\x00\x00\x00\x0c\x00\x07\x00\x02\x00\x08\x00\x02\x00\x07\x00\x05\x00\x0a\x00\x0c\x00\x02\x00\x01\x00\x08\x00\x07\x00\x01\x00\xff\xff\xff\xff\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x09\x00\x0f\x00\x09\x00\x28\x00\x2a\x00\x09\x00\x09\x00\x0a\x00\x2b\x00\x0c\x00\x10\x00\x14\x00\x24\x00\x0b\x00\x14\x00\x0c\x00\x09\x00\x0a\x00\x1e\x00\x1f\x00\x26\x00\x20\x00\x24\x00\x06\x00\x07\x00\x0c\x00\x21\x00\x1e\x00\x1f\x00\x17\x00\x20\x00\x0c\x00\x0d\x00\x07\x00\x14\x00\x1a\x00\x1b\x00\x1c\x00\x0c\x00\x0d\x00\x07\x00\x05\x00\x06\x00\x07\x00\x2b\x00\x1c\x00\x25\x00\x1c\x00\x1e\x00\x1f\x00\x16\x00\x17\x00\x19\x00\x12\x00\x03\x00\x2d\x00\x12\x00\x19\x00\x16\x00\x19\x00\x12\x00\x28\x00\x22\x00\x23\x00\x11\x00\x03\x00\x16\x00\x12\x00\x05\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (1, 23) [- (1 , happyReduce_1),- (2 , happyReduce_2),- (3 , happyReduce_3),- (4 , happyReduce_4),- (5 , happyReduce_5),- (6 , happyReduce_6),- (7 , happyReduce_7),- (8 , happyReduce_8),- (9 , happyReduce_9),- (10 , happyReduce_10),- (11 , happyReduce_11),- (12 , happyReduce_12),- (13 , happyReduce_13),- (14 , happyReduce_14),- (15 , happyReduce_15),- (16 , happyReduce_16),- (17 , happyReduce_17),- (18 , happyReduce_18),- (19 , happyReduce_19),- (20 , happyReduce_20),- (21 , happyReduce_21),- (22 , happyReduce_22),- (23 , happyReduce_23)- ]--happy_n_terms = 14 :: Int-happy_n_nonterms = 9 :: Int--happyReduce_1 = happySpecReduce_3 0# happyReduction_1-happyReduction_1 happy_x_3- happy_x_2- happy_x_1- = case happyOut7 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_3 of { happy_var_3 -> - happyIn4- (UnitAssignment happy_var_3 happy_var_2- )}}--happyReduce_2 = happyReduce 5# 0# happyReduction_2-happyReduction_2 (happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut7 happy_x_5 of { happy_var_5 -> - happyIn4- (UnitAlias happy_var_3 happy_var_5- ) `HappyStk` happyRest}}--happyReduce_3 = happySpecReduce_2 1# happyReduction_3-happyReduction_3 happy_x_2- happy_x_1- = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn5- (Just happy_var_2- )}--happyReduce_4 = happySpecReduce_0 1# happyReduction_4-happyReduction_4 = happyIn5- (Nothing- )--happyReduce_5 = happySpecReduce_3 2# happyReduction_5-happyReduction_5 happy_x_3- happy_x_2- happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6- (happy_var_1 : happy_var_3- )}}--happyReduce_6 = happySpecReduce_1 2# happyReduction_6-happyReduction_6 happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6- ([happy_var_1]- )}--happyReduce_7 = happySpecReduce_1 3# happyReduction_7-happyReduction_7 happy_x_1- = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7- (happy_var_1- )}--happyReduce_8 = happySpecReduce_1 3# happyReduction_8-happyReduction_8 happy_x_1- = happyIn7- (Unitless- )--happyReduce_9 = happySpecReduce_3 3# happyReduction_9-happyReduction_9 happy_x_3- happy_x_2- happy_x_1- = happyIn7- (Unitless- )--happyReduce_10 = happySpecReduce_2 3# happyReduction_10-happyReduction_10 happy_x_2- happy_x_1- = happyIn7- (Unitless- )--happyReduce_11 = happySpecReduce_2 4# happyReduction_11-happyReduction_11 happy_x_2- happy_x_1- = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn8- (UnitProduct happy_var_1 happy_var_2- )}}--happyReduce_12 = happySpecReduce_3 4# happyReduction_12-happyReduction_12 happy_x_3- happy_x_2- happy_x_1- = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_3 of { happy_var_3 -> - happyIn8- (UnitQuotient happy_var_1 happy_var_3- )}}--happyReduce_13 = happySpecReduce_1 4# happyReduction_13-happyReduction_13 happy_x_1- = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn8- (happy_var_1- )}--happyReduce_14 = happySpecReduce_3 5# happyReduction_14-happyReduction_14 happy_x_3- happy_x_2- happy_x_1- = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn9- (UnitExponentiation happy_var_1 happy_var_3- )}}--happyReduce_15 = happySpecReduce_3 5# happyReduction_15-happyReduction_15 happy_x_3- happy_x_2- happy_x_1- = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn9- (happy_var_2- )}--happyReduce_16 = happySpecReduce_1 5# happyReduction_16-happyReduction_16 happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn9- (UnitBasic happy_var_1- )}--happyReduce_17 = happySpecReduce_1 6# happyReduction_17-happyReduction_17 happy_x_1- = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10- (UnitPowerInteger happy_var_1- )}--happyReduce_18 = happySpecReduce_3 6# happyReduction_18-happyReduction_18 happy_x_3- happy_x_2- happy_x_1- = case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn10- (UnitPowerInteger happy_var_2- )}--happyReduce_19 = happyReduce 5# 6# happyReduction_19-happyReduction_19 (happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOut11 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_4 of { happy_var_4 -> - happyIn10- (UnitPowerRational happy_var_2 happy_var_4- ) `HappyStk` happyRest}}--happyReduce_20 = happySpecReduce_1 7# happyReduction_20-happyReduction_20 happy_x_1- = case happyOut12 happy_x_1 of { happy_var_1 -> - happyIn11- (read happy_var_1- )}--happyReduce_21 = happySpecReduce_2 7# happyReduction_21-happyReduction_21 happy_x_2- happy_x_1- = case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn11- (read $ '-' : happy_var_2- )}--happyReduce_22 = happySpecReduce_1 8# happyReduction_22-happyReduction_22 happy_x_1- = case happyOutTok happy_x_1 of { (TNum happy_var_1) -> - happyIn12- (happy_var_1- )}--happyReduce_23 = happySpecReduce_1 8# happyReduction_23-happyReduction_23 happy_x_1- = happyIn12- ("1"- )--happyNewToken action sts stk [] =- happyDoAction 13# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =- let cont i = happyDoAction i tk action sts stk tks in- case tk of {- TId "unit" -> cont 1#;- TId happy_dollar_dollar -> cont 2#;- TNum "1" -> cont 3#;- TNum happy_dollar_dollar -> cont 4#;- TComma -> cont 5#;- TMinus -> cont 6#;- TExponentiation -> cont 7#;- TDivision -> cont 8#;- TDoubleColon -> cont 9#;- TEqual -> cont 10#;- TLeftPar -> cont 11#;- TRightPar -> cont 12#;- _ -> happyError' (tk:tks)- }--happyError_ 13# tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)--happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b-happyThen = (>>=)-happyReturn :: () => a -> Either AnnotationParseError a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> Either AnnotationParseError a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> Either AnnotationParseError a-happyError' = happyError--parseUnit tks = happySomeParser where- happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))--happySeq = happyDontSeq---data UnitStatement =- UnitAssignment (Maybe [String]) UnitOfMeasure- | UnitAlias String UnitOfMeasure- deriving Data--instance Show UnitStatement where- show (UnitAssignment (Just ss) uom) = "= unit (" ++ show uom ++ ") :: " ++ (intercalate "," ss)- show (UnitAssignment Nothing uom) = "= unit (" ++ show uom ++ ")"- show (UnitAlias s uom) = "= unit :: " ++ s ++ " = " ++ show uom--data UnitOfMeasure =- Unitless- | UnitBasic String- | UnitProduct UnitOfMeasure UnitOfMeasure- | UnitQuotient UnitOfMeasure UnitOfMeasure- | UnitExponentiation UnitOfMeasure UnitPower- deriving Data--instance Show UnitOfMeasure where- show Unitless = "1"- show (UnitBasic s) = s- show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2- show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2- show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")"--data UnitPower =- UnitPowerInteger Integer- | UnitPowerRational Integer Integer- deriving Data--instance Show UnitPower where- show (UnitPowerInteger i) = show i- show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2--data Token =- TUnit- | TComma- | TDoubleColon- | TExponentiation- | TDivision- | TMinus- | TEqual- | TLeftPar- | TRightPar- | TId String- | TNum String- deriving (Show)--lexer :: String -> Either AnnotationParseError [ Token ]-lexer ('=':xs) = lexer' xs-lexer _ = Left NotAnnotation--addToTokens :: Token -> String -> Either AnnotationParseError [ Token ]-addToTokens tok rest = do- tokens <- lexer' rest- return $ tok : tokens--lexer' :: String -> Either AnnotationParseError [ Token ]-lexer' [] = Right []-lexer' ['\n'] = Right []-lexer' ['\r', '\n'] = Right []-lexer' ['\r'] = Right [] -- windows-lexer' (' ':xs) = lexer' xs-lexer' ('\t':xs) = lexer' xs-lexer' (':':':':xs) = addToTokens TDoubleColon xs-lexer' ('*':'*':xs) = addToTokens TExponentiation xs-lexer' (',':xs) = addToTokens TComma xs-lexer' ('/':xs) = addToTokens TDivision xs-lexer' ('-':xs) = addToTokens TMinus xs-lexer' ('=':xs) = addToTokens TEqual xs-lexer' ('(':xs) = addToTokens TLeftPar xs-lexer' (')':xs) = addToTokens TRightPar xs-lexer' (x:xs)- | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId- | isNumber x = aux isNumber TNum- | otherwise = Left NotAnnotation -- failWith $ "Not valid unit syntax at " ++ show (x:xs)- where- aux p cons =- let (target, rest) = span p xs- in lexer' rest >>= (\tokens -> return $ cons (x:target) : tokens)--unitParser :: String -> Either AnnotationParseError UnitStatement-unitParser src = do- tokens <- lexer $ map toLower src- parseUnit tokens--happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = Left NotAnnotation -- failWith $ "Could not parse specification at: " ++ show t-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<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,883 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}--- -*- Mode: Haskell -*--{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}-module Camfort.Specification.Stencils.Grammar-( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where--import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace)-import Data.List (intersect, sort, isPrefixOf)-import Data.Data--import Debug.Trace--import Camfort.Analysis.CommentAnnotator-import Camfort.Specification.Stencils.Syntax (showL)-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts-import Control.Applicative(Applicative(..))-import Control.Monad (ap)---- parser produced by Happy Version 1.19.5--newtype HappyAbsSyn = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = Happy_GHC_Exts.Any-#else-type HappyAny = forall a . a-#endif-happyIn4 :: (Specification) -> (HappyAbsSyn )-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn ) -> (Specification)-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-happyIn5 :: ((String, Region)) -> (HappyAbsSyn )-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn ) -> ((String, Region))-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: (Region) -> (HappyAbsSyn )-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn ) -> (Region)-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: (Bool) -> (HappyAbsSyn )-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn ) -> (Bool)-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: (Spec) -> (HappyAbsSyn )-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn ) -> (Spec)-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: (Mod) -> (HappyAbsSyn )-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn ) -> (Mod)-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyIn10 :: ([Mod]) -> (HappyAbsSyn )-happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn ) -> ([Mod])-happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut10 #-}-happyIn11 :: (Mod) -> (HappyAbsSyn )-happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn ) -> (Mod)-happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut11 #-}-happyIn12 :: ([String]) -> (HappyAbsSyn )-happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn12 #-}-happyOut12 :: (HappyAbsSyn ) -> ([String])-happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut12 #-}-happyInTok :: (Token) -> (HappyAbsSyn )-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn ) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x36\x00\x61\x00\x00\x00\x5d\x00\x5a\x00\xfe\xff\x23\x00\x5c\x00\x18\x00\x4b\x00\x0b\x00\x00\x00\x59\x00\x00\x00\x00\x00\x58\x00\x57\x00\x56\x00\x55\x00\x00\x00\x18\x00\x54\x00\x53\x00\x07\x00\x52\x00\x50\x00\x4f\x00\x4e\x00\x4c\x00\x23\x00\x00\x00\x2d\x00\x18\x00\x1f\x00\x51\x00\x18\x00\x18\x00\x00\x00\x4d\x00\x00\x00\x47\x00\x1f\x00\x4a\x00\x49\x00\x48\x00\x46\x00\x45\x00\x00\x00\x18\x00\x1f\x00\x44\x00\x43\x00\x41\x00\x40\x00\x3b\x00\x00\x00\x2e\x00\x42\x00\x3f\x00\x3e\x00\x00\x00\x3a\x00\x35\x00\x34\x00\x00\x00\x33\x00\x32\x00\x30\x00\x3d\x00\x3d\x00\x3d\x00\x29\x00\x00\x00\x28\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x2f\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x39\x00\x37\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x2b\x00\x00\x00\x1e\x00\x20\x00\x13\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x0a\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xec\xff\x00\x00\x00\x00\x00\x00\xe9\xff\xeb\xff\x00\x00\xe8\xff\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\xea\xff\xe9\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf7\xff\xfd\xff\xe5\xff\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\xfc\xff\xf1\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\x00\x00\x00\x00\x00\x00\xf8\xff\x00\x00\x00\x00\x00\x00\xf2\xff\xf2\xff\xf2\xff\x00\x00\xf3\xff\x00\x00\x00\x00\xf9\xff\xfa\xff\xfb\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x03\x00\x04\x00\x02\x00\x06\x00\x07\x00\x03\x00\x06\x00\x07\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x03\x00\x10\x00\x04\x00\x03\x00\x06\x00\x07\x00\x02\x00\x16\x00\x02\x00\x0b\x00\x0c\x00\x0d\x00\x12\x00\x13\x00\x10\x00\x04\x00\x08\x00\x17\x00\x06\x00\x07\x00\x16\x00\x02\x00\x0b\x00\x0c\x00\x0d\x00\x08\x00\x02\x00\x10\x00\x04\x00\x05\x00\x06\x00\x07\x00\x02\x00\x16\x00\x00\x00\x01\x00\x12\x00\x13\x00\x06\x00\x07\x00\x12\x00\x13\x00\x01\x00\x02\x00\x08\x00\x02\x00\x02\x00\x05\x00\x01\x00\x17\x00\x17\x00\x17\x00\x11\x00\x05\x00\x11\x00\x11\x00\x17\x00\xff\xff\x09\x00\x09\x00\x15\x00\x15\x00\x09\x00\x11\x00\xff\xff\x03\x00\x15\x00\xff\xff\x11\x00\x11\x00\x0f\x00\x11\x00\x09\x00\xff\xff\x10\x00\x0a\x00\x0a\x00\x0a\x00\x15\x00\x17\x00\x15\x00\x15\x00\x15\x00\x13\x00\x10\x00\x10\x00\x02\x00\x10\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x14\x00\x14\x00\xff\xff\x19\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x0c\x00\x0d\x00\x1d\x00\x0e\x00\x0f\x00\x47\x00\x1e\x00\x1f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x49\x00\x14\x00\x0d\x00\x4a\x00\x0e\x00\x0f\x00\x31\x00\x15\x00\x25\x00\x10\x00\x11\x00\x12\x00\x24\x00\x25\x00\x14\x00\x0d\x00\x37\x00\x30\x00\x1e\x00\x1f\x00\x15\x00\x26\x00\x10\x00\x11\x00\x12\x00\x27\x00\x06\x00\x14\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x29\x00\x15\x00\x04\x00\x02\x00\x24\x00\x25\x00\x0e\x00\x0f\x00\x24\x00\x25\x00\x06\x00\x04\x00\x2e\x00\x17\x00\x21\x00\x20\x00\x02\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x49\x00\x46\x00\x47\x00\x41\x00\x00\x00\x3e\x00\x3f\x00\x42\x00\x43\x00\x40\x00\x39\x00\x00\x00\x0c\x00\x44\x00\x00\x00\x3a\x00\x3b\x00\x3d\x00\x3c\x00\x2b\x00\x00\x00\x29\x00\x2c\x00\x2d\x00\x2e\x00\x34\x00\x33\x00\x35\x00\x36\x00\x37\x00\x25\x00\x29\x00\x29\x00\x04\x00\x17\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x23\x00\x16\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (1, 26) [- (1 , happyReduce_1),- (2 , happyReduce_2),- (3 , happyReduce_3),- (4 , happyReduce_4),- (5 , happyReduce_5),- (6 , happyReduce_6),- (7 , happyReduce_7),- (8 , happyReduce_8),- (9 , happyReduce_9),- (10 , happyReduce_10),- (11 , happyReduce_11),- (12 , happyReduce_12),- (13 , happyReduce_13),- (14 , happyReduce_14),- (15 , happyReduce_15),- (16 , happyReduce_16),- (17 , happyReduce_17),- (18 , happyReduce_18),- (19 , happyReduce_19),- (20 , happyReduce_20),- (21 , happyReduce_21),- (22 , happyReduce_22),- (23 , happyReduce_23),- (24 , happyReduce_24),- (25 , happyReduce_25),- (26 , happyReduce_26)- ]--happy_n_terms = 26 :: Int-happy_n_nonterms = 9 :: Int--happyReduce_1 = happySpecReduce_1 0# happyReduction_1-happyReduction_1 happy_x_1- = case happyOut5 happy_x_1 of { happy_var_1 -> - happyIn4- (RegionDec (fst happy_var_1) (snd happy_var_1)- )}--happyReduce_2 = happyReduce 4# 0# happyReduction_2-happyReduction_2 (happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOut8 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn4- (SpecDec happy_var_2 happy_var_4- ) `HappyStk` happyRest}}--happyReduce_3 = happyReduce 5# 1# happyReduction_3-happyReduction_3 (happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut6 happy_x_5 of { happy_var_5 -> - happyIn5- ((happy_var_3, happy_var_5)- ) `HappyStk` happyRest}}--happyReduce_4 = happyReduce 10# 2# happyReduction_4-happyReduction_4 (happy_x_10 `HappyStk`- happy_x_9 `HappyStk`- happy_x_8 `HappyStk`- happy_x_7 `HappyStk`- happy_x_6 `HappyStk`- happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6- (Forward (read happy_var_5) (read happy_var_8) happy_var_9- ) `HappyStk` happyRest}}}--happyReduce_5 = happyReduce 10# 2# happyReduction_5-happyReduction_5 (happy_x_10 `HappyStk`- happy_x_9 `HappyStk`- happy_x_8 `HappyStk`- happy_x_7 `HappyStk`- happy_x_6 `HappyStk`- happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6- (Backward (read happy_var_5) (read happy_var_8) happy_var_9- ) `HappyStk` happyRest}}}--happyReduce_6 = happyReduce 10# 2# happyReduction_6-happyReduction_6 (happy_x_10 `HappyStk`- happy_x_9 `HappyStk`- happy_x_8 `HappyStk`- happy_x_7 `HappyStk`- happy_x_6 `HappyStk`- happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - case happyOutTok happy_x_8 of { (TNum happy_var_8) -> - case happyOut7 happy_x_9 of { happy_var_9 -> - happyIn6- (Centered (read happy_var_5) (read happy_var_8) happy_var_9- ) `HappyStk` happyRest}}}--happyReduce_7 = happyReduce 6# 2# happyReduction_7-happyReduction_7 (happy_x_6 `HappyStk`- happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_5 of { (TNum happy_var_5) -> - happyIn6- (Centered 0 (read happy_var_5) True- ) `HappyStk` happyRest}--happyReduce_8 = happySpecReduce_3 2# happyReduction_8-happyReduction_8 happy_x_3- happy_x_2- happy_x_1- = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6- (Or happy_var_1 happy_var_3- )}}--happyReduce_9 = happySpecReduce_3 2# happyReduction_9-happyReduction_9 happy_x_3- happy_x_2- happy_x_1- = case happyOut6 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6- (And happy_var_1 happy_var_3- )}}--happyReduce_10 = happySpecReduce_3 2# happyReduction_10-happyReduction_10 happy_x_3- happy_x_2- happy_x_1- = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn6- (happy_var_2- )}--happyReduce_11 = happySpecReduce_1 2# happyReduction_11-happyReduction_11 happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6- (Var happy_var_1- )}--happyReduce_12 = happySpecReduce_1 3# happyReduction_12-happyReduction_12 happy_x_1- = happyIn7- (False- )--happyReduce_13 = happySpecReduce_0 3# happyReduction_13-happyReduction_13 = happyIn7- (True- )--happyReduce_14 = happyReduce 4# 4# happyReduction_14-happyReduction_14 (happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn8- (Temporal happy_var_3 False- ) `HappyStk` happyRest}--happyReduce_15 = happyReduce 5# 4# happyReduction_15-happyReduction_15 (happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn8- (Temporal happy_var_3 True- ) `HappyStk` happyRest}--happyReduce_16 = happySpecReduce_3 4# happyReduction_16-happyReduction_16 happy_x_3- happy_x_2- happy_x_1- = case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn8- (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3- )}}}--happyReduce_17 = happySpecReduce_2 4# happyReduction_17-happyReduction_17 happy_x_2- happy_x_1- = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn8- (Spatial [happy_var_1] happy_var_2- )}}--happyReduce_18 = happySpecReduce_2 4# happyReduction_18-happyReduction_18 happy_x_2- happy_x_1- = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn8- (Spatial [happy_var_1] happy_var_2- )}}--happyReduce_19 = happySpecReduce_1 4# happyReduction_19-happyReduction_19 happy_x_1- = case happyOut6 happy_x_1 of { happy_var_1 -> - happyIn8- (Spatial [] happy_var_1- )}--happyReduce_20 = happySpecReduce_1 5# happyReduction_20-happyReduction_20 happy_x_1- = happyIn9- (ReadOnce- )--happyReduce_21 = happySpecReduce_2 6# happyReduction_21-happyReduction_21 happy_x_2- happy_x_1- = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_2 of { happy_var_2 -> - happyIn10- (happy_var_1 : happy_var_2- )}}--happyReduce_22 = happySpecReduce_1 6# happyReduction_22-happyReduction_22 happy_x_1- = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10- ([happy_var_1]- )}--happyReduce_23 = happySpecReduce_1 7# happyReduction_23-happyReduction_23 happy_x_1- = happyIn11- (AtMost- )--happyReduce_24 = happySpecReduce_1 7# happyReduction_24-happyReduction_24 happy_x_1- = happyIn11- (AtLeast- )--happyReduce_25 = happySpecReduce_2 8# happyReduction_25-happyReduction_25 happy_x_2- happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn12- (happy_var_1 : happy_var_2- )}}--happyReduce_26 = happySpecReduce_1 8# happyReduction_26-happyReduction_26 happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn12- ([happy_var_1]- )}--happyNewToken action sts stk [] =- happyDoAction 25# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =- let cont i = happyDoAction i tk action sts stk tks in- case tk of {- TId "stencil" -> cont 1#;- TId "region" -> cont 2#;- TId "readonce" -> cont 3#;- TId "reflexive" -> cont 4#;- TId "irreflexive" -> cont 5#;- TId "atmost" -> cont 6#;- TId "atleast" -> cont 7#;- TId "dims" -> cont 8#;- TId "dim" -> cont 9#;- TId "depth" -> cont 10#;- TId "forward" -> cont 11#;- TId "backward" -> cont 12#;- TId "centered" -> cont 13#;- TId "dependency" -> cont 14#;- TId "mutual" -> cont 15#;- TId happy_dollar_dollar -> cont 16#;- TNum happy_dollar_dollar -> cont 17#;- TPlus -> cont 18#;- TStar -> cont 19#;- TDoubleColon -> cont 20#;- TEqual -> cont 21#;- TLParen -> cont 22#;- TRParen -> cont 23#;- TComma -> cont 24#;- _ -> happyError' (tk:tks)- }--happyError_ 25# tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)--happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b-happyThen = (>>=)-happyReturn :: () => a -> Either AnnotationParseError a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> Either AnnotationParseError a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> Either AnnotationParseError a-happyError' = happyError--parseSpec tks = happySomeParser where- happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))--happySeq = happyDontSeq---data Specification- = RegionDec String Region- | SpecDec Spec [String]- deriving (Show, Eq, Ord, Typeable, Data)--data Region- = Forward Int Int Bool- | Backward Int Int Bool- | Centered Int Int Bool- | Or Region Region- | And Region Region- | Var String- deriving (Show, Eq, Ord, Typeable, Data)--data Spec- = Spatial [Mod] Region- | Temporal [String] Bool- deriving (Show, Eq, Ord, Typeable, Data)--data Mod- = AtLeast- | AtMost- | ReadOnce- deriving (Show, Eq, Ord, Typeable, Data)------------------------------------------------------data Token- = TDoubleColon- | TStar- | TPlus- | TEqual- | TComma- | TLParen- | TRParen- | TId String- | TNum String- deriving (Show)--addToTokens :: Token -> String -> Either AnnotationParseError [ Token ]-addToTokens tok rest = do- tokens <- lexer' rest- return $ tok : tokens--stripLeadingWhiteSpace (' ':xs) = stripLeadingWhiteSpace xs-stripLeadingWhiteSpace ('\t':xs) = stripLeadingWhiteSpace xs-stripLeadingWhiteSpace ('\n':xs) = stripLeadingWhiteSpace xs-stripLeadingWhiteSpace xs = xs---lexer :: String -> Either AnnotationParseError [ Token ]-lexer input | length (stripLeadingWhiteSpace input) >= 2 =- case stripLeadingWhiteSpace input of- -- Check the leading character is '=' for specification- '=':input' ->- -- First test to see if the input looks like an actual- -- specification of either a stencil or region- if (input' `hasPrefix` "stencil" || input' `hasPrefix` "region")- then lexer' input'- else Left NotAnnotation- _ -> Left NotAnnotation- where- hasPrefix [] str = False- hasPrefix (' ':xs) str = hasPrefix xs str- hasPrefix xs str = isPrefixOf str xs-lexer _ = Left NotAnnotation---lexer' :: String -> Either AnnotationParseError [ Token ]-lexer' [] = return []-lexer' (' ':xs) = lexer' xs-lexer' ('\t':xs) = lexer' xs-lexer' (':':':':xs) = addToTokens TDoubleColon xs-lexer' ('*':xs) = addToTokens TStar xs-lexer' ('+':xs) = addToTokens TPlus xs-lexer' ('=':xs) = addToTokens TEqual xs--- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead.-lexer' (',':xs)- | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs')- | otherwise = addToTokens TComma xs-lexer' ('(':xs) = addToTokens TLParen xs-lexer' (')':xs) = addToTokens TRParen xs-lexer' (x:xs)- | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_'- | isNumber x = aux TNum isNumber- | otherwise- = failWith $ "Not an indentifier " ++ show x- where- aux f p = (f target :) `fmap` lexer' rest- where (target, rest) = span p (x:xs)-lexer' x- = failWith $ "Not a valid piece of stencil syntax " ++ show x-------------------------------------------------------- specParser :: String -> Either AnnotationParseError Specification-specParser :: AnnotationParser Specification-specParser src = do- tokens <- lexer src- parseSpec tokens >>= modValidate---- Check whether modifiers are used correctly-modValidate :: Specification -> Either AnnotationParseError Specification-modValidate (SpecDec (Spatial mods r) vars) =- do mods' <- modValidate' $ sort mods- return $ SpecDec (Spatial mods' r) vars-- where modValidate' [] = return $ []-- modValidate' (AtLeast : AtLeast : xs)- = failWith "Duplicate 'atLeast' modifier; use at most one."-- modValidate' (AtMost : AtMost : xs)- = failWith "Duplicate 'atMost' modifier; use at most one."-- modValidate' (ReadOnce : ReadOnce : xs)- = failWith "Duplicate 'readOnce' modifier; use at most one."-- modValidate' (AtLeast : AtMost : xs)- = failWith $ "Conflicting modifiers: cannot use 'atLeast' and "- ++ "'atMost' together"-- modValidate' (x : xs)- = do xs' <- modValidate' xs- return $ x : xs'-modValidate x = return x--happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = failWith $ "Could not parse specification at: " ++ show t-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<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,759 +0,0 @@-{-# OPTIONS_GHC -w #-}-{-# OPTIONS -fglasgow-exts -cpp #-}--- -*- Mode: Haskell -*---{-# LANGUAGE DeriveDataTypeable #-}-module Camfort.Specification.Units.Parser ( unitParser- , UnitStatement(..)- , UnitOfMeasure(..)- , UnitPower(..)- ) where--import Camfort.Analysis.CommentAnnotator-import Data.Data-import Data.List-import Data.Char (isLetter, isNumber, isAlphaNum, toLower)-import qualified Data.Array as Happy_Data_Array-import qualified GHC.Exts as Happy_GHC_Exts-import Control.Applicative(Applicative(..))-import Control.Monad (ap)---- parser produced by Happy Version 1.19.5--newtype HappyAbsSyn = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = Happy_GHC_Exts.Any-#else-type HappyAny = forall a . a-#endif-happyIn4 :: (UnitStatement) -> (HappyAbsSyn )-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn ) -> (UnitStatement)-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-happyIn5 :: (Maybe [String]) -> (HappyAbsSyn )-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn ) -> (Maybe [String])-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-happyIn6 :: ([String]) -> (HappyAbsSyn )-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn ) -> ([String])-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-happyIn7 :: (UnitOfMeasure) -> (HappyAbsSyn )-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn ) -> (UnitOfMeasure)-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-happyIn8 :: (UnitOfMeasure) -> (HappyAbsSyn )-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn ) -> (UnitOfMeasure)-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-happyIn9 :: (UnitOfMeasure) -> (HappyAbsSyn )-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn ) -> (UnitOfMeasure)-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-happyIn10 :: (UnitPower) -> (HappyAbsSyn )-happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn ) -> (UnitPower)-happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut10 #-}-happyIn11 :: (Integer) -> (HappyAbsSyn )-happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn ) -> (Integer)-happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut11 #-}-happyIn12 :: (String) -> (HappyAbsSyn )-happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyIn12 #-}-happyOut12 :: (HappyAbsSyn ) -> (String)-happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut12 #-}-happyInTok :: (Token) -> (HappyAbsSyn )-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn ) -> (Token)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x44\x00\x41\x00\x0f\x00\x3c\x00\x05\x00\x2b\x00\x04\x00\x3d\x00\x00\x00\x00\x00\x3f\x00\xff\xff\x3b\x00\x01\x00\x34\x00\x00\x00\x35\x00\x10\x00\x36\x00\x0f\x00\x00\x00\x04\x00\x3a\x00\x00\x00\x39\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x19\x00\x0f\x00\x00\x00\x00\x00\x33\x00\xfd\xff\x00\x00\x38\x00\x00\x00\x19\x00\x00\x00\x2c\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\x37\x00\x00\x00\x27\x00\x00\x00\x27\x00\x22\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x1d\x00\x00\x00\x30\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x28\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xf8\xff\xf2\xff\xef\xff\xf7\xff\x00\x00\x00\x00\x00\x00\xf8\xff\xf7\xff\xf5\xff\x00\x00\x00\x00\xf4\xff\x00\x00\xfe\xff\x00\x00\x00\x00\xfc\xff\xf9\xff\xf3\xff\xf1\xff\xee\xff\xeb\xff\xe8\xff\xe9\xff\x00\x00\x00\x00\x00\x00\xf6\xff\xf0\xff\xfd\xff\x00\x00\xea\xff\x00\x00\xfa\xff\x00\x00\xed\xff\x00\x00\xec\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x02\x00\x02\x00\x08\x00\x02\x00\x02\x00\x03\x00\x0c\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x09\x00\x0b\x00\x0b\x00\x02\x00\x03\x00\x03\x00\x04\x00\x08\x00\x06\x00\x03\x00\x04\x00\x05\x00\x0b\x00\x0b\x00\x03\x00\x04\x00\x02\x00\x06\x00\x03\x00\x04\x00\x05\x00\x01\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x07\x00\x08\x00\x07\x00\x08\x00\x03\x00\x04\x00\x08\x00\x09\x00\x05\x00\x05\x00\x00\x00\x0c\x00\x07\x00\x02\x00\x08\x00\x02\x00\x07\x00\x05\x00\x0a\x00\x0c\x00\x02\x00\x01\x00\x08\x00\x07\x00\x01\x00\xff\xff\xff\xff\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x09\x00\x0f\x00\x09\x00\x28\x00\x2a\x00\x09\x00\x09\x00\x0a\x00\x2b\x00\x0c\x00\x10\x00\x14\x00\x24\x00\x0b\x00\x14\x00\x0c\x00\x09\x00\x0a\x00\x1e\x00\x1f\x00\x26\x00\x20\x00\x24\x00\x06\x00\x07\x00\x0c\x00\x21\x00\x1e\x00\x1f\x00\x17\x00\x20\x00\x0c\x00\x0d\x00\x07\x00\x14\x00\x1a\x00\x1b\x00\x1c\x00\x0c\x00\x0d\x00\x07\x00\x05\x00\x06\x00\x07\x00\x2b\x00\x1c\x00\x25\x00\x1c\x00\x1e\x00\x1f\x00\x16\x00\x17\x00\x19\x00\x12\x00\x03\x00\x2d\x00\x12\x00\x19\x00\x16\x00\x19\x00\x12\x00\x28\x00\x22\x00\x23\x00\x11\x00\x03\x00\x16\x00\x12\x00\x05\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (1, 23) [- (1 , happyReduce_1),- (2 , happyReduce_2),- (3 , happyReduce_3),- (4 , happyReduce_4),- (5 , happyReduce_5),- (6 , happyReduce_6),- (7 , happyReduce_7),- (8 , happyReduce_8),- (9 , happyReduce_9),- (10 , happyReduce_10),- (11 , happyReduce_11),- (12 , happyReduce_12),- (13 , happyReduce_13),- (14 , happyReduce_14),- (15 , happyReduce_15),- (16 , happyReduce_16),- (17 , happyReduce_17),- (18 , happyReduce_18),- (19 , happyReduce_19),- (20 , happyReduce_20),- (21 , happyReduce_21),- (22 , happyReduce_22),- (23 , happyReduce_23)- ]--happy_n_terms = 14 :: Int-happy_n_nonterms = 9 :: Int--happyReduce_1 = happySpecReduce_3 0# happyReduction_1-happyReduction_1 happy_x_3- happy_x_2- happy_x_1- = case happyOut7 happy_x_2 of { happy_var_2 -> - case happyOut5 happy_x_3 of { happy_var_3 -> - happyIn4- (UnitAssignment happy_var_3 happy_var_2- )}}--happyReduce_2 = happyReduce 5# 0# happyReduction_2-happyReduction_2 (happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOutTok happy_x_3 of { (TId happy_var_3) -> - case happyOut7 happy_x_5 of { happy_var_5 -> - happyIn4- (UnitAlias happy_var_3 happy_var_5- ) `HappyStk` happyRest}}--happyReduce_3 = happySpecReduce_2 1# happyReduction_3-happyReduction_3 happy_x_2- happy_x_1- = case happyOut6 happy_x_2 of { happy_var_2 -> - happyIn5- (Just happy_var_2- )}--happyReduce_4 = happySpecReduce_0 1# happyReduction_4-happyReduction_4 = happyIn5- (Nothing- )--happyReduce_5 = happySpecReduce_3 2# happyReduction_5-happyReduction_5 happy_x_3- happy_x_2- happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - case happyOut6 happy_x_3 of { happy_var_3 -> - happyIn6- (happy_var_1 : happy_var_3- )}}--happyReduce_6 = happySpecReduce_1 2# happyReduction_6-happyReduction_6 happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn6- ([happy_var_1]- )}--happyReduce_7 = happySpecReduce_1 3# happyReduction_7-happyReduction_7 happy_x_1- = case happyOut8 happy_x_1 of { happy_var_1 -> - happyIn7- (happy_var_1- )}--happyReduce_8 = happySpecReduce_1 3# happyReduction_8-happyReduction_8 happy_x_1- = happyIn7- (Unitless- )--happyReduce_9 = happySpecReduce_3 3# happyReduction_9-happyReduction_9 happy_x_3- happy_x_2- happy_x_1- = happyIn7- (Unitless- )--happyReduce_10 = happySpecReduce_2 3# happyReduction_10-happyReduction_10 happy_x_2- happy_x_1- = happyIn7- (Unitless- )--happyReduce_11 = happySpecReduce_2 4# happyReduction_11-happyReduction_11 happy_x_2- happy_x_1- = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_2 of { happy_var_2 -> - happyIn8- (UnitProduct happy_var_1 happy_var_2- )}}--happyReduce_12 = happySpecReduce_3 4# happyReduction_12-happyReduction_12 happy_x_3- happy_x_2- happy_x_1- = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut9 happy_x_3 of { happy_var_3 -> - happyIn8- (UnitQuotient happy_var_1 happy_var_3- )}}--happyReduce_13 = happySpecReduce_1 4# happyReduction_13-happyReduction_13 happy_x_1- = case happyOut9 happy_x_1 of { happy_var_1 -> - happyIn8- (happy_var_1- )}--happyReduce_14 = happySpecReduce_3 5# happyReduction_14-happyReduction_14 happy_x_3- happy_x_2- happy_x_1- = case happyOut9 happy_x_1 of { happy_var_1 -> - case happyOut10 happy_x_3 of { happy_var_3 -> - happyIn9- (UnitExponentiation happy_var_1 happy_var_3- )}}--happyReduce_15 = happySpecReduce_3 5# happyReduction_15-happyReduction_15 happy_x_3- happy_x_2- happy_x_1- = case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn9- (happy_var_2- )}--happyReduce_16 = happySpecReduce_1 5# happyReduction_16-happyReduction_16 happy_x_1- = case happyOutTok happy_x_1 of { (TId happy_var_1) -> - happyIn9- (UnitBasic happy_var_1- )}--happyReduce_17 = happySpecReduce_1 6# happyReduction_17-happyReduction_17 happy_x_1- = case happyOut11 happy_x_1 of { happy_var_1 -> - happyIn10- (UnitPowerInteger happy_var_1- )}--happyReduce_18 = happySpecReduce_3 6# happyReduction_18-happyReduction_18 happy_x_3- happy_x_2- happy_x_1- = case happyOut11 happy_x_2 of { happy_var_2 -> - happyIn10- (UnitPowerInteger happy_var_2- )}--happyReduce_19 = happyReduce 5# 6# happyReduction_19-happyReduction_19 (happy_x_5 `HappyStk`- happy_x_4 `HappyStk`- happy_x_3 `HappyStk`- happy_x_2 `HappyStk`- happy_x_1 `HappyStk`- happyRest)- = case happyOut11 happy_x_2 of { happy_var_2 -> - case happyOut11 happy_x_4 of { happy_var_4 -> - happyIn10- (UnitPowerRational happy_var_2 happy_var_4- ) `HappyStk` happyRest}}--happyReduce_20 = happySpecReduce_1 7# happyReduction_20-happyReduction_20 happy_x_1- = case happyOut12 happy_x_1 of { happy_var_1 -> - happyIn11- (read happy_var_1- )}--happyReduce_21 = happySpecReduce_2 7# happyReduction_21-happyReduction_21 happy_x_2- happy_x_1- = case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn11- (read $ '-' : happy_var_2- )}--happyReduce_22 = happySpecReduce_1 8# happyReduction_22-happyReduction_22 happy_x_1- = case happyOutTok happy_x_1 of { (TNum happy_var_1) -> - happyIn12- (happy_var_1- )}--happyReduce_23 = happySpecReduce_1 8# happyReduction_23-happyReduction_23 happy_x_1- = happyIn12- ("1"- )--happyNewToken action sts stk [] =- happyDoAction 13# notHappyAtAll action sts stk []--happyNewToken action sts stk (tk:tks) =- let cont i = happyDoAction i tk action sts stk tks in- case tk of {- TId "unit" -> cont 1#;- TId happy_dollar_dollar -> cont 2#;- TNum "1" -> cont 3#;- TNum happy_dollar_dollar -> cont 4#;- TComma -> cont 5#;- TMinus -> cont 6#;- TExponentiation -> cont 7#;- TDivision -> cont 8#;- TDoubleColon -> cont 9#;- TEqual -> cont 10#;- TLeftPar -> cont 11#;- TRightPar -> cont 12#;- _ -> happyError' (tk:tks)- }--happyError_ 13# tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)--happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b-happyThen = (>>=)-happyReturn :: () => a -> Either AnnotationParseError a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> Either AnnotationParseError a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> Either AnnotationParseError a-happyError' = happyError--parseUnit tks = happySomeParser where- happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))--happySeq = happyDontSeq---data UnitStatement =- UnitAssignment (Maybe [String]) UnitOfMeasure- | UnitAlias String UnitOfMeasure- deriving Data--instance Show UnitStatement where- show (UnitAssignment (Just ss) uom) = "= unit (" ++ show uom ++ ") :: " ++ (intercalate "," ss)- show (UnitAssignment Nothing uom) = "= unit (" ++ show uom ++ ")"- show (UnitAlias s uom) = "= unit :: " ++ s ++ " = " ++ show uom--data UnitOfMeasure =- Unitless- | UnitBasic String- | UnitProduct UnitOfMeasure UnitOfMeasure- | UnitQuotient UnitOfMeasure UnitOfMeasure- | UnitExponentiation UnitOfMeasure UnitPower- deriving Data--instance Show UnitOfMeasure where- show Unitless = "1"- show (UnitBasic s) = s- show (UnitProduct uom1 uom2) = show uom1 ++ " " ++ show uom2- show (UnitQuotient uom1 uom2) = show uom1 ++ " / " ++ show uom2- show (UnitExponentiation uom exp) = show uom ++ "** (" ++ show exp ++ ")"--data UnitPower =- UnitPowerInteger Integer- | UnitPowerRational Integer Integer- deriving Data--instance Show UnitPower where- show (UnitPowerInteger i) = show i- show (UnitPowerRational i1 i2) = show i1 ++ "/" ++ show i2--data Token =- TUnit- | TComma- | TDoubleColon- | TExponentiation- | TDivision- | TMinus- | TEqual- | TLeftPar- | TRightPar- | TId String- | TNum String- deriving (Show)--lexer :: String -> Either AnnotationParseError [ Token ]-lexer ('=':xs) = lexer' xs-lexer _ = Left NotAnnotation--addToTokens :: Token -> String -> Either AnnotationParseError [ Token ]-addToTokens tok rest = do- tokens <- lexer' rest- return $ tok : tokens--lexer' :: String -> Either AnnotationParseError [ Token ]-lexer' [] = Right []-lexer' ['\n'] = Right []-lexer' ['\r', '\n'] = Right []-lexer' ['\r'] = Right [] -- windows-lexer' (' ':xs) = lexer' xs-lexer' ('\t':xs) = lexer' xs-lexer' (':':':':xs) = addToTokens TDoubleColon xs-lexer' ('*':'*':xs) = addToTokens TExponentiation xs-lexer' (',':xs) = addToTokens TComma xs-lexer' ('/':xs) = addToTokens TDivision xs-lexer' ('-':xs) = addToTokens TMinus xs-lexer' ('=':xs) = addToTokens TEqual xs-lexer' ('(':xs) = addToTokens TLeftPar xs-lexer' (')':xs) = addToTokens TRightPar xs-lexer' (x:xs)- | isLetter x = aux (\c -> isAlphaNum c || c `elem` ['\'','_','-']) TId- | isNumber x = aux isNumber TNum- | otherwise = Left NotAnnotation -- failWith $ "Not valid unit syntax at " ++ show (x:xs)- where- aux p cons =- let (target, rest) = span p xs- in lexer' rest >>= (\tokens -> return $ cons (x:target) : tokens)--unitParser :: String -> Either AnnotationParseError UnitStatement-unitParser src = do- tokens <- lexer $ map toLower src- parseUnit tokens--happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = Left NotAnnotation -- failWith $ "Could not parse specification at: " ++ show t-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<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
@@ -27,11 +27,6 @@ import Data.Map.Lazy hiding (map) import Debug.Trace -import Language.Haskell.ParseMonad--import Language.Fortran-import Camfort.Analysis.IntermediateReps- import Camfort.Specification.Units.Environment import qualified Camfort.Specification.Units.Parser as P import Camfort.Analysis.CommentAnnotator@@ -40,62 +35,44 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA+import qualified Language.Fortran.Util.Position as FU type Report = String --- Additional "helper" syntax (NOT GENERATED BY PARSER)---- Loop classifications--data ReduceType = Reduce | NoReduce-data AccessPatternType = Regular | RegularAndConstants | Irregular | Undecidable-data LoopType = Functor ReduceType- | Gather ReduceType ReduceType AccessPatternType- | Scatter ReduceType AccessPatternType--{- classify :: Fortran Annotation -> Fortran Annotation- classify x = -}- type A = Annotation--data Annotation = A { lives :: ([Access],[Access]),- unitVar :: Int,- number :: Int,- refactored :: Maybe SrcLoc,- successorStmts :: [Int],- -- used to indicate when a node is newly introduced- newNode :: Bool,- stencilSpec :: Maybe- -- If defined, either an unprocessed syntax tree- (Either StencilComment.Specification- -- Or a parser AST of a RegionEnv or SpecDecls- (Either StencilSpec.RegionEnv StencilSpec.SpecDecls)),- stencilBlock ::- Maybe (F.Block (FA.Analysis Annotation))- }- deriving (Eq, Show, Typeable, Data)--liveOut = snd . lives-liveIn = fst . lives-- -- Map Variable [[(Variable,Int)]],+data Annotation =+ A { unitVar :: Int+ , number :: Int+ , refactored :: Maybe FU.Position+ -- indicates when a node is newly introduced+ , newNode :: Bool+ -- indicates a node which is being deleted+ , deleteNode :: Bool+ -- Stencil specification annotations+ -- TODO: move these into their own annotation+ , stencilSpec :: Maybe+ -- If defined, either an unprocessed syntax tree+ (Either StencilComment.Specification+ -- Or a parser AST of a RegionEnv or SpecDecls+ (Either StencilSpec.RegionEnv StencilSpec.SpecDecls))+ , stencilBlock :: Maybe (F.Block (FA.Analysis Annotation))+ } deriving (Eq, Show, Typeable, Data) +-- Predicate on whether an AST has been refactored pRefactored :: Annotation -> Bool pRefactored = isJust . refactored unitAnnotation = A- { lives = ([], [])- , unitVar = 0+ { unitVar = 0 , number = 0 , refactored = Nothing- , successorStmts = [] , newNode = False+ , deleteNode = False , stencilSpec = Nothing , stencilBlock = Nothing } --------------------------------------------------- -- Convenience name for a common annotation type. type UA = FA.Analysis (UnitAnnotation A) @@ -106,7 +83,7 @@ -- Link annotation comments to declaration statements instance Linkable UA where- link ann (b@(F.BlStatement _ _ _ (F.StDeclaration {}))) =+ link ann (b@(F.BlStatement _ _ _ F.StDeclaration {})) = onPrev (\ ann -> ann { unitBlock = Just b }) ann link ann b = ann
− src/Camfort/Analysis/CallGraph.hs
@@ -1,36 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE DeriveDataTypeable #-}--module Camfort.Analysis.CallGraph where--import Data.Data--import Language.Fortran-import Language.Fortran.Pretty--import Data.Generics.Uniplate.Operations-import Control.Monad.State.Lazy-import Debug.Trace--import Camfort.Analysis.Annotations-import Camfort.Analysis.Syntax-import Camfort.Traverse---- Calculates inter-procedural information--type DefSites = [(String, String)]
src/Camfort/Analysis/CommentAnnotator.hs view
@@ -30,7 +30,7 @@ import Control.Monad.Writer.Strict (Writer(..), tell) import Data.Generics.Uniplate.Operations import Data.Data (Data)-+import Debug.Trace import Language.Fortran.AST import Language.Fortran.Util.Position@@ -67,7 +67,7 @@ {-| Link all comment blocks to first non-comment block in the list. |-} linkBlocks :: (Data a, Linkable a) => [ Block a ] -> [ Block a ] linkBlocks [ ] = [ ]- linkBlocks [ x ] = [ x ]+ --linkBlocks [ x ] = [ x ] linkBlocks blocks@(b:bs) | BlComment{} <- b = let (comments, rest) = span isComment blocks@@ -75,7 +75,7 @@ then comments else let (bs, bs') = linkMultiple comments rest in bs ++ linkBlocks bs'- | otherwise = b : linkBlocks bs+ | otherwise = (descendBi linkBlocks b) : linkBlocks bs where isComment BlComment{} = True isComment _ = False
− src/Camfort/Analysis/IntermediateReps.hs
@@ -1,40 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}--module Camfort.Analysis.IntermediateReps where--import Data.Data--import Language.Fortran-import Language.Fortran.Pretty--data AccessP p = VarA String | ArrayA String [Expr p] deriving (Eq, Typeable, Data)--type Access = AccessP ()--accessToVarName :: AccessP a -> Variable-accessToVarName (VarA v) = v-accessToVarName (ArrayA v _) = v--instance Show (AccessP ()) where- show (VarA s) = s- show (ArrayA v es) = v ++ "(" ++ (showList (map pprint es)) ++ ")"- where showList [] = ""- showList [x] = x- showList (x:xs) = x ++ ", " ++ showList xs
− src/Camfort/Analysis/LVA.hs
@@ -1,113 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}-{-# LANGUAGE ScopedTypeVariables #-}--{-|--Provides live-variable analysis for Fortran code. One of the simpler analyses in the suite (a good-starting point for any new developers). This demonstrates the use of the "zipper" format, and -various helpers from 'Analysis.Syntax' and 'Traverse'. --'lva' is the top-level definition here.---}-module Camfort.Analysis.LVA where- -import Data.Data-import Data.List--import Data.Generics.Zipper-import Data.Generics.Uniplate.Operations--import Language.Fortran--import Camfort.Analysis.Annotations-import Camfort.Analysis.Syntax-import Camfort.Transformation.Syntax-import Camfort.Analysis.IntermediateReps-import Camfort.Traverse---{-| live-variable analysis on a program -}--- Recall: type Program a = [ProgUnit a]-lva :: Program Annotation -> Program Annotation-lva x = map lvaOnUnit x- -{-| live-variable analysis at the level of a unit, not whole-program,iterates @lva1@ until a fixed-point is reached -}-lvaOnUnit :: ProgUnit Annotation -> ProgUnit Annotation-lvaOnUnit x = let y = fromZipper . (everywhere lva1) . toZipper $ numberStmts . (transformBi reassociate) $ x- in if (y == x) then y else lvaOnUnit y--{-| Single iteration of live-variable analysis over the zipper for an AST -}-lva1 :: Zipper (ProgUnit Annotation) -> Zipper (ProgUnit Annotation)--lva1 z = case (getHole z)::(Maybe (Fortran Annotation)) of- Just f -> let anns = map tag ((successors z)::[Fortran Annotation]) -- annotations of the successors- liveOut = nub $ concat $ map (fst . lives) anns- killV = kill f- genV = gen f- liveIn = nub $ union genV (liveOut \\ killV)- annotation = (tag f) { lives = (liveIn, liveOut), successorStmts = map number anns }- in setHole (refill f annotation) z- Nothing -> z--{-| Variables killed by the current statement -}-kill :: Fortran Annotation -> [Access]-kill (Assg _ _ e1 _) = killForLhsVar e1 - where- {-| variable killed by expressions on the left-hand side -}- killForLhsVar :: Expr Annotation -> [Access]- killForLhsVar (Var a p xes) = map (\((VarName _ v), _) -> VarA v) xes- killForLhsVar _ = []-kill t = concatMap accesses (lhsExpr t)--{-| Variables generated (made live) by the current statement -}-gen :: Fortran Annotation -> [Access]-gen t@(Assg _ _ e1 e2) = (concatMap accesses (rhsExpr t)) ++ (genForLhsVar e1)- where- {-| variables generated on the left-hand side -}- genForLhsVar :: Expr Annotation -> [Access] - genForLhsVar t@ (Var _ _ xes) = concatMap (\(_, es) -> accesses es) xes- genForLhsVar _ = []-gen t = concatMap accesses (rhsExpr t) ----- --------{-- successorAnnotations :: Zipper (ProgUnit Annotation) -> [Annotation]- successorAnnotations x = goRight x ++ (case (up x) of- Just ux -> case (getHole ux)::(Maybe (Fortran Annotation)) of- Just f -> map tag (successors f) ++ (goRight ux)- Nothing -> (goRight ux)- Nothing -> []) - where goRight :: Zipper (ProgUnit Annotation) -> [Annotation]- goRight z = (case (getHole z)::(Maybe (Fortran Annotation)) of - Just f -> [tag f]- Nothing -> []) ++- (case (right z) of- Just rz -> goRight rz- Nothing -> [])- - -}
− src/Camfort/Analysis/Syntax.hs
@@ -1,393 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, KindSignatures,- FlexibleContexts, GADTs, DeriveGeneric #-}--{-|--This module provides a number of helper functions for working with Fortran syntax that are useful-between different analyses and transformations.---}-module Camfort.Analysis.Syntax where---- Standard imports-import Data.Char-import Data.List-import Data.Monoid-import Control.Monad.State.Lazy-import Debug.Trace---- Data-type generics imports-import Data.Data-import Data.Generics.Uniplate.Data-import Data.Generics.Uniplate.Operations-import Data.Generics.Zipper-import Data.Typeable---- CamFort specific functionality-import Camfort.Analysis.Annotations-import Camfort.Analysis.IntermediateReps-import Camfort.Traverse-import Language.Fortran---- * Comparison and ordering--{-| 'AnnotationFree' is a data type that wraps other types and denotes terms- which should be compared for equality modulo their annotations and source- location information -}-data AnnotationFree t = AnnotationFree { annotationBound :: t } deriving Show--{-| short-hand constructor for 'AnnotationFree' -}-af = AnnotationFree-{-| short-hand deconstructor for 'AnnotationFree' -}-unaf = annotationBound--{-| A helpful function, used by the 'Eq AnnotationFree' instance that- resets and source location information -}-eraseSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a-eraseSrcLocs =- transformBi erase'- where- erase' :: SrcLoc -> SrcLoc- erase' _ = SrcLoc { srcFilename = "", srcLine = 0, srcColumn = 0 }--{-| Sets the @SrcLoc@ information to have the filename "compact" which triggers a special- compact form of pretty printing in the @Show SrcLoc@ instances -}-setCompactSrcLocs :: (Typeable (t a), Data (t a)) => t a -> t a-setCompactSrcLocs =- transformBi cmpact'- where- cmpact' :: SrcLoc -> SrcLoc- cmpact' (SrcLoc _ l c) = SrcLoc { srcFilename = "compact", srcLine = l, srcColumn = c }--lower = map toLower---- Here begins varioous 'Eq' instances for instantiations of 'AnnotationFree'--instance Eq (AnnotationFree a) => Eq (AnnotationFree [a]) where- (AnnotationFree xs) == (AnnotationFree xs') =- if (length xs == length xs')- then foldl (\b -> \(x, x') -> ((af x) == (af x')) && b) True (zip xs xs')- else False--instance Eq (AnnotationFree Int) where- x == y = (unaf x) == (unaf y)--instance Eq (AnnotationFree Char) where- x == y = (unaf x) == (unaf y)--instance Eq (AnnotationFree (AccessP ())) where- x == y = (unaf x) == (unaf y)--instance (Eq (AnnotationFree a), Eq (AnnotationFree b)) => Eq (AnnotationFree (a, b)) where- (AnnotationFree (x, y)) == (AnnotationFree (x', y')) = ((af x) == (af x')) && ((af y) == (af y'))--instance Eq (AnnotationFree (Expr a)) where- -- Compute variable equality modulo annotations and spans- (AnnotationFree (Var _ _ vs)) == (AnnotationFree (Var _ _ vs'))- = cmp vs vs'- where- cmp [] [] = True- cmp ((VarName _ v,es):vs) ((VarName _ v',es'):vs') =-- -- Since whether variable names are upper or lower case is irrelevant- -- in Fortran, we must compare variables for equality by normalising- -- first (here to lower case)-- if (lower v) == (lower v') then- (and (map (\(e, e') -> (af e) == (af e'))- (zip es es'))) && (cmp vs vs')- else False- cmp _ _ = False-- -- For other expressions we can get away with reseting their- -- annotations are erasing their source locs- (AnnotationFree e1) == (AnnotationFree e2) =- (eraseSrcLocs $ fmap (const ()) e1) == (eraseSrcLocs $ fmap (const ()) e2)---instance Eq (AnnotationFree (Type a)) where- (AnnotationFree (BaseType _ b attrs e1 e2)) == (AnnotationFree (BaseType _ b' attrs' e1' e2')) =- (af b == af b') && (af attrs == af attrs') && (af e1 == af e1') && (af e2 == af e2')-- (AnnotationFree (ArrayT _ eps b attrs e1 e2)) == (AnnotationFree (ArrayT _ eps' b' attrs' e1' e2')) =- (af eps == af eps') && (af b == af b') && (af attrs == af attrs') && (af e1 == af e1') && (af e2 == af e2')--instance Eq (AnnotationFree (Attr p)) where- (AnnotationFree (Dimension _ es)) == (AnnotationFree (Dimension _ es')) = af es == af es'- (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y)--instance Eq (AnnotationFree (BaseType p)) where- (AnnotationFree (DerivedType _ s)) == (AnnotationFree (DerivedType _ s')) = (af s) == (af s')- (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y)---instance Eq (AnnotationFree (SubName p)) where- (AnnotationFree (SubName _ s)) == (AnnotationFree (SubName _ s')) = (lower s) == (lower s')- (AnnotationFree (NullSubName _)) == (AnnotationFree (NullSubName _)) = True- _ == _ = False--instance Eq (AnnotationFree (IntentAttr p)) where- (AnnotationFree x) == (AnnotationFree y) = (fmap (const ()) x) == (fmap (const ()) y)---instance Eq (AnnotationFree (MeasureUnitSpec p)) where- (AnnotationFree (UnitProduct _ u)) == (AnnotationFree (UnitProduct _ u')) = (af u) == (af u')- (AnnotationFree (UnitQuotient _ u1 u2)) == (AnnotationFree (UnitQuotient _ u1' u2')) =- (af u1 == af u1') && (af u2 == af u2')- (AnnotationFree (UnitNone _)) == (AnnotationFree (UnitNone _)) = True- _ == _ = False--instance Eq (AnnotationFree (Fraction p)) where- (AnnotationFree (IntegerConst _ n)) == (AnnotationFree (IntegerConst _ n')) = (af n) == (af n')- (AnnotationFree (FractionConst _ p q)) == (AnnotationFree (FractionConst _ p' q')) =- (af p == af p') && (af q == af q')- (AnnotationFree (NullFraction _)) == (AnnotationFree (NullFraction _)) = True- _ == _ = False---{-| Ordering on accessor syntax -}-instance Ord (AccessP ()) where- (VarA s1) <= (VarA s2) = s1 <= s2- (ArrayA s1 e1) <= (ArrayA s2 e2) = if (s1 == s2) then e1 <= e2 else s1 <= s2- (VarA s1) <= (ArrayA s2 e1) = True- _ <= _ = False--{-| Partial-ordering for expressions (constructors only so far), ignores annotations -}-instance Eq p => Ord (Expr p) where- (Con _ _ c) <= (Con _ _ c') = c <= c'- e <= e' = error "Ordering on expressions only for constructors so far"---- * Accessor functions for extracting various pieces of information out of syntax trees--{-| Extracts the subprocedure name from a program unit -}-getSubName :: ProgUnit p -> Maybe String-getSubName (Main _ _ (SubName _ s) _ _ _) = Just s-getSubName (Sub _ _ _ (SubName _ s) _ _) = Just s-getSubName (Function _ _ _ (SubName _ s) _ _ _) = Just s-getSubName (Module _ _ (SubName _ s) _ _ _ _) = Just s-getSubName (BlockData _ _ (SubName _ s) _ _ _) = Just s-getSubName _ = Nothing--{-| Extracts all accessors (variables and array indexing) from a piece of syntax -}-accesses f = nub $ [VarA (lower v) | (AssgExpr _ _ v _) <- (universeBi f)::[Expr Annotation]]- ++ concat [varExprToAccesses ve | ve@(Var _ _ _) <- (universeBi f)::[Expr Annotation]]---{-| Extracts a string of the (root) variable name from a variable expression (if it is indeed a variable- expression -}-varExprToVariable :: Expr a -> Maybe Variable-varExprToVariable (Var _ _ ((VarName _ v, es):_)) = Just v-varExprToVariable _ = Nothing--{-| Extracts an 'accessor' form a variable from a variable expression -}-varExprToAccess :: Expr a -> Maybe Access-varExprToAccess v = varExprToVariable v >>= (Just . VarA)--{-| Extracts all 'accessors' from a variable expression e.g.,- @varExprToAccess@ on the syntax tree coming from @a(i, j)@ returns a list of @[VarA "a", VarA "i", VarA "j"]@ -}-varExprToAccesses :: Expr a -> [Access]-varExprToAccesses (Var _ _ ves) = [mkAccess v es | (VarName _ v, es) <- ves, all isConstant es]- where mkAccess v [] = VarA v- mkAccess v es = ArrayA v (map (fmap (const ())) es)-varExprToAccesses _ = []---class Successors t where- {-| Computes the 'root' successor from the current -}- successorsRoot :: t a -> [t a]- {-| Computes the successors nodes of a CFG (described by a zipper) for certain node types -}- successors :: (Eq a, Typeable a) => Zipper (ProgUnit a) -> [t a]--instance Successors Fortran where- successorsRoot (FSeq _ _ f1 f2) = [f1]- successorsRoot (For _ _ _ _ _ _ f) = [f]- successorsRoot (If _ _ _ f efs f') = [f]- successorsRoot (Forall _ _ _ f) = [f]- successorsRoot (Where _ _ _ f Nothing) = [f]- successorsRoot (Where _ _ _ f (Just f')) = [f, f']- successorsRoot (Label _ _ _ f) = [f]- successorsRoot _ = []-- successors =- successorsF- where- successorsF :: forall a . (Eq a, Typeable a) => Zipper (ProgUnit a) -> [Fortran a]- successorsF z = maybe [] id- (do f <- (getHole z)::(Maybe (Fortran a))- ss <- return $ successorsRoot f- return $ ss ++ seekUp f (Just z))-- seekUp :: forall a . (Eq a, Typeable a) => Fortran a -> Maybe (Zipper (ProgUnit a)) -> [Fortran a]- seekUp f z = case (z >>= up >>= getHole)::(Maybe (Fortran a)) of- Just uf ->- case uf of- (FSeq _ _ f1 f2) -> if (f == f1) then [f2]- else seekUp uf (z >>= up)- (For _ _ _ _ _ _ f') -> seekUp uf (z >>= up)- (If _ _ _ gf efs f') -> if (f == gf) then (maybe [] (:[]) f') ++ (map snd efs)- else seekUp uf (z >>= up)- (Forall _ _ _ f') -> seekUp uf (z >>= up)- (Where _ _ _ f' _) -> seekUp uf (z >>= up)- (Label _ _ _ f') -> seekUp uf (z >>= up)- _ -> []- Nothing -> []---{-| extract all 'right-hand side' expressions e.g.- @rhsExpr (parse "x = e") = parse "e"@ -}-rhsExpr :: Fortran Annotation -> [Expr Annotation]-rhsExpr (Assg _ _ _ e2) = (universeBi e2)::[Expr Annotation]--rhsExpr (For _ _ v e1 e2 e3 _) = ((universeBi e1)::[Expr Annotation]) ++- ((universeBi e2)::[Expr Annotation]) ++- ((universeBi e3)::[Expr Annotation])--rhsExpr (If _ _ e f1 fes f3) = ((universeBi e)::[Expr Annotation])--rhsExpr (Allocate x sp e1 e2) = ((universeBi e1)::[Expr Annotation]) ++- ((universeBi e2)::[Expr Annotation])--rhsExpr (Call _ _ e as) = ((universeBi e)::[Expr Annotation]) ++- ((universeBi as)::[Expr Annotation])--rhsExpr (Deallocate _ _ es e) = (concatMap (\e -> (universeBi e)::[Expr Annotation]) es) ++- ((universeBi e)::[Expr Annotation])--rhsExpr (Forall _ _ (es, e) f) = concatMap (\(_, e1, e2, e3) -> -- TODO: maybe different here- ((universeBi e1)::[Expr Annotation]) ++- ((universeBi e2)::[Expr Annotation]) ++- ((universeBi e3)::[Expr Annotation])) es ++- ((universeBi e)::[Expr Annotation])--rhsExpr (Nullify _ _ es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es--rhsExpr (Inquire _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es-rhsExpr (Stop _ _ e) = (universeBi e)::[Expr Annotation]-rhsExpr (Where _ _ e f _) = (universeBi e)::[Expr Annotation]--rhsExpr (Write _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es--rhsExpr (PointerAssg _ _ _ e2) = (universeBi e2)::[Expr Annotation]--rhsExpr (Return _ _ e) = (universeBi e)::[Expr Annotation]-rhsExpr (Print _ _ e es) = ((universeBi e)::[Expr Annotation]) ++- (concatMap (\e -> (universeBi e)::[Expr Annotation]) es)-rhsExpr (ReadS _ _ s es) = concatMap (\e -> (universeBi e)::[Expr Annotation]) es--- rhsExpr (Label x sp s f) = rhsExpr f-rhsExpr _ = []--{-| extract all 'left-hand side' expressions e.g.- @rhsExpr (parse "x = e") = parse "x"@ -}-lhsExpr :: Fortran Annotation -> [Expr Annotation]-lhsExpr (Assg _ _ e1 e2) = ((universeBi e1)::[Expr Annotation])-lhsExpr (For x sp v e1 e2 e3 fs) = [Var x sp [(v, [])]]-lhsExpr (PointerAssg _ _ e1 e2) = ((universeBi e1)::[Expr Annotation])-lhsExpr t = concatMap lhsExpr ((children t)::[Fortran Annotation])----- * Various simple analyses--{-| Set a default monoid instances for Int -}-instance Monoid Int where- mempty = 0- mappend = (+)---{-| Numbers all the statements in a program unit (successively) which is useful for analysis output -}-numberStmts :: ProgUnit Annotation -> ProgUnit Annotation-numberStmts x = let- numberF :: Fortran Annotation -> State Int (Fortran Annotation)- numberF = descendBiM number'-- numberD :: Decl Annotation -> State Int (Decl Annotation)- numberD = descendBiM number'-- number' :: Annotation -> State Int Annotation- -- actually numbers more than just statements, but this doesn't matter- number' x = do n <- get- put (n + 1)- return $ x { number = n }-- (x', n) = runState (descendBiM numberD x) 0- (x'', _) = runState (descendBiM numberF x') n-- in x''--{-| All variables from a Fortran syntax tree -}-variables f = nub $ map (map toLower) $ [v | (AssgExpr _ _ v _) <- (universeBi f)::[Expr Annotation]]- ++ [v | (VarName _ v) <- (universeBi f)::[VarName Annotation]]--{-| A predicate on whether an expression is actually a constant constructor -}-isConstant :: Expr p -> Bool-isConstant (Con _ _ _) = True-isConstant (ConL _ _ _ _) = True-isConstant (ConS _ _ _) = True-isConstant _ = False--{-| Free-variables in a piece of Fortran syntax -}-freeVariables :: (Data (t a), Data a) => t a -> [String]-freeVariables f = (variables f) \\ (binders f)--{-| All variables from binders -}-binders :: forall a t . (Data (t a), Typeable (t a), Data a, Typeable a) => t a -> [String]-binders f = nub $- [v | (ArgName _ v) <- (universeBi f)::[ArgName a]]- ++ [v | (VarName _ v) <- (universeBi ((universeBi f)::[Decl a]))::[VarName a]]- ++ [v | (For _ _ (VarName _ v) _ _ _ _) <- (universeBi f)::[Fortran a]]---{-| Tests whether an expression is an affine transformation (without scaling)- on some variable, if so returns the variable and the translation factor -}-affineMatch (Bin _ _ (Plus _) (Var _ _ [(VarName _ v, _)]) (Con _ _ n)) = Just (v, read n)-affineMatch (Bin _ _ (Plus _) (Con _ _ n) (Var _ _ [(VarName _ v, _)])) = Just (v, read n)-affineMatch (Bin _ _ (Minus _) (Var _ _ [(VarName _ v, _)]) (Con _ _ n)) = Just (v, - read n)-affineMatch (Bin _ _ (Minus _) (Con _ _ n) (Var _ _ [(VarName _ v, _)])) = Just (v, - read n)-affineMatch (Var _ _ [(VarName _ v, _)]) = Just (v, 0)-affineMatch _ = Nothing----- * An embedded domain-specific language for describing syntax tree queries--{-| 'QueryCmd' provides 'commands' of which pieces of syntax to find -}--data QueryCmd t where- Exprs :: QueryCmd (Expr Annotation)- Blocks :: QueryCmd (Block Annotation)- Decls :: QueryCmd (Decl Annotation)- Locs :: QueryCmd Access- Vars :: QueryCmd (Expr Annotation)--{-| 'from' takes a command as its first parameter, a piece of syntax as its second, and- returns all pieces of syntax matching the query request.-- For example: @from Decls x@ returns a list of all declarations in @x@, of type @[Decl Annotation]@- If @x@ is itself a declaration then this is returned as well (so be careful with recursive functions- over things defined in turns of 'from'. See 'topFrom' for a solution to this.--}-from :: forall t synTyp . (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp]-from Locs x = accesses x-from Vars x = [v | v@(Var _ _ _) <- (universeBi x)::[Expr Annotation]]-from _ x = (universeBi x)::[synTyp]--{-| 'topFrom' takes a command as first parameter, a piece of syntax as its second, and- returns all pieces of syntax matching the query request that are *children* of the current- piece of syntax. This means that it will not return itself. -}--topFrom :: forall t synTyp . (Data t, Data synTyp) => QueryCmd synTyp -> t -> [synTyp]-topFrom Locs x = accesses x-topFrom _ x = (childrenBi x)::[synTyp]
− src/Camfort/Analysis/Types.hs
@@ -1,109 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Camfort.Analysis.Types where--import Data.List-import Data.Char-import Data.Data-import Control.Monad.State.Lazy--import Data.Generics.Uniplate.Operations--import Camfort.Analysis.Syntax-import Language.Fortran--import Debug.Trace--type TypeEnv t = [(Variable, Type t)]-type TypeEnvStack t = [TypeEnv t] -- stack of environments--typeAnnotations :: (Show a, Typeable a, Data a) => Program a -> State (TypeEnv a) (Program a)-typeAnnotations = mapM (descendBiM buildTypeEnv)--typeEnv :: (Show a, Typeable a, Data a) => Block a -> TypeEnv a-typeEnv x = snd $ runState (buildTypeEnv x) []--tenvLookup :: Variable -> TypeEnv t -> Maybe (Type t)-tenvLookup v = lookup (lowercase v)---buildTypeEnv :: (Show a, Typeable a, Data a) => Block a -> State (TypeEnv a) (Block a)-buildTypeEnv x = do tenv <- get- tenv' <- return $ gtypes x- put (tenv ++ tenv')- return x--eqType :: Variable -> Variable -> TypeEnv t -> Bool-eqType v1 v2 vs = case lookup v1 vs of- Nothing -> False- Just t1 -> case lookup v2 vs of- Nothing -> False- Just t2 -> (AnnotationFree t1 == AnnotationFree t2)---gtypes :: forall a t . (Show a, Data (t a), Typeable (t a), Data a, Typeable a) => t a -> TypeEnv a-gtypes x = let decAndTypes :: [([(Expr a, Expr a, Maybe Int)], Type a)]- decAndTypes = [(d, t) | (Decl _ _ d t) <- (universeBi x)::[Decl a]]- in concatMap (\(d, t) ->- [(lowercase v, toArrayType t es)- | (Var _ _ vs, _, _) <- d, (VarName _ v, es) <- vs]) decAndTypes--lowercase = map toLower--quicktest t = case t of- (ArrayT _ _ _ _ _ _) -> True- _ -> False--isArrayType :: (TypeEnv t) -> Variable -> Bool-isArrayType env v = case (lookup v env) of- Nothing -> False -- probably a primitive- Just t -> case t of- (ArrayT _ _ _ _ _ _) -> True- (BaseType _ _ attrs _ _) -> any (\x -> case x of Dimension _ _ -> True- _ -> False) attrs- -- _ -> False -- overlap--toArrayType (BaseType x b as e1 e2) es- | boundsP es = ArrayT x (bounds es) b as e1 e2- | otherwise = BaseType x b as e1 e2-toArrayType t es = t--arrayElementType :: Type p -> Type p-arrayElementType (ArrayT a dims t attrs kind len) = BaseType a t attrs kind len-arrayElementType t = t--boundsP [] = False-boundsP ((Bound _ _ _ _):es) = True || (boundsP es)-boundsP _ = False--bounds [] = []-bounds ((Bound _ _ e1 e2):es) = (e1, e2) : (bounds es)-bounds _ = error "Bound expression is of the wrong form"---{- OLD- predBounds [] = False- predBounds [(Bound _ _ _)] = True- predBounds ((Bound _ _ _):bs) = True || predBounds bs- predBounds _ = False-- declsWithBounds :: forall a . (Data a, Typeable a) => [Program a] -> [String]- declsWithBounds x = [v | (VarName _ v, b) <- (universeBi ((universeBi x)::[Decl a]))::[(VarName a, [Expr a])], predBounds b]---}
src/Camfort/Functionality.hs view
@@ -27,39 +27,30 @@ import System.Console.GetOpt import System.Directory import System.Environment+import System.FilePath import System.IO import Data.Monoid import Data.Generics.Uniplate.Operations+import Data.Data+import Data.List (foldl', intercalate)+import qualified Debug.Trace as D import Camfort.Analysis.Annotations-import Camfort.Analysis.Types-import Camfort.Analysis.LVA import Camfort.Analysis.Simple-import Camfort.Analysis.Syntax- import Camfort.Transformation.DeadCode import Camfort.Transformation.CommonBlockElim-import Camfort.Transformation.CommonBlockElimToCalls import Camfort.Transformation.EquivalenceElim-import Camfort.Transformation.DerivedTypeIntro import qualified Camfort.Specification.Units as LU import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad +import Camfort.Helpers.Syntax import Camfort.Helpers import Camfort.Output import Camfort.Input -import Data.Data-import Data.List (foldl', nub, (\\), elemIndices, intersperse, intercalate)--import qualified Data.ByteString.Char8 as B-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)-import Data.Text.Encoding.Error (replace)---- FORPAR related imports import qualified Language.Fortran.Parser.Any as FP import qualified Language.Fortran.AST as F import Language.Fortran.Analysis.Renaming@@ -67,8 +58,6 @@ import Language.Fortran.Analysis(initAnalysis) import qualified Camfort.Specification.Stencils as Stencils -import qualified Debug.Trace as D- -- CamFort optional flags data Flag = Version | Input String@@ -76,7 +65,9 @@ | Excludes String | Literals LiteralsOpt | StencilInferMode Stencils.InferMode- | Debug deriving (Data, Show)+ | Doxygen+ | Ford+ | Debug deriving (Data, Show, Eq) type Options = [Flag] @@ -84,174 +75,85 @@ instance Default String where defaultValue = "" getExcludes :: Options -> String-getExcludes xs = getOption xs+getExcludes = getOption -- * Wrappers on all of the features-typeStructuring inSrc excludes outSrc _ = do- putStrLn $ "Introducing derived data types in " ++ show inSrc ++ "\n"- report <- doRefactor typeStruct inSrc excludes outSrc- putStrLn report- ast d excludes f _ = do- xs <- readForparseSrcDir (d ++ "/" ++ f) excludes- putStrLn $ show (map (\(_, _, p) -> p) xs)--asts inSrc excludes _ _ = do- putStrLn $ "Do a basic analysis and output the HTML files "- ++ "with AST information for " ++ show inSrc ++ "\n"- let astAnalysis = (map numberStmts) . map (fmap (const unitAnnotation))- doAnalysis astAnalysis inSrc excludes+ xs <- readParseSrcDir (d ++ "/" ++ f) excludes+ print (map (\(_, _, p) -> p) xs) countVarDecls inSrc excludes _ _ = do- putStrLn $ "Counting variable declarations in " ++ show inSrc ++ "\n"- doAnalysisSummaryForpar countVariableDeclarations inSrc excludes Nothing--lvaA inSrc excludes _ _ = do- putStrLn $ "Analysing loops for " ++ show inSrc ++ "\n"- doAnalysis lva inSrc excludes+ putStrLn $ "Counting variable declarations in '" ++ inSrc ++ "'"+ doAnalysisSummary countVariableDeclarations inSrc excludes Nothing dead inSrc excludes outSrc _ = do- putStrLn $ "Eliminating dead code in " ++ show inSrc ++ "\n"- report <- doRefactor ((mapM (deadCode False))) inSrc excludes outSrc- putStrLn report--commonToArgs inSrc excludes outSrc _ = do- putStrLn $ "Refactoring common blocks in " ++ show inSrc ++ "\n"- report <- doRefactor (commonElimToCalls inSrc) inSrc excludes outSrc+ putStrLn $ "Eliminating dead code in '" ++ inSrc ++ "'"+ report <- doRefactor (mapM (deadCode False)) inSrc excludes outSrc putStrLn report common inSrc excludes outSrc _ = do- putStrLn $ "Refactoring common blocks in " ++ show inSrc ++ "\n"- report <- doRefactor (commonElimToModules inSrc) inSrc excludes outSrc+ putStrLn $ "Refactoring common blocks in '" ++ inSrc ++ "'"+ isDir <- isDirectory inSrc+ let dir = if isDir then inSrc ++ "/" else ""+ let rfun = commonElimToModules (takeDirectory outSrc ++ "/")+ report <- doRefactorAndCreate rfun inSrc excludes outSrc putStrLn report equivalences inSrc excludes outSrc _ = do- putStrLn $ "Refactoring equivalences blocks in " ++ show inSrc ++ "\n"+ putStrLn $ "Refactoring equivalences blocks in '" ++ inSrc ++ "'" report <- doRefactor (mapM refactorEquivalences) inSrc excludes outSrc putStrLn report {- Units feature -} optsToUnitOpts :: [Flag] -> UnitOpts-optsToUnitOpts = foldl' (\ o f -> case f of Literals m -> o { uoLiterals = m }; Debug -> o { uoDebug = True }) unitOpts0+optsToUnitOpts = foldl' (\ o f -> case f of Literals m -> o { uoLiterals = m }+ Debug -> o { uoDebug = True }+ _ -> o) unitOpts0 unitsCheck inSrc excludes outSrc opt = do- putStrLn $ "Checking units for " ++ show inSrc ++ "\n"- doAnalysisReportForpar (mapM (LU.checkUnits (optsToUnitOpts opt))) inSrc excludes outSrc+ putStrLn $ "Checking units for '" ++ inSrc ++ "'"+ let rfun = concatMap (LU.checkUnits (optsToUnitOpts opt))+ doAnalysisReport rfun putStrLn inSrc excludes unitsInfer inSrc excludes outSrc opt = do- putStrLn $ "Inferring units for " ++ show inSrc ++ "\n"- doAnalysisReportForpar (mapM (LU.inferUnits (optsToUnitOpts opt))) inSrc excludes outSrc+ putStrLn $ "Inferring units for '" ++ inSrc ++ "'"+ let rfun = concatMap (LU.inferUnits (optsToUnitOpts opt))+ doAnalysisReport rfun putStrLn inSrc excludes unitsSynth inSrc excludes outSrc opt = do- putStrLn $ "Synthesising units for " ++ show inSrc ++ "\n"- doRefactorForpar (mapM (LU.synthesiseUnits (optsToUnitOpts opt))) inSrc excludes outSrc+ putStrLn $ "Synthesising units for '" ++ inSrc ++ "'"+ let marker+ | Doxygen `elem` opt = '<'+ | Ford `elem` opt = '!'+ | otherwise = '='+ let rfun =+ mapM (LU.synthesiseUnits (optsToUnitOpts opt) marker)+ report <- doRefactor rfun inSrc excludes outSrc+ putStrLn report unitsCriticals inSrc excludes outSrc opt = do- putStrLn $ "Infering critical variables for units inference in directory "- ++ show inSrc ++ "\n"- doAnalysisReportForpar (mapM (LU.inferCriticalVariables (optsToUnitOpts opt))) inSrc excludes outSrc+ putStrLn $ "Suggesting variables to annotate with unit specifications in '"+ ++ inSrc ++ "'"+ let rfun = mapM (LU.inferCriticalVariables (optsToUnitOpts opt))+ doAnalysisReport rfun (putStrLn . fst) inSrc excludes {- Stencils feature -} stencilsCheck inSrc excludes _ _ = do- putStrLn $ "Checking stencil specs for " ++ show inSrc ++ "\n"- doAnalysisSummaryForpar (\f p -> (Stencils.check f p, p)) inSrc excludes Nothing+ putStrLn $ "Checking stencil specs for '" ++ inSrc ++ "'"+ let rfun = \f p -> (Stencils.check f p, p)+ doAnalysisSummary rfun inSrc excludes Nothing stencilsInfer inSrc excludes outSrc opt = do- putStrLn $ "Infering stencil specs for " ++ show inSrc ++ "\n"- doAnalysisSummaryForpar (Stencils.infer (getOption opt)) inSrc excludes (Just outSrc)+ putStrLn $ "Infering stencil specs for '" ++ inSrc ++ "'"+ let rfun = Stencils.infer (getOption opt) '='+ doAnalysisSummary rfun inSrc excludes (Just outSrc) stencilsSynth inSrc excludes outSrc opt = do- putStrLn $ "Synthesising stencil specs for " ++ show inSrc ++ "\n"- doRefactorForpar (Stencils.synth (getOption opt)) inSrc excludes outSrc--stencilsVarFlowCycles inSrc excludes _ _ = do- putStrLn $ "Inferring var flow cycles for " ++ show inSrc ++ "\n"- let flowAnalysis = intercalate ", " . map show . Stencils.findVarFlowCycles- doAnalysisSummaryForpar (\_ p -> (flowAnalysis p , p)) inSrc excludes Nothing------------------------------------------------------- Forpar wrappers--doRefactorForpar :: ([(Filename, F.ProgramFile A)]- -> (String, [(Filename, F.ProgramFile Annotation)]))- -> FileOrDir -> [Filename] -> FileOrDir -> IO ()-doRefactorForpar rFun inSrc excludes outSrc = do- if excludes /= [] && excludes /= [""]- then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes)- ++ " from " ++ inSrc ++ "/"- else return ()- ps <- readForparseSrcDir inSrc excludes- let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)- --let outFiles = filter (\f -> not ((take (length $ d ++ "out") f) == (d ++ "out"))) (map fst ps')- --let outFiles = map fst ps'- putStrLn report- let outputs = mkOutputFileForpar ps ps'- outputFiles inSrc outSrc outputs- where snd3 (a, b, c) = b--mkOutputFileForpar :: [(Filename, SourceText, a)]- -> [(Filename, F.ProgramFile Annotation)]- -> [(Filename, SourceText, F.ProgramFile Annotation)]-mkOutputFileForpar ps ps' = zip3 (map fst ps') (map snd3 ps) (map snd ps')- where- snd3 (a, b, c) = b-----{-| Performs an analysis which reports to the user,- but does not output any files -}-doAnalysisReportForpar :: ([(Filename, F.ProgramFile A)] -> (String, t1))- -> FileOrDir -> [Filename] -> t -> IO ()-doAnalysisReportForpar rFun inSrc excludes outSrc = do- if excludes /= [] && excludes /= [""]- then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes)- ++ " from " ++ inSrc ++ "/"- else return ()- ps <- readForparseSrcDir inSrc excludes------ let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)- putStrLn report--------- * Source directory and file handling-readForparseSrcDir :: FileOrDir -> [Filename]- -> IO [(Filename, SourceText, F.ProgramFile A)]-readForparseSrcDir inp excludes = do- isdir <- isDirectory inp- files <- if isdir- then do files <- rGetDirContents inp- return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes- else return [inp]- mapM readForparseSrcFile files-------{-| Read a specific file, and parse it -}-readForparseSrcFile :: Filename -> IO (Filename, SourceText, F.ProgramFile A)-readForparseSrcFile f = do- inp <- flexReadFile f- let ast = FP.fortranParser inp f- return $ (f, inp, fmap (const unitAnnotation) ast)-------doAnalysisSummaryForpar :: (Monoid s, Show' s) => (Filename -> F.ProgramFile A -> (s, F.ProgramFile A))- -> FileOrDir -> [Filename] -> Maybe FileOrDir -> IO ()-doAnalysisSummaryForpar aFun inSrc excludes outSrc = do- if excludes /= [] && excludes /= [""]- then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes)- ++ " from " ++ inSrc ++ "/"- else return ()- ps <- readForparseSrcDir inSrc excludes- let (out, ps') = callAndSummarise aFun ps- putStrLn "Output of the analysis:"- putStrLn . show' $ out--callAndSummarise aFun ps = do- foldl' (\(n, pss) (f, _, ps) -> let (n', ps') = aFun f ps- in (n `mappend` n', ps' : pss)) (mempty, []) ps---------- | Read file using ByteString library and deal with any weird characters.-flexReadFile :: String -> IO B.ByteString-flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile+ putStrLn $ "Synthesising stencil specs for '" ++ inSrc ++ "'"+ let marker+ | Doxygen `elem` opt = '<'+ | Ford `elem` opt = '!'+ | otherwise = '='+ let rfun = Stencils.synth (getOption opt) marker+ report <- doRefactor rfun inSrc excludes outSrc+ putStrLn report
src/Camfort/Helpers.hs view
@@ -13,27 +13,33 @@ See the License for the specific language governing permissions and limitations under the License. -}-{-# LANGUAGE TypeOperators, PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} module Camfort.Helpers where +import GHC.Generics+import Data.Generics.Zipper+import Data.Generics.Aliases+import Data.Generics.Str+import Data.Generics.Uniplate.Operations+import Data.Data+import Data.Maybe+import Data.Monoid import Data.List (elemIndices, group, sort, nub) import qualified Data.ByteString.Char8 as B import System.Directory-import Language.Fortran import Data.List (union) import qualified Data.Map.Lazy as Map hiding (map, (\\))+import Control.Monad.Writer.Strict -- collect: from an association list to a map with list-based bins for matching keys collect :: (Eq a, Ord k) => [(k, a)] -> Map.Map k [a] collect = Map.fromListWith union . map (fmap (:[])) -lineCol :: SrcLoc -> (Int, Int)-lineCol s = (srcLine s, srcColumn s)--spanLineCol :: SrcSpan -> ((Int, Int), (Int, Int))-spanLineCol (l, u) = (lineCol l, lineCol u)- type Filename = String type Directory = String type SourceText = B.ByteString@@ -57,9 +63,7 @@ isDirectory :: FileOrDir -> IO Bool isDirectory s = doesDirectoryExist s - -- Helpers- fanout :: (a -> b) -> (a -> c) -> a -> (b, c) fanout f g x = (f x, g x) @@ -136,3 +140,42 @@ normaliseBy :: Ord t => (t -> t -> Maybe t) -> [t] -> [t] normaliseBy plus = nub . (foldPair plus) . sort +#if __GLASGOW_HASKELL__ < 800+instance Monoid x => Monad ((,) x) where+ return a = (mempty, a)+ (x, a) >>= k = let (x', b) = k a+ in (mappend x x', b)+#endif++-- Data-type generic reduce traversal+reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a]+reduceCollect k x = execWriter (transformBiM (\y -> do case k y of+ Just x -> tell [x]+ Nothing -> return ()+ return y) x)++-- Data-type generic comonad-style traversal with zipper (contextual traversal)+everywhere :: (Zipper a -> Zipper a) -> Zipper a -> Zipper a+everywhere k z = everywhere' z+ where+ everywhere' = enterRight . enterDown . k++ enterDown z =+ case (down' z) of+ Just dz -> let dz' = everywhere' dz+ in case (up $ dz') of+ Just uz -> uz+ Nothing -> dz'+ Nothing -> z++ enterRight z =+ case (right z) of+ Just rz -> let rz' = everywhere' rz+ in case (left $ rz') of+ Just lz -> lz+ Nothing -> rz'+ Nothing -> z+++zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a)+zfmap f x = zeverywhere (mkT f) x
+ src/Camfort/Helpers/Syntax.hs view
@@ -0,0 +1,127 @@+{-+ Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}++{-|++This module provides a number of helper functions for working with Fortran+syntax that are useful between different analyses and transformations.++-}+module Camfort.Helpers.Syntax where++-- Standard imports+import Data.Char+import Data.List+import Data.Monoid+import Control.Monad.State.Lazy+import Debug.Trace++-- Data-type generics imports+import Data.Data+import Data.Generics.Uniplate.Data+import Data.Generics.Uniplate.Operations+import Data.Generics.Zipper+import Data.Typeable++-- CamFort specific functionality+import Camfort.Analysis.Annotations++import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Util.Position as FU+import Language.Fortran.Util.FirstParameter+import Language.Fortran.Util.SecondParameter++-- * Comparison and ordering++{-| 'AnnotationFree' is a data type that wraps other types and denotes terms+ which should be compared for equality modulo their annotations and source+ location information -}+data AnnotationFree t = AnnotationFree { annotationBound :: t } deriving Show++{-| short-hand constructor for 'AnnotationFree' -}+af = AnnotationFree+{-| short-hand deconstructor for 'AnnotationFree' -}+unaf = annotationBound++-- variable renaming helpers+caml (x:xs) = toUpper x : xs+lower = map toLower++-- Here begins varioous 'Eq' instances for instantiations of 'AnnotationFree'++instance Eq (AnnotationFree a) => Eq (AnnotationFree [a]) where+ (AnnotationFree xs) == (AnnotationFree xs') =+ if length xs == length xs'+ then foldl (\b (x, x') -> (af x == af x') && b) True (zip xs xs')+ else False++instance (Eq (AnnotationFree a), Eq (AnnotationFree b))+ => Eq (AnnotationFree (a, b)) where++ (AnnotationFree (x, y)) == (AnnotationFree (x', y')) =+ (af x == af x') && (af y == af y')++instance Eq a => Eq (AnnotationFree (F.Expression a)) where+ (AnnotationFree x) == (AnnotationFree y) = x'' == y''+ where x' = fmap (const ()) x+ y' = fmap (const ()) y+ y'' = transformBi setSpanConst y'+ x'' = transformBi setSpanConst x'+ setSpanConst :: FU.SrcSpan -> FU.SrcSpan+ setSpanConst (FU.SrcSpan _ _) = FU.SrcSpan pos0 pos0+ where pos0 = FU.Position 0 0 0++instance Eq (AnnotationFree F.BaseType) where+ (AnnotationFree x) == (AnnotationFree y) = x == y++-- * Accessor functions for extracting various pieces of information+-- out of syntax trees+{-| Extracts a string of the (root) variable name from an expression,+ e.g., extractVariable "v" = Just v+ extractVariable "v(i)" = Just v -}+extractVariable :: F.Expression a -> Maybe F.Name+extractVariable (F.ExpValue _ _ (F.ValVariable v)) = Just v+extractVariable (F.ExpSubscript _ _ e _) = extractVariable e+extractVariable _ = Nothing++{-| Set a default monoid instances for Int -}+instance Monoid Int where+ mempty = 0+ mappend = (+)++-- SrcSpan helpers++dropLine :: FU.SrcSpan -> FU.SrcSpan+dropLine (FU.SrcSpan s1 (FU.Position o c l)) =+ FU.SrcSpan s1 (FU.Position o 0 (l+1))++deleteLine :: FU.SrcSpan -> FU.SrcSpan+deleteLine (FU.SrcSpan (FU.Position ol cl ll) (FU.Position ou cu lu)) =+ FU.SrcSpan (FU.Position ol (cl-1) ll) (FU.Position ou 0 (lu+1))++linesCovered :: FU.Position -> FU.Position -> Int+linesCovered (FU.Position _ _ l1) (FU.Position _ _ l2) = l2 - l1 + 1++toCol0 (FU.Position o c l) = FU.Position o 0 l++afterAligned :: FU.SrcSpan -> FU.Position+afterAligned (FU.SrcSpan (FU.Position o cA lA) (FU.Position _ cB lB)) =+ FU.Position o cA (lB+1)
src/Camfort/Input.hs view
@@ -26,28 +26,23 @@ module Camfort.Input where --- FIXME: Did enough to get this module to compile, it's not optimised to use ByteString.-import qualified Data.ByteString.Char8 as B-import qualified Language.Fortran.Parser as Fortran-import Language.Fortran.PreProcess-import Language.Fortran--import Data.Monoid-import Data.Generics.Uniplate.Operations import Camfort.Analysis.Annotations--import Language.Haskell.ParseMonad-import qualified Language.Haskell.Syntax as LHS--import System.Directory- import Camfort.Helpers import Camfort.Output-import Camfort.Traverse +import qualified Language.Fortran.Parser.Any as FP+import qualified Language.Fortran.AST as F++import qualified Data.ByteString.Char8 as B import Data.Data-import Data.List (nub, (\\), elemIndices, intersperse)+import Data.Generics.Uniplate.Operations+import Data.List (foldl', nub, (\\), elemIndices, intercalate)+import Data.Monoid+import Data.Text.Encoding.Error (replace)+import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import System.Directory+ -- Class for default values of some type 't' class Default t where defaultValue :: t@@ -63,147 +58,137 @@ -- * Builders for analysers and refactorings -{-| Performs an analysis provided by its first parameter on the directory of its- second, excluding files listed by its third -}-doAnalysis :: (Program A -> Program Annotation)- -> FileOrDir -> [Filename] -> IO ()-doAnalysis aFun src excludes = do- if excludes /= [] && excludes /= [""]- then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes)- ++ " from " ++ src ++ "/"- else return ()-- ps <- readParseSrcDir src excludes-- let inFiles = map Fortran.fst3 ps- let outFiles = filter (\f -> not ((take (length $ src ++ "out") f) == (src ++ "out"))) inFiles- let asts' = map (\(f, _, ps) -> aFun ps) ps- outputAnalysisFiles src asts' outFiles- {-| Performs an analysis provided by its first parameter which generates information 's', which is then combined together (via a monoid) -}-doAnalysisSummary :: (Monoid s, Show s)- => (Program A -> s) -> FileOrDir -> [Filename] -> IO ()-doAnalysisSummary aFun d excludes = do+doAnalysisSummary :: (Monoid s, Show' s) => (Filename -> F.ProgramFile A -> (s, F.ProgramFile A))+ -> FileOrDir -> [Filename] -> Maybe FileOrDir -> IO ()+doAnalysisSummary aFun inSrc excludes outSrc = do if excludes /= [] && excludes /= [""]- then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes)- ++ " from " ++ d ++ "/"- else return ()+ then putStrLn $ "Excluding " ++ intercalate "," excludes+ ++ " from " ++ inSrc ++ "/"+ else return ()+ ps <- readParseSrcDir inSrc excludes+ let (out, ps') = callAndSummarise aFun ps+ putStrLn . show' $ out - ps <- readParseSrcDir d excludes+callAndSummarise aFun =+ foldl' (\(n, pss) (f, _, ps) -> let (n', ps') = aFun f ps+ in (n `mappend` n', ps' : pss)) (mempty, []) - let inFiles = map Fortran.fst3 ps- putStrLn "Output of the analysis:"- putStrLn $ show $ Prelude.foldl (\n (f, _, ps) -> n `mappend` (aFun ps)) mempty ps {-| Performs an analysis which reports to the user, but does not output any files -}-doAnalysisReport :: ([(Filename, Program A)] -> (String, t1))- -> FileOrDir -> [Filename] -> t -> IO ()-doAnalysisReport rFun inSrc excludes outSrc = do- if excludes /= [] && excludes /= [""]- then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes)- ++ " from " ++ inSrc ++ "/"- else return ()- ps <- readParseSrcDir inSrc excludes- putStr "\n"- let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)- putStrLn report---- Temporary doAnalysisReport version to make it work with Units-Of-Measure--- glue code.-doAnalysisReport' :: ([(Filename, Program A)] -> (String, t1))- -> FileOrDir -> [Filename] -> t -> IO ()-doAnalysisReport' rFun inSrc excludes outSrc = do+doAnalysisReport :: ([(Filename, F.ProgramFile A)] -> r)+ -> (r -> IO out)+ -> FileOrDir -> [Filename] -> IO out+doAnalysisReport rFun sFun inSrc excludes = do if excludes /= [] && excludes /= [""]- then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes)- ++ " from " ++ inSrc ++ "/"- else return ()+ then putStrLn $ "Excluding " ++ intercalate "," excludes+ ++ " from " ++ inSrc ++ "/"+ else return () ps <- readParseSrcDir inSrc excludes- putStr "\n"- let (report, ps') = rFun (map (\(a, b, c) -> (a, c)) ps)- putStrLn report+----+ let report = rFun (map (\(f, inp, ast) -> (f, ast)) ps)+ sFun report+---- {-| Performs a refactoring provided by its first parameter, on the directory of the second, excluding files listed by third, output to the directory specified by the fourth parameter -}-doRefactor :: ([(Filename, Program A)]- -> (String, [(Filename, Program Annotation)]))- -> FileOrDir -> [Filename] -> FileOrDir -> IO String++-- Refactoring where just a single list of filename/program file+-- pairs is returned (the case when no files are being added)+doRefactor ::+ ([(Filename, F.ProgramFile A)] -> (String, [(Filename, F.ProgramFile A)]))+ -> FileOrDir -> [Filename] -> FileOrDir -> IO String doRefactor rFun inSrc excludes outSrc = do- if excludes /= [] && excludes /= [""]- then putStrLn $ "Excluding " ++ (concat $ intersperse "," excludes)- ++ " from " ++ inSrc ++ "/"- else return ()+ if excludes /= [] && excludes /= [""]+ then putStrLn $ "Excluding " ++ intercalate "," excludes+ ++ " from " ++ inSrc ++ "/"+ else return ()+ ps <- readParseSrcDir inSrc excludes+ let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)+ let outputs = reassociateSourceText ps ps'+ outputFiles inSrc outSrc outputs+ return report - ps <- readParseSrcDir inSrc excludes- let (report, ps') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)- --let outFiles = filter (\f -not ((take (length $ d ++ "out") f) == (d ++ "out"))) (map fst ps')- let outFiles = map fst ps'- let outData = zip3 outFiles (map (B.pack . Fortran.snd3) ps) (map snd ps')- outputFiles inSrc outSrc outData- return report+-- For refactorings which create some files too+-- i.e., for refactoring functions that return a+-- pair of lists of filename/program file pairs is+doRefactorAndCreate ::+ ([(Filename, F.ProgramFile A)]+ -> (String, [(Filename, F.ProgramFile A)], [(Filename, F.ProgramFile A)]))+ -> FileOrDir -> [Filename] -> FileOrDir -> IO String+doRefactorAndCreate rFun inSrc excludes outSrc = do+ if excludes /= [] && excludes /= [""]+ then putStrLn $ "Excluding " ++ intercalate "," excludes+ ++ " from " ++ inSrc ++ "/"+ else return ()+ ps <- readParseSrcDir inSrc excludes+ let (report, ps', ps'') = rFun (map (\(f, inp, ast) -> (f, ast)) ps)+ let outputs = reassociateSourceText ps ps'+ let outputs' = map (\(f, pf) -> (f, B.empty, pf)) ps''+ outputFiles inSrc outSrc outputs+ outputFiles inSrc outSrc outputs'+ return report +reassociateSourceText :: [(Filename, SourceText, a)]+ -> [(Filename, F.ProgramFile Annotation)]+ -> [(Filename, SourceText, F.ProgramFile Annotation)]+reassociateSourceText ps ps' = zip3 (map fst ps') (map snd3 ps) (map snd ps')+ where snd3 (a, b, c) = b+ -- * Source directory and file handling {-| Read files from a direcotry, excluding those listed by the second parameter -}-readParseSrcDir :: FileOrDir -> [Filename] -> IO [(Filename, String, Program A)]+-- * Source directory and file handling+readParseSrcDir :: FileOrDir -> [Filename]+ -> IO [(Filename, SourceText, F.ProgramFile A)] readParseSrcDir inp excludes = do isdir <- isDirectory inp- files <- if isdir then do+ files <- if isdir+ then do files <- rGetDirContents inp- return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes+ -- Compute alternate list of excludes with the+ -- the directory appended+ let excludes' = excludes ++ map (\x -> inp ++ "/" ++ x) excludes+ return $ (map (\y -> inp ++ "/" ++ y) files) \\ excludes' else return [inp] mapM readParseSrcFile files +{-| Read a specific file, and parse it -}+readParseSrcFile :: Filename -> IO (Filename, SourceText, F.ProgramFile A)+readParseSrcFile f = do+ inp <- flexReadFile f+ let ast = FP.fortranParser inp f+ return (f, inp, fmap (const unitAnnotation) ast)+----+ rGetDirContents :: FileOrDir -> IO [String] rGetDirContents d = do ds <- getDirectoryContents d- ds' <- return $ ds \\ [".", ".."] -- remove '.' and '..' entries+ let ds' = ds \\ [".", ".."] -- remove '.' and '..' entries rec ds' where- rec [] = return $ []+ rec [] = return [] rec (x:xs) = do xs' <- rec xs g <- doesDirectoryExist (d ++ "/" ++ x) if g then do x' <- rGetDirContents (d ++ "/" ++ x) return $ (map (\y -> x ++ "/" ++ y) x') ++ xs' else if isFortran x- then return $ x : xs'- else return $ xs'+ then return (x : xs')+ else return xs' {-| predicate on which fileextensions are Fortran files -}-isFortran x = elem (fileExt x) [".f", ".f90", ".f77", ".cmn", ".inc"]--{-| Read a specific file, and parse it -}-readParseSrcFile :: Filename -> IO (Filename, String, Program A)-readParseSrcFile f = do- putStrLn f- inp <- readFile f- ast <- parse f- return $ (f, inp, map (fmap (const unitAnnotation)) ast)----{-| parse file into an un-annotated Fortran AST -}-parse :: Filename -> IO (Program ())-parse f =- let mode = ParseMode { parseFilename = f }- selectedParser = case (fileExt f) of- ".cmn" -> Fortran.include_parser- ".inc" -> Fortran.include_parser- _ -> Fortran.parser-- in do inp <- readFile f- -- There is a temporary fix here of adding a space at the start,- -- this is to deal with an alignment issue in the parser,- -- but will be removed when we move to the new parser.- case runParserWithMode mode selectedParser (' ' : pre_process inp) of- (ParseOk p) -> return $ p- (ParseFailed l e) -> error e+isFortran x = fileExt x `elem` [".f", ".f90", ".f77", ".cmn", ".inc"] {-| extract a filename's extension -} fileExt x = let ix = elemIndices '.' x- in if (length ix == 0) then ""+ in if null ix then "" else Prelude.drop (Prelude.last ix) x++-- | Read file using ByteString library and deal with any weird characters.+flexReadFile :: String -> IO B.ByteString+flexReadFile = fmap (encodeUtf8 . decodeUtf8With (replace ' ')) . B.readFile
src/Camfort/Output.hs view
@@ -14,60 +14,40 @@ limitations under the License. -} -{-# LANGUAGE FlexibleInstances, UndecidableInstances, ImplicitParams, DoAndIfThenElse,- MultiParamTypeClasses, FlexibleContexts, KindSignatures, ScopedTypeVariables,- DeriveGeneric, DeriveDataTypeable #-}--{--- Provides support for outputting source files and analysis information+{-# LANGUAGE FlexibleInstances, UndecidableInstances,+ DoAndIfThenElse, MultiParamTypeClasses, FlexibleContexts,+ ScopedTypeVariables #-} --}+{- Provides support for outputting source files and analysis information -} module Camfort.Output where -import Camfort.Helpers-import Camfort.Traverse- import qualified Language.Fortran.AST as F-import qualified Language.Fortran.Util.Position as FU import qualified Language.Fortran.Analysis as FA--import qualified Language.Fortran.Parser as Fortran-import Language.Fortran-import Language.Fortran.Pretty-import Language.Fortran.PreProcess+import qualified Language.Fortran.PrettyPrint as PP+import qualified Language.Fortran.Util.Position as FU+import qualified Language.Fortran.ParserMonad as FPM import Camfort.Analysis.Annotations-import Camfort.Analysis.Syntax-import Camfort.PrettyPrint import Camfort.Reprint-import Camfort.Transformation.Syntax--import Camfort.Specification.Units.Environment+import Camfort.Helpers+import Camfort.Helpers.Syntax import System.FilePath import System.Directory --- FIXME: Did enough to get this module to compile, it's not optimised to use ByteString. import qualified Data.ByteString.Char8 as B-import Data.Map.Lazy hiding (map, foldl)-import Data.Functor.Identity import Data.Generics-import GHC.Generics+import Data.Functor.Identity import Data.List hiding (zip) import Data.Generics.Uniplate.Data-import Generics.Deriving.Copoint-import Data.Char import Data.Generics.Zipper-import Data.Maybe import Debug.Trace-import Text.Printf+import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.State.Lazy - -- Custom 'Show' which on strings is the identity class Show' s where show' :: s -> String@@ -83,6 +63,7 @@ text (if it exists) and their AST, write these to the directory -} mkOutputText :: FileOrDir -> t -> SourceText outputFile :: t -> Filename+ isNewFile :: t -> Bool outputFiles :: FileOrDir -> FileOrDir -> [t] -> IO () outputFiles inp outp pdata = do@@ -90,174 +71,144 @@ inIsDir <- isDirectory inp inIsFile <- doesFileExist inp if outIsDir then do+ -- Output to a directory, create if missing createDirectoryIfMissing True outp+ -- Report which directory the files are going to putStrLn $ "Writing refactored files to directory: " ++ outp ++ "/"+ -- If the input was a directory then work out the path prefix+ -- which needs to be replaced with the new directory path isdir <- isDirectory inp let inSrc = if isdir then inp else getDir inp- mapM_ (\x -> let f' = changeDir outp inSrc (outputFile x)- in do checkDir f'- putStrLn $ "Writing " ++ f'- B.writeFile f' (mkOutputText outp x)) pdata+ forM_ pdata (\x -> let f' = changeDir outp inSrc (outputFile x)+ in do checkDir f'+ putStrLn $ "Writing " ++ f'+ B.writeFile f' (mkOutputText outp x)) else- if inIsDir || length pdata > 1- then error $ "Error: attempting to output multiple files, but the \- \given output destination is a single file. \n\- \Please specify an output directory"- else- if inIsFile -- Input was just a file, then output just a file- then do- putStrLn $ "Writing refactored file to: " ++ outp- putStrLn $ "Writing " ++ outp- B.writeFile outp (mkOutputText outp (head pdata))+ forM_ pdata (\x -> do+ let out = if isNewFile x then outputFile x else outp+ putStrLn $ "Writing " ++ out+ B.writeFile out (mkOutputText outp x)) - else let outSrc = getDir outp- in do createDirectoryIfMissing True outSrc- putStrLn $ "Writing refactored file to: " ++ outp- putStrLn $ "Writing " ++ outp- B.writeFile outp (mkOutputText outp (head pdata)) +{-| changeDir is used to change the directory of a filename string.+ If the filename string has no directory then this is an identity -}+changeDir newDir oldDir oldFilename =+ newDir ++ listDiffL oldDir oldFilename+ where+ listDiffL [] ys = ys+ listDiffL xs [] = []+ listDiffL (x:xs) (y:ys)+ | x==y = listDiffL xs ys+ | otherwise = ys+ -- When the new source text is already provided instance OutputFiles (Filename, SourceText) where mkOutputText _ (_, output) = output outputFile (f, _) = f--data PR a = PR (Program a) deriving Data--instance PrettyPrint (PR Annotation) where- prettyPrint (PR x) = prettyPrint x---- When there is a file to be reprinted (for refactoring)-instance OutputFiles (Filename, SourceText, Program Annotation) where- mkOutputText f' (f, input, ast') = evalState (reprint refactoringLF (PR ast') input) 0- where- outputFile (f, _, _) = f+ isNewFile (_, inp) = B.null inp -- When there is a file to be reprinted (for refactoring) instance OutputFiles (Filename, SourceText, F.ProgramFile Annotation) where- mkOutputText f' (f, input, ast') = runIdentity $ reprint refactoringForPar ast' input- outputFile (f, _, _) = f--srcSpanToSrcLocs :: FU.SrcSpan -> (SrcLoc, SrcLoc)-srcSpanToSrcLocs (FU.SrcSpan lpos upos) = (toSrcLoc lpos, toSrcLoc upos)- where- toSrcLoc pos = SrcLoc { srcFilename = ""- , srcLine = FU.posLine pos- , srcColumn = FU.posColumn pos }--instance (PrettyPrint (F.ProgramFile Annotation)) where- -- STUB- prettyPrint _ = B.empty--refactoringForPar :: (Typeable a) => a -> SourceText -> StateT SrcLoc Identity (SourceText, Bool)-refactoringForPar z inp =- ((\_ -> return (B.empty, False)) `extQ` (flip outputComments inp)) $ z- where- outputComments :: F.Block Annotation -> SourceText -> StateT SrcLoc Identity (SourceText, Bool)- outputComments e@(F.BlComment ann span comment) inp = do- cursor <- get- if (pRefactored ann)- then let (lb, ub) = srcSpanToSrcLocs span- lb' = leftOne lb- (p0, _) = takeBounds (cursor, lb') inp- nl = if comment == [] then B.empty else B.pack "\n"- in put ub >> return (B.concat [p0, B.pack comment, nl], True)- else return (B.empty, False)- where leftOne (SrcLoc f l c) = SrcLoc f (l-1) (c-1)- outputComments _ _ = return (B.empty, False)---{-| changeDir is used to change the directory of a filename string.- If the filename string has no directory then this is an identity -}-changeDir newDir oldDir oldFilename = newDir ++ (listDiffL oldDir oldFilename)- where listDiffL [] ys = ys- listDiffL xs [] = []- listDiffL (x:xs) (y:ys) | x==y = listDiffL xs ys- | otherwise = ys--{-| output pre-analysis ASTs into the directory with the given file names (the list of ASTs should match the- list of filenames) -}-outputAnalysisFiles :: FileOrDir -> [Program Annotation] -> [Filename] -> IO ()-outputAnalysisFiles src asts files = do- isdir <- isDirectory src- let src' = if isdir then src else dropFileName src- putStrLn $ "Writing analysis files to directory: " ++ src'- mapM (\(ast', f) -> writeFile (f ++ ".html") ((concatMap outputHTML) ast')) (zip asts files)- return ()+ mkOutputText f' (f, input, ast@(F.ProgramFile (F.MetaInfo version) _ _)) =+ -- If we are create a file, call the pretty printer directly+ if B.null input+ then B.pack $ PP.pprintAndRender version ast (Just 0)+ -- Otherwise, applying the refactoring system with reprint+ else runIdentity $ reprint (refactoring version) ast input + outputFile (f, _, _) = f+ isNewFile (_, inp, _) = B.null inp {- Specifies how to do specific refactorings- (uses generic query extension - remember extQ is non-symmetric)--}--refactoringLF :: (Typeable a) => a -> SourceText -> StateT SrcLoc (State Int) (SourceText, Bool)-refactoringLF = flip $ \inp -> ((((\_ -> return (B.empty, False))- `extQ` (refactorUses inp))- `extQ` (refactorDecl inp))- `extQ` (refactorArgName inp))- `extQ` (refactorFortran inp)+ (uses generic query extension - remember extQ is non-symmetric) -} +refactoring :: Typeable a+ => FPM.FortranVersion+ -> a -> SourceText -> StateT FU.Position Identity (SourceText, Bool)+refactoring v z inp = catchAll inp `extQ` refactorings inp $ z+ where+ catchAll :: SourceText -> a -> StateT FU.Position Identity (SourceText, Bool)+ catchAll _ _ = return (B.empty, False)+ refactorings inp z =+ mapStateT (\n -> Identity $ n `evalState` 0) (refactorBlocks v inp z) -refactorFortran :: Monad m => SourceText -> Fortran Annotation -> StateT SrcLoc m (SourceText, Bool)-refactorFortran inp e = do+refactorBlocks :: FPM.FortranVersion+ -> SourceText+ -> F.Block Annotation+ -> StateT FU.Position (State Int) (SourceText, Bool)+-- Output comments+refactorBlocks v inp e@(F.BlComment ann span comment) = do cursor <- get- if (pRefactored $ tag e) then- let (lb, ub) = srcSpan e- (p0, _) = takeBounds (cursor, lb) inp- outE = B.pack $ pprint e- lnl = case e of (NullStmt _ _) -> (if ((p0 /= B.empty) && (B.last p0 /= '\n')) then B.pack "\n" else B.empty)- _ -> B.empty- lnl2 = if ((p0 /= B.empty) && (B.last p0 /= '\n')) then B.pack "\n" else B.empty- textOut = if p0 == (B.pack "\n") then outE else B.concat [p0, lnl2, outE, lnl]- in put ub >> return (textOut, True)- else return (B.empty, False)-+ if pRefactored ann+ then let (FU.SrcSpan lb ub) = span+ lb' = leftOne lb+ (p0, _) = takeBounds (cursor, lb') inp+ nl = if null comment then B.empty else B.pack "\n"+ in put ub >> return (B.concat [p0, B.pack comment, nl], True)+ else return (B.empty, False)+ where leftOne (FU.Position f c l) = FU.Position f (c-1) (l-1) -refactorDecl :: SourceText -> Decl Annotation -> StateT SrcLoc (State Int) (SourceText, Bool)-refactorDecl inp d = do+-- Refactor use statements+refactorBlocks v inp b@(F.BlStatement _ _ _ u@F.StUse{}) = do cursor <- get- if (pRefactored $ tag d) then- let (lb, ub) = srcSpan d- (p0, _) = takeBounds (cursor, lb) inp- textOut = p0 `B.append` (B.pack $ pprint d)- in do textOut' <- -- The following compensates new lines with removed lines- case d of- (NullDecl _ _) ->- do added <- lift get- let diff = linesCovered ub lb- -- remove empty newlines here if extra lines have been added- let (text, removed) = if added <= diff- then removeNewLines textOut added- else removeNewLines textOut diff- lift $ put (added - removed)- return text- otherwise -> return textOut- put ub- return (textOut', True)- else return (B.empty, False)+ case refactored $ F.getAnnotation u of+ Just (FU.Position _ rCol rLine) -> do+ let (FU.SrcSpan lb _) = FU.getSpan u+ let (p0, _) = takeBounds (cursor, lb) inp+ let out = B.pack $ PP.pprintAndRender v b (Just (rCol -1))+ added <- lift get+ when (newNode $ F.getAnnotation u)+ (lift $ put $ added + countLines out)+ put $ toCol0 lb+ return (p0 `B.append` out, True)+ Nothing -> return (B.empty, False) -refactorArgName :: Monad m => SourceText -> ArgName Annotation -> StateT SrcLoc m (SourceText, Bool)-refactorArgName inp a = do- cursor <- get- case (refactored $ tag a) of- Just lb -> do- let (p0, _) = takeBounds (cursor, lb) inp- put lb- return (p0 `B.append` (B.pack $ pprint a), True)- Nothing -> return (B.empty, False)+-- Common blocks, equivalence statements, and declarations can all+-- be refactored by the default refactoring+refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StEquivalence{}) =+ refactorStatements v inp s+refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StCommon{}) =+ refactorStatements v inp s+refactorBlocks v inp b@(F.BlStatement _ _ _ s@F.StDeclaration{}) =+ refactorStatements v inp s+-- Arbitrary statements can be refactored *as blocks* (in order to+-- get good indenting)+refactorBlocks v inp b@F.BlStatement {} = refactorSyntax v inp b+refactorBlocks _ _ _ = return (B.empty, False) -refactorUses :: SourceText -> Uses Annotation -> StateT SrcLoc (State Int) (SourceText, Bool)-refactorUses inp u = do+-- Wrapper to fix the type of refactorSyntax to deal with statements+refactorStatements :: FPM.FortranVersion -> SourceText+ -> F.Statement A -> StateT FU.Position (State Int) (SourceText, Bool)+refactorStatements = refactorSyntax++refactorSyntax ::+ (Typeable s, F.Annotated s, FU.Spanned (s A), PP.IndentablePretty (s A))+ => FPM.FortranVersion -> SourceText+ -> s A -> StateT FU.Position (State Int) (SourceText, Bool)+refactorSyntax v inp e = do cursor <- get- let ?variant = HTMLPP in- case (refactored $ tag u) of- Just lb -> let (p0, _) = takeBounds (cursor, lb) inp- syntax = B.pack $ printSlave u- in do added <- lift get- if (newNode $ tag u) then lift $ put (added + (countLines syntax))- else return ()- put $ toCol0 lb- return (p0 `B.append` syntax, True)- Nothing -> return (B.empty, False)+ let a = F.getAnnotation e+ case refactored a of+ Nothing -> return (B.empty, False)+ Just (FU.Position _ rCol rLine) -> do+ let (FU.SrcSpan lb ub) = FU.getSpan e+ let (pre, _) = takeBounds (cursor, lb) inp+ let indent = if newNode a then Just (rCol - 1) else Nothing+ let output = if deleteNode a then B.empty+ else B.pack $ PP.pprintAndRender v e indent+ out <- if newNode a then do+ -- If a new node is begin created then+ numAdded <- lift get+ let diff = linesCovered ub lb+ -- remove empty newlines here if extra lines were added+ let (out, numRemoved) = if numAdded <= diff+ then removeNewLines output numAdded+ else removeNewLines output diff+ lift $ put (numAdded - numRemoved)+ return out+ else return output+ put ub+ return (B.concat [pre, out], True) countLines xs = case B.uncons xs of@@ -265,27 +216,26 @@ Just ('\n', xs) -> 1 + countLines xs Just (x, xs) -> countLines xs -{- 'removeNewLines xs n' removes at most 'n' new lines characters from the input string- xs, returning the new string and the number of new lines that were removed. Note- that the number of new lines removed might actually be less than 'n'- but in principle- this should not happen with the usaage in 'refactorDecl' -}+{- 'removeNewLines xs n' removes at most 'n' new lines characters from+the input string xs, returning the new string and the number of new+lines that were removed. Note that the number of new lines removed+might actually be less than 'n'- but in principle this should not+happen with the usaage in 'refactorDecl' -} removeNewLines xs 0 = (xs, 0) -- Deal with CR LF in the same way as just LF removeNewLines xs n = case unpackFst (B.splitAt 4 xs) of- ("\r\n\r\n", xs) -> (xs', n' + 1)- where (xs', n') = removeNewLines ((B.pack "\r\n") `B.append` xs) (n - 1)- _ ->- case unpackFst (B.splitAt 2 xs) of- ("\n\n", xs) -> (xs', n' + 1)- where (xs', n') = removeNewLines ((B.pack "\n") `B.append` xs) (n - 1)- _ ->- case B.uncons xs of- Nothing -> (xs, 0)- Just (x, xs) -> (B.cons x xs', n)- where (xs', n') = removeNewLines xs n+ ("\r\n\r\n", xs) -> (xs', n' + 1)+ where (xs', n') = removeNewLines (B.pack "\r\n" `B.append` xs) (n - 1)+ _ ->+ case unpackFst (B.splitAt 2 xs) of+ ("\n\n", xs) -> (xs', n' + 1)+ where (xs', n') = removeNewLines (B.pack "\n" `B.append` xs) (n - 1)+ _ ->+ case B.uncons xs of+ Nothing -> (xs, 0)+ Just (x, xs) -> (B.cons x xs', n)+ where (xs', n') = removeNewLines xs n unpackFst (x, y) = (B.unpack x, y)---removeNewLines ('\n':xs) 0 = let (xs', n') = removeNewLines xs 0--- in ('\n':xs', 0)
− src/Camfort/PrettyPrint.hs
@@ -1,315 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}--{-# LANGUAGE FlexibleInstances, UndecidableInstances, ImplicitParams, DoAndIfThenElse,- MultiParamTypeClasses, FlexibleContexts, KindSignatures, ScopedTypeVariables,- DeriveGeneric, DeriveDataTypeable #-}--{--- Provides pretty printing related code---}--module Camfort.PrettyPrint where--import Camfort.Analysis.Syntax-import Camfort.Analysis.Annotations-import Camfort.Helpers-import Camfort.Traverse--import qualified Language.Fortran as Fortran-import Language.Fortran.PreProcess-import Language.Fortran-import Language.Fortran.Pretty--import Data.Map.Lazy hiding (map, foldl)-import qualified Data.ByteString.Char8 as B-import Data.Text hiding (zip,foldl,map,concatMap,take,drop,length,last,head,tail,replicate,concat)-import qualified Data.Text as Text-import Data.List-import Data.Generics.Uniplate.Data-import Data.Generics-import GHC.Generics-import Data.Char-import Data.Maybe-import Control.Monad.Trans.State.Lazy-import Text.Printf--class PrettyPrint p where- prettyPrint :: p -> SourceText--instance (PrintMaster (Program Annotation) DefaultPP) => PrettyPrint (Program Annotation) where- prettyPrint p = let ?variant = DefaultPP in B.pack $ printMaster p---- Define new pretty printing version for HTML output-data HTMLPP = HTMLPP-instance PPVersion HTMLPP--{-| Convert source code to a pretty-printed HTML format -}-outputHTMLA :: Fortran.ProgUnit Annotation -> String-outputHTMLA x = outputHTML x--outputHTML :: forall p . (Data p, Typeable p, PrintSlave p HTMLPP, PrintSlave (Decl p) HTMLPP, PrintIndSlave (Fortran p) HTMLPP, Indentor (Decl p), Indentor (Fortran p)) =>- Fortran.ProgUnit p -> String-outputHTML prog = unpack html- where- t :: SubName p -> SubName p- t (SubName p n) = SubName p (addColor blue n)- t x = x-- purple = "#800080"- green = "#008000"- blue = "#000080"-- toColor c t k = replace k (Text.concat [pack ("<span style='color:" ++ c ++ "'>"), k, pack "</span>"]) t- addColor c k = "<span style='color:" ++ c ++ "'>" ++ k ++ "</span>"- pre l = Text.concat [pack "<pre>", l, pack "</pre>"]- types = map pack ["real", "integer", "character", "type", "logical"]-- html = let ?variant = HTMLPP- in- (Text.append (pack $ "<head><script type='text/javascript' src='../source.js'></script>"- ++ "<link href='../source.css' type='text/css' rel='stylesheet' /></head>"))- . (\t -> replace (pack "newline") (pack "\n") t)- . (Text.concat . (map pre) . Text.lines)- . (\t -> foldl (toColor green) t types)- . (\t -> foldl (toColor purple) t keyword)- . (pack . printMaster)- -- . (pack . output)- -- . (pack . paraBi (\p -> \ss -> (showPara p) ++ ss) "")- -- . (pack . (para (\p -> \ss -> showPara p ++ (Prelude.concat ss))))- . (transformBi t) $ prog--{- | Pretty printer for HTML, specialised to the analysis of CamFort, which mostly uses the default master- behaviour, but with a few special cases -}--instance PrintSlave Bool HTMLPP where- printSlave = show--instance PrintSlave SrcLoc HTMLPP where- printSlave _ = "" -- not sure if I want this to shown--instance (PrintSlave (Decl p) HTMLPP, PrintIndSlave (Fortran p) HTMLPP, PrintSlave p HTMLPP, Indentor (Decl p), Indentor (Fortran p)) => PrintSlave (ProgUnit p) HTMLPP where- printSlave = printMaster--instance PrintSlave (DataForm p) HTMLPP where- printSlave = printMaster--instance (PrintSlave (DataForm p) HTMLPP) => PrintSlave (SubName p) HTMLPP where- printSlave = printMaster--instance (PrintSlave (Decl p) HTMLPP) => PrintSlave (Implicit p) HTMLPP where- printSlave = printMaster--instance {-# OVERLAPPABLE #-} (Indentor (Decl p), PrintSlave (DataForm p) HTMLPP) => PrintSlave (Decl p) HTMLPP where- printSlave = printMaster--instance {-# OVERLAPS #-} PrintSlave (Decl Annotation) HTMLPP where- printSlave t = let i = 0- in "<div style=''>" ++ (outputAnn (tag t) False i showt) ++ (annotationMark i t (printMaster t)) ++ "</div>"- where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t))---instance PrintSlave (Type p) HTMLPP where- printSlave = printMaster--instance PrintSlave (VarName p) HTMLPP where- printSlave = printMaster--instance (PrintSlave (DataForm p) HTMLPP) => PrintSlave (Expr p) HTMLPP where- printSlave = printMaster--instance PrintSlave (UnaryOp p) HTMLPP where- printSlave = printMaster--instance PrintSlave (BinOp p) HTMLPP where- printSlave = printMaster--instance PrintSlave (ArgList p) HTMLPP where- printSlave = printMaster--instance PrintSlave (BaseType p) HTMLPP where- printSlave = printMaster--instance (PrintSlave (Decl p) HTMLPP, Indentor (Decl p)) => PrintSlave (InterfaceSpec p) HTMLPP where- printSlave = printMaster--instance PrintSlave (Arg p) HTMLPP where- printSlave = printMaster--instance PrintSlave (ArgName p) HTMLPP where- printSlave = printMaster--instance PrintSlave (GSpec p) HTMLPP where- printSlave = printMaster--instance PrintSlave (Attr p) HTMLPP where- printSlave = printMaster--instance PrintSlave (Fraction p) HTMLPP where- printSlave = printMaster--instance PrintSlave (MeasureUnitSpec p) HTMLPP where- printSlave = printMaster--instance (PrintSlave (Decl p) HTMLPP, PrintSlave (DataForm p) HTMLPP, PrintIndSlave (Fortran p) HTMLPP, PrintSlave p HTMLPP, Indentor (Fortran p), Indentor (Decl p)) => PrintSlave (Block p) HTMLPP where- printSlave = printMaster--instance PrintSlave (Uses p) HTMLPP where- printSlave u = showUse' u--showUse' :: Uses p -> String-showUse' (UseNil _) = ""-showUse' (Uses _ (Use n []) us _) = ("use "++n++"\n") ++ (showUse' us)-showUse' (Uses _ (Use n renames) us _) = ("use "++n++", " ++ (Prelude.concat $ Data.List.intersperse ", " (map (\(a, b) -> a ++ " => " ++ b) renames)) ++ "\n") ++ (showUse' us)--instance (PrintIndSlave (Fortran p) HTMLPP, PrintSlave p HTMLPP, Indentor (Fortran p)) => PrintSlave (Fortran p) HTMLPP where- printSlave (For p _ v e e' e'' f) = "do"++" "++printSlave v++" = "++printSlave e++", "++- printSlave e'++", "++printSlave e''++"\n"++- "<span style='color:#707d8f'>"++"{"++printSlave p++"}</span>\n" ++- (printIndSlave 1 f)++"\n"++(ind 1)++"end do"- printSlave t = printMaster t--instance PrintSlave (Spec p) HTMLPP where- printSlave = printMaster--instance Indentor (Fortran Bool) where- indR t i = if (tag t) then- let (s, SrcLoc f l c) = srcSpan t- in Prelude.take c (repeat ' ')- else ind i--instance PrintIndSlave (Fortran A1) HTMLPP where- printIndSlave = printIndMaster--instance PrintIndSlave (Fortran Annotation) HTMLPP where-- printIndSlave i t@(For p _ v e e' e'' f) = (outputAnn p False i (show t)) ++- annotationMark i t- ((ind i) ++ "do"++" "++printSlave v++" = "++- printSlave e++", "++- printSlave e'++", "++printSlave e''++"\n"++- (printIndSlave (i+1) f)++"\n"++(ind i)++"end do")--- -- printIndSlave i t@(FSeq p f1 f2) = (outputAnn p False i) ++ printIndSlave i f1 ++ printIndSlave i f2- printIndSlave i t = "<div style=''>" ++ (outputAnn (rextract t) False i showt) ++ (annotationMark i t (printIndMaster i t)) ++ "</div>"- where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t))--{--instance PrintIndSlave (Decl p) HTMLPP where- outputPrintSlave i t = "<div style=''>" ++ (outputAnn (rextract t) False i showt) ++ (annotationMark i t (printIndMaster i t)) ++ "</div>"- where showt = prettyp (show (setCompactSrcLocs $ fmap (\x -> ()) t))x--}--countToColor n = colors !! (n `mod` (length colors)) -- printf "#%06x" ((256*256*256 - (n * 40)) :: Int)--colors = ["#ffeeee", "#eeffee", "#eeeeff", "#ffffee",- "#eeffff", "#eeffee", "#ffdddd", "#ddffdd",- "#ddddff", "#ffffdd", "#ffddff", "#ddffff",- "#eecccc", "#cceecc", "#eeeecc", "#ddeeee"]--prettyp xs = prettyp' xs 0 []-prettyp' [] n f = []-prettyp' ('(':xs) n f = let k = "<span style='background-color:" ++ (countToColor n) ++ ";'>"- in if (nearbyClose xs 10) then- k ++ ('(':(prettyp' xs n (False:f)))- else- ("<br>" ++ (concat $ replicate (2 * (n+1)) " ")) ++ k ++ ('(' : (prettyp' xs (n+1) (True:f)))-prettyp' (')':xs) n (False:f) = ')' : ("</span>" ++ prettyp' xs n f)-prettyp' (')':xs) n (True:f) = ')' : ("</span>" ++ prettyp' xs (n - 1) f)-prettyp' (x:xs) n f = x : prettyp' xs n f--nearbyClose [] n = False-nearbyClose _ 0 = False-nearbyClose ('(':(')':xs)) n = nearbyClose xs (n - 2)-nearbyClose (')':xs) n = True-nearbyClose (x:xs) n = nearbyClose xs (n - 1)---annotationMark i t x = "<div class='clickable' onClick='toggle(" ++- (show $ number (tag t)) ++ ");'>" ++- x ++ "</div>"---row xs = "<tr>" ++ (concatMap (\x -> "<td>" ++ x ++ "</td>") xs) ++ "</tr>"--instance PrintSlave Annotation HTMLPP where- printSlave t = outputAnn t False 0 (show t)--breakUp xs = breakup' xs 0 False- where breakup' [] _ _ = []- breakup' (x:xs) c mode | x == '<' = x : (breakup' xs c True)- | x == '>' = x : (breakup' xs c False)- | c >= 80 && (not mode) = x : ("newline" ++ breakup' xs 0 False)- | mode = x : (breakup' xs c mode)- | otherwise = x : (breakup' xs (c+1) mode)-- -- (take 80 xs) ++ "newline" ++ (if (drop 80 xs) == [] then [] else breakUp (drop 80 xs))--outputAnn t visible i astString =- "<div id='a" ++ (show $ number t) ++ "' style='" ++- (if visible then "" else "display:none;") ++- "' class'outer'><div class='spacer'><pre>" ++ (indent 3 i) ++ "</pre></div>" ++- "<div class='annotation'><div class='number'>" ++ (show $ number t) ++ "</div>" ++- "<div><div class='clickable' onClick=\"toggle('" ++ (show $ number t) ++ "src');\">" ++- "<u>show ast</u></div><div id='a" ++ (show $ number t) ++ "src' " ++- "style='background:#fff;display:none;width:600px;overflow:wrap;'>" ++ (astString) ++ "</div></div>" ++ "<p><table>" ++- row ["lives: (in) ", showList $ (map show) $ fst $ lives t, "(out)", showList $ (map show) $ snd $ lives t] ++- row ["successors:", showList $ (map show) (successorStmts t)] ++- "</table></p></div><br />\n\r\n"- where- listToPair x = "(" ++ listToPair' x ++ ")"- listToPair' [] = ""- listToPair' [x] = printMaster x- listToPair' (x:xs) = printMaster x ++ ", " ++ listToPair' xs-- showExps [] = ""- showExps [(v, es)] = "[" ++ v ++ ": " ++ (showList $ map listToPair es) ++ "]"- showExps ((v, es):ys) = (showExps [(v, es)]) ++ ", " ++ (showExps ys)--- showList [] = ""- showList [x] = x- showList (x:xs) = x ++ ", " ++ showList xs---type A1 = Bool----- inBounds :: SrcLoc -> (SrcLoc, SrcLoc) -> Bool--- inBounds x (l,u) = (lineCol x) >= (lineCol l) && (lineCol x) < (lineCol u)---{- Indenting for refactored code -}--instance Tagged p => Indentor (p Annotation) where- indR t i = case (refactored . tag $ t) of- Just (SrcLoc f _ c) -> Prelude.take c (repeat ' ')- Nothing -> ind i--keyword = map pack- ["end","subroutine","function","program","module","data", "common",- "namelist", "external", "interface", "type", "include", "format",- "len", "kind", "dimension", "allocatable", "parameter", "external",- "intent", "intrinsic", "optional", "pointer", "save", "target",- "volatile", "public", "private", "sequence", "operator", "assignment",- "procedure", "do", "if", "else", "then", "allocate", "backspace",- "call", "open", "close", "continue", "cycle", "deallocate", "endfile",- "exit", "forall", "goto", "nullify", "inquire", "rewind", "stop", "where",- "write", "rerun", "print", "read", "write", "implicit", "use"]-
src/Camfort/Reprint.hs view
@@ -20,70 +20,69 @@ import Data.Generics.Zipper -import Camfort.PrettyPrint import Camfort.Analysis.Annotations-import Camfort.Traverse import Camfort.Helpers+import Camfort.Helpers.Syntax import qualified Data.ByteString.Char8 as B import Data.Functor.Identity import Data.Data import Control.Monad.Trans.State.Lazy--import Language.Fortran-import Camfort.Analysis.Syntax+import qualified Language.Fortran.Util.Position as FU {- Reminder: -- type SourceText = B.ByteString- -- data SrcLoc- = SrcLoc {srcFilename :: String, srcLine :: Int, srcColumn :: Int}+ -- data FU.Position = FU.Position { posAsbsoluteOffset :: Int,+ posColumn :: Int,+ posLine :: Int } -} -type Refactored = Bool -- A refactoring takes a 'Typeable' value -- into a stateful SourceText (ByteString) transformer, -- which returns a pair of a stateful computation of an updated SourceText -- paired with a boolean flag denoting whether a refactoring has been--- performed. The state contains a SrcLoc which is the "cursor"+-- performed. The state contains a FU.Position which is the "cursor" -- within the original source text. The incoming value corresponds to -- the position of the first character in the input SourceText. The -- outgoing value is a cursor ahead of the incoming one which shows -- the amount of SourceText that is consumed by the refactoring. +type Refactored = Bool type Refactoring m =- forall b .- Typeable b => b -> SourceText -> StateT SrcLoc m (SourceText, Refactored)+ forall b . Typeable b+ => b -> SourceText -> StateT FU.Position m (SourceText, Refactored) -- The reprint algorithm takes a refactoring (parameteric in -- some monad m) and turns an arbitrary pretty-printable type 'p' -- into a monadic SourceText transformer. -reprint :: (Monad m, Data p, PrettyPrint p)+reprint :: (Monad m, Data p) => Refactoring m -> p -> SourceText -> m SourceText reprint refactoring tree input- -- If the inupt is null then switch into pretty printer- | B.null input = return $ prettyPrint tree+ -- If the inupt is null then null is returned+ | B.null input = return B.empty -- Otherwise go with the normal algorithm | otherwise = do- -- Create an initial cursor at the start of the file- let cursor0 = SrcLoc "" 1 0- -- Enter the top-node of a zipper for 'tree'- -- setting the cursor at the start of the file- (output, cursorn) <- runStateT (enter refactoring (toZipper tree) input) cursor0- -- Remove from the input the portion covered by the main algorithm- -- leaving the rest of the file not covered within the bounds of- -- the tree- let (_, remaining) = takeBounds (cursor0, cursorn) input- return $ output `B.append` remaining+ -- Create an initial cursor at the start of the file+ let cursor0 = FU.Position 0 0 1+ -- Enter the top-node of a zipper for 'tree'+ -- setting the cursor at the start of the file+ (out, cursorn) <- runStateT (enter refactoring (toZipper tree) input) cursor0+ -- Remove from the input the portion covered by the main algorithm+ -- leaving the rest of the file not covered within the bounds of+ -- the tree+ let (_, remaining) = takeBounds (cursor0, cursorn) input+ return $ out `B.append` remaining --- The enter, enterDown, enterRight each take a refactoring--- and a zipper producing a stateful SourceText transformer with SrcLoc state.+-- The enter, enterDown, enterRight each take a refactoring and a+-- zipper producing a stateful SourceText transformer with FU.Position+-- state. enter, enterDown, enterRight :: Monad m- => Refactoring m -> Zipper a -> SourceText -> StateT SrcLoc m SourceText+ => Refactoring m -> Zipper a -> SourceText -> StateT FU.Position m SourceText -- `enter` applies the generic refactoring to the current context -- of the zipper@@ -92,7 +91,7 @@ -- Part 1. -- Apply a refactoring cursor <- get- (p1, refactored) <- query (flip refactoring inp) z+ (p1, refactored) <- query (`refactoring` inp) z -- Part 2. -- Cut out the portion of source text consumed by the refactoring@@ -116,28 +115,30 @@ -- `enterDown` navigates to the children of the current context enterDown refactoring z inp =- case (down' z) of+ case down' z of -- Go to children Just dz -> enter refactoring dz inp -- No children- Nothing -> return $ B.empty+ Nothing -> return B.empty -- `enterRight` navigates to the right sibling of the current context enterRight refactoring z inp =- case (right z) of+ case right z of -- Go to right sibling Just rz -> enter refactoring rz inp -- No right sibling- Nothing -> return $ B.empty+ Nothing -> return B.empty --- Given a lower-bound and upper-bound pair of SrcLocs, split the--- incoming SourceText based on the distance between the SrcLoc pairs-takeBounds :: (SrcLoc, SrcLoc) -> SourceText -> (SourceText, SourceText)-takeBounds (l, u) inp = takeBounds' (lineCol l, lineCol u) B.empty inp+-- Given a lower-bound and upper-bound pair of FU.Positions, split the+-- incoming SourceText based on the distanceF between the FU.Position pairs+takeBounds :: (FU.Position, FU.Position) -> SourceText -> (SourceText, SourceText)+takeBounds (l, u) = takeBounds' ((ll, lc), (ul, uc)) B.empty+ where (FU.Position _ lc ll) = l+ (FU.Position _ uc ul) = u takeBounds' ((ll, lc), (ul, uc)) tk inp = if (ll == ul && lc == uc) || (ll > ul) then (B.reverse tk, inp) else case B.uncons inp of- Nothing -> (B.reverse tk, inp)- Just ('\n', ys) -> takeBounds' ((ll+1, 0), (ul, uc)) (B.cons '\n' tk) ys- Just (x, xs) -> takeBounds' ((ll, lc+1), (ul, uc)) (B.cons x tk) xs+ Nothing -> (B.reverse tk, inp)+ Just ('\n', ys) -> takeBounds' ((ll+1, 0), (ul, uc)) (B.cons '\n' tk) ys+ Just (x, xs) -> takeBounds' ((ll, lc+1), (ul, uc)) (B.cons x tk) xs
src/Camfort/Specification/Stencils.hs view
@@ -15,7 +15,7 @@ -} module Camfort.Specification.Stencils- (InferMode, infer, check, synth, findVarFlowCycles) where+ (InferMode, infer, check, synth) where import Control.Monad.State.Lazy import Control.Monad.Writer hiding (Product)@@ -49,20 +49,21 @@ -------------------------------------------------- -- Top-level of specification inference-infer :: InferMode -> Filename+infer :: InferMode -> Char -> Filename -> F.ProgramFile Annotation -> (String, F.ProgramFile Annotation)-infer mode filename pf =+infer mode marker filename pf = -- Append filename to any outputs if null output then ("", fmap FA.prevAnnotation pf'') else ("\n" ++ filename ++ "\n" ++ output, fmap FA.prevAnnotation pf'') where- output = (intercalate "\n")- . (filter (not . white))+ output = intercalate "\n"+ . filter (not . white) . map (formatSpec Nothing nameMap) $ results white = all (\x -> (x == ' ') || (x == '\t'))- (pf'', results) = (stencilInference nameMap mode) . FAB.analyseBBlocks $ pf'+ (pf'', results) = stencilInference nameMap mode marker+ . FAB.analyseBBlocks $ pf' nameMap = FAR.extractNameMap pf' pf' = FAR.analyseRenames . FA.initAnalysis $ pf @@ -72,21 +73,23 @@ -- Top-level of specification synthesis synth :: InferMode+ -> Char -> [(Filename, F.ProgramFile A)] -> (String, [(Filename, F.ProgramFile Annotation)])-synth mode ps = foldr buildOutput ("", []) ps+synth mode marker = foldr buildOutput ("", []) where buildOutput (f, pf) (r, pfs) = (r ++ r', (f, pf') : pfs)- where (r', pf') = synthPF mode f pf+ where (r', pf') = synthPF mode marker f pf -synthPF :: InferMode -> Filename+synthPF :: InferMode -> Char -> Filename -> F.ProgramFile Annotation -> (String, F.ProgramFile Annotation)-synthPF mode filename pf =+synthPF mode marker filename pf = -- Append filename to any outputs ("", fmap FA.prevAnnotation pf'') where- (pf'', _) = (stencilInference nameMap Synth) . FAB.analyseBBlocks $ pf'+ (pf'', _) = stencilInference nameMap Synth marker+ . FAB.analyseBBlocks $ pf' nameMap = FAR.extractNameMap pf' pf' = FAR.analyseRenames . FA.initAnalysis $ pf @@ -101,7 +104,7 @@ where output = intercalate "\n" results -- Applying checking mechanism- results = (stencilChecking nameMap) . FAB.analyseBBlocks $ pf'+ results = stencilChecking nameMap . FAB.analyseBBlocks $ pf' nameMap = FAR.extractNameMap pf' pf' = FAR.analyseRenames . FA.initAnalysis $ pf
src/Camfort/Specification/Stencils/Annotation.hs view
@@ -26,7 +26,7 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-+import Debug.Trace {- *** Routines for associating annotations to ASTs -}
src/Camfort/Specification/Stencils/CheckBackend.hs view
@@ -14,8 +14,11 @@ limitations under the License. -} -{-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances,- TupleSections, FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} module Camfort.Specification.Stencils.CheckBackend where@@ -60,10 +63,10 @@ instance SynToAst SYN.Specification (Either RegionEnv SpecDecls) where synToAst (SYN.SpecDec spec vars) = do spec' <- synToAst spec- return $ Right $ [(vars, spec')]+ return $ Right [(vars, spec')] synToAst (SYN.RegionDec rvar region) = do- spec' <- synToAst $ region+ spec' <- synToAst region return $ Left [(rvar, spec')] -- Convert temporal or spatial specifications@@ -71,18 +74,18 @@ synToAst (SYN.Spatial mods r) = do (modLinear, approx) <- synToAst mods r' <- synToAst r- let s' = Spatial modLinear r'- return $ Specification $ Left $+ let s' = Spatial r'+ return $ Specification $ addLinearity modLinear $ case approx of Just SYN.AtMost -> Bound Nothing (Just s') Just SYN.AtLeast -> Bound (Just s') Nothing Nothing -> Exact s'-- synToAst (SYN.Temporal vars mutual) =- return $ Specification $ Right $ Dependency vars mutual+ where+ addLinearity Linear appr = Single appr+ addLinearity NonLinear appr = Multiple appr -- Convert region definitions into the DNF-form used internally-instance SynToAst (SYN.Region) RegionSum where+instance SynToAst SYN.Region RegionSum where synToAst = dnf -- Convert a grammar syntax to Disjunctive Normal Form AST@@ -107,7 +110,7 @@ dnf (SYN.Var v) = case lookup v ?renv of Nothing -> Left $ "Error: region " ++ v ++ " is not in scope."- Just rs -> return $ rs+ Just rs -> return rs -- Convert modifier list to modifier info instance SynToAst [SYN.Mod]
src/Camfort/Specification/Stencils/CheckFrontend.hs view
@@ -20,11 +20,9 @@ module Camfort.Specification.Stencils.CheckFrontend where -import Data.Data import Data.Generics.Uniplate.Operations import Control.Arrow import Control.Monad.State.Strict-import Control.Monad.Reader import Control.Monad.Writer.Strict hiding (Product) import Camfort.Specification.Stencils.CheckBackend@@ -41,19 +39,14 @@ import qualified Language.Fortran.AST as F import qualified Language.Fortran.Analysis as FA-import qualified Language.Fortran.Analysis.Types as FAT import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.Analysis.BBlocks as FAB import qualified Language.Fortran.Analysis.DataFlow as FAD import qualified Language.Fortran.Util.Position as FU -import Data.Graph.Inductive.Graph hiding (isEmpty) import qualified Data.Map as M-import qualified Data.IntMap as IM-import qualified Data.Set as S import Data.Maybe import Data.List-import Debug.Trace -- Entry point stencilChecking :: FAR.NameMap -> F.ProgramFile (FA.Analysis A) -> [String]@@ -83,7 +76,7 @@ let ?nameMap = nameMap in descendBiM perProgramUnitCheck pf' -- Format output- let a@(_, output) = evalState (runWriterT $ results) (([], Nothing), ivmap)+ let a@(_, output) = evalState (runWriterT results) (([], Nothing), ivmap) tell $ pprint output type LogLine = (FU.SrcSpan, String)@@ -110,26 +103,28 @@ updateRegionEnv :: FA.Analysis A -> Checker () updateRegionEnv ann = case stencilSpec (FA.prevAnnotation ann) of- Just (Right (Left regionEnv)) -> modify $ (((++) regionEnv) *** id) *** id+ Just (Right (Left regionEnv)) -> modify $ first (first (regionEnv ++)) _ -> return () --- Given a mapping from variables to inferred specifications--- an environment of specification delcarations, for each declared--- specification check if there is a inferred specification that--- agrees with it, *up-to the model*-compareInferredToDeclared :: [([F.Name], Specification)] -> SpecDecls -> Bool-compareInferredToDeclared inferreds declareds =- all (\(names, dec) ->- all (\name ->- any (\inf -> eqByModel inf dec) (lookupAggregate inferreds name)- ) names) declareds+checkOffsetsAgainstSpec :: [(Variable, Multiplicity [[Int]])]+ -> [(Variable, Specification)]+ -> Bool+checkOffsetsAgainstSpec offsetMaps =+ all (\(var1, Specification mult)->+ all (\(var2, offsets) ->+ var1 /= var2 || noAllInfinity offsets `consistent` mult) offsetMaps)+ where+ noAllInfinity (Single a) =+ Single $ filter (not . all (== absoluteRep)) a+ noAllInfinity (Multiple a) =+ Multiple $ filter (not . all (== absoluteRep)) a -- Go into the program units first and record the module name when -- entering into a module perProgramUnitCheck :: (?nameMap :: FAR.NameMap, ?flowsGraph :: FAD.FlowsGraph A) => F.ProgramUnit (FA.Analysis A) -> Checker (F.ProgramUnit (FA.Analysis A))-perProgramUnitCheck p@(F.PUModule {}) = do- modify $ (id *** (const (Just $ FA.puName p))) *** id+perProgramUnitCheck p@F.PUModule{} = do+ modify $ first (second (const (Just $ FA.puName p))) descendBiM perBlockCheck p perProgramUnitCheck p = descendBiM perBlockCheck p @@ -141,36 +136,47 @@ updateRegionEnv ann' let b' = F.setAnnotation ann' b case (stencilSpec $ FA.prevAnnotation ann', stencilBlock $ FA.prevAnnotation ann') of- -- Comment contains a specification and an associated block+ -- Comment contains a specification and an Associated block (Just (Right (Right specDecls)), Just block) -> case block of- s@(F.BlStatement ann span _ (F.StExpressionAssign _ _ lhs rhs)) ->+ s@(F.BlStatement ann span' _ (F.StExpressionAssign _ _ lhs rhs)) -> case isArraySubscript lhs of Just subs -> do -- Create list of relative indices- (_, ivmap) <- get+ ivmap <- snd <$> get -- Do inference let realName v = v `fromMaybe` (v `M.lookup` ?nameMap)- let lhsN = maybe [] id (neighbourIndex ivmap subs)- let correctNames = map (\(names, spec) -> (map realName names, spec))- let inferred = correctNames . fst . runWriter $ genSpecifications ivmap lhsN [s]+ let lhsN = fromMaybe [] (neighbourIndex ivmap subs)+ let correctNames = map (first realName)+ let relOffsets = correctNames . fst . runWriter $ genOffsets ivmap lhsN [s]+ let multOffsets = map (\relOffset ->+ case relOffset of+ (var, (True, offsets)) -> (var, Multiple offsets)+ (var, (False, offsets)) -> (var, Single offsets)) relOffsets+ let expandedDecls =+ concatMap (\(vars,spec) -> map (flip (,) spec) vars) specDecls -- Model and compare the current and specified stencil specs- if compareInferredToDeclared inferred specDecls+ if checkOffsetsAgainstSpec multOffsets expandedDecls then tell [ (span, "Correct.") ]- else tell [ (span, "Not well specified:\n\t\t expecting: "+ else do+ let correctNames2 = map (first (map realName))+ let inferred = correctNames2 . fst . runWriter $ genSpecifications ivmap lhsN [s]+ tell [ (span, "Not well specified.\n"+ ++ "\tSpecification is:\t " ++ pprintSpecDecls specDecls- ++ "\t\t inferred: " ++ pprintSpecDecls inferred) ]- return $ b'- Nothing -> return $ b'- _ -> return $ b'+ ++ "\tbut at " ++ show span' ++ " the code behaves as"+ ++ "\n\t \t "+ ++ pprintSpecDecls inferred) ]+ return b'+ Nothing -> return b' - (F.BlDo ann span _ mDoSpec body) -> do+ (F.BlDo ann span _ _ _ mDoSpec body _) -> -- Stub, maybe collect stencils inside 'do' block- return $ b'- _ -> return $ b'+ return b'+ _ -> return b' _ -> return b' -perBlockCheck b@(F.BlDo ann span _ mDoSpec body) = do+perBlockCheck b@(F.BlDo ann span _ _ _ mDoSpec body _) = do -- descend into the body of the do-statement mapM_ (descendBiM perBlockCheck) body -- Remove any induction variable from the state
− src/Camfort/Specification/Stencils/Grammar.hs
@@ -1,1131 +0,0 @@-{-# OPTIONS_GHC -w #-}--- -*- Mode: Haskell -*--{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}-module Camfort.Specification.Stencils.Grammar-( specParser, Specification(..), Region(..), Spec(..), Mod(..), lexer ) where--import Data.Char (isLetter, isNumber, isAlphaNum, toLower, isAlpha, isSpace)-import Data.List (intersect, sort, isPrefixOf)-import Data.Data--import Debug.Trace--import Camfort.Analysis.CommentAnnotator-import Camfort.Specification.Stencils.Syntax (showL)-import Control.Applicative(Applicative(..))-import Control.Monad (ap)---- parser produced by Happy Version 1.19.5--data HappyAbsSyn - = HappyTerminal (Token)- | HappyErrorToken Int- | HappyAbsSyn4 (Specification)- | HappyAbsSyn5 ((String, Region))- | HappyAbsSyn6 (Region)- | HappyAbsSyn7 (Bool)- | HappyAbsSyn8 (Spec)- | HappyAbsSyn9 (Mod)- | HappyAbsSyn10 ([Mod])- | HappyAbsSyn12 ([String])--{- to allow type-synonyms as our monads (likely- - with explicitly-specified bind and return)- - in Haskell98, it seems that with- - /type M a = .../, then /(HappyReduction M)/- - is not allowed. But Happy is a- - code-generator that can just substitute it.-type HappyReduction m = - Int - -> (Token)- -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)- -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> m HappyAbsSyn--}--action_0,- action_1,- action_2,- action_3,- action_4,- action_5,- action_6,- action_7,- action_8,- action_9,- action_10,- action_11,- action_12,- action_13,- action_14,- action_15,- action_16,- action_17,- action_18,- action_19,- action_20,- action_21,- action_22,- action_23,- action_24,- action_25,- action_26,- action_27,- action_28,- action_29,- action_30,- action_31,- action_32,- action_33,- action_34,- action_35,- action_36,- action_37,- action_38,- action_39,- action_40,- action_41,- action_42,- action_43,- action_44,- action_45,- action_46,- action_47,- action_48,- action_49,- action_50,- action_51,- action_52,- action_53,- action_54,- action_55,- action_56,- action_57,- action_58,- action_59,- action_60,- action_61,- action_62,- action_63,- action_64,- action_65,- action_66,- action_67,- action_68,- action_69,- action_70,- action_71,- action_72,- action_73,- action_74,- action_75,- action_76 :: () => Int -> ({-HappyReduction (Either AnnotationParseError) = -}- Int - -> (Token)- -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)- -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)--happyReduce_1,- happyReduce_2,- happyReduce_3,- happyReduce_4,- happyReduce_5,- happyReduce_6,- happyReduce_7,- happyReduce_8,- happyReduce_9,- happyReduce_10,- happyReduce_11,- happyReduce_12,- happyReduce_13,- happyReduce_14,- happyReduce_15,- happyReduce_16,- happyReduce_17,- happyReduce_18,- happyReduce_19,- happyReduce_20,- happyReduce_21,- happyReduce_22,- happyReduce_23,- happyReduce_24,- happyReduce_25,- happyReduce_26 :: () => ({-HappyReduction (Either AnnotationParseError) = -}- Int - -> (Token)- -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)- -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)] - -> HappyStk HappyAbsSyn - -> [(Token)] -> (Either AnnotationParseError) HappyAbsSyn)--action_0 (13) = happyShift action_5-action_0 (14) = happyShift action_3-action_0 (4) = happyGoto action_4-action_0 (5) = happyGoto action_2-action_0 _ = happyFail--action_1 (14) = happyShift action_3-action_1 (5) = happyGoto action_2-action_1 _ = happyFail--action_2 _ = happyReduce_1--action_3 (28) = happyShift action_21-action_3 _ = happyFail--action_4 (37) = happyAccept-action_4 _ = happyFail--action_5 (15) = happyShift action_11-action_5 (16) = happyShift action_12-action_5 (18) = happyShift action_13-action_5 (19) = happyShift action_14-action_5 (23) = happyShift action_15-action_5 (24) = happyShift action_16-action_5 (25) = happyShift action_17-action_5 (26) = happyShift action_18-action_5 (28) = happyShift action_19-action_5 (34) = happyShift action_20-action_5 (6) = happyGoto action_6-action_5 (8) = happyGoto action_7-action_5 (9) = happyGoto action_8-action_5 (10) = happyGoto action_9-action_5 (11) = happyGoto action_10-action_5 _ = happyFail--action_6 (30) = happyShift action_35-action_6 (31) = happyShift action_36-action_6 _ = happyReduce_19--action_7 (32) = happyShift action_34-action_7 _ = happyFail--action_8 (16) = happyShift action_12-action_8 (23) = happyShift action_15-action_8 (24) = happyShift action_16-action_8 (25) = happyShift action_17-action_8 (28) = happyShift action_19-action_8 (34) = happyShift action_20-action_8 (6) = happyGoto action_33-action_8 _ = happyFail--action_9 (15) = happyShift action_11-action_9 (9) = happyGoto action_32-action_9 _ = happyFail--action_10 (16) = happyShift action_12-action_10 (18) = happyShift action_13-action_10 (19) = happyShift action_14-action_10 (23) = happyShift action_15-action_10 (24) = happyShift action_16-action_10 (25) = happyShift action_17-action_10 (28) = happyShift action_19-action_10 (34) = happyShift action_20-action_10 (6) = happyGoto action_29-action_10 (10) = happyGoto action_30-action_10 (11) = happyGoto action_31-action_10 _ = happyReduce_22--action_11 _ = happyReduce_20--action_12 (34) = happyShift action_28-action_12 _ = happyFail--action_13 _ = happyReduce_23--action_14 _ = happyReduce_24--action_15 (34) = happyShift action_27-action_15 _ = happyFail--action_16 (34) = happyShift action_26-action_16 _ = happyFail--action_17 (34) = happyShift action_25-action_17 _ = happyFail--action_18 (34) = happyShift action_24-action_18 _ = happyFail--action_19 _ = happyReduce_11--action_20 (16) = happyShift action_12-action_20 (23) = happyShift action_15-action_20 (24) = happyShift action_16-action_20 (25) = happyShift action_17-action_20 (28) = happyShift action_19-action_20 (34) = happyShift action_20-action_20 (6) = happyGoto action_23-action_20 _ = happyFail--action_21 (33) = happyShift action_22-action_21 _ = happyFail--action_22 (16) = happyShift action_12-action_22 (23) = happyShift action_15-action_22 (24) = happyShift action_16-action_22 (25) = happyShift action_17-action_22 (28) = happyShift action_19-action_22 (34) = happyShift action_20-action_22 (6) = happyGoto action_48-action_22 _ = happyFail--action_23 (30) = happyShift action_35-action_23 (31) = happyShift action_36-action_23 (35) = happyShift action_47-action_23 _ = happyFail--action_24 (28) = happyShift action_40-action_24 (12) = happyGoto action_46-action_24 _ = happyFail--action_25 (22) = happyShift action_45-action_25 _ = happyFail--action_26 (22) = happyShift action_44-action_26 _ = happyFail--action_27 (22) = happyShift action_43-action_27 _ = happyFail--action_28 (21) = happyShift action_42-action_28 _ = happyFail--action_29 (30) = happyShift action_35-action_29 (31) = happyShift action_36-action_29 _ = happyReduce_18--action_30 _ = happyReduce_21--action_31 (18) = happyShift action_13-action_31 (19) = happyShift action_14-action_31 (10) = happyGoto action_30-action_31 (11) = happyGoto action_31-action_31 _ = happyReduce_22--action_32 (16) = happyShift action_12-action_32 (23) = happyShift action_15-action_32 (24) = happyShift action_16-action_32 (25) = happyShift action_17-action_32 (28) = happyShift action_19-action_32 (34) = happyShift action_20-action_32 (6) = happyGoto action_41-action_32 _ = happyFail--action_33 (30) = happyShift action_35-action_33 (31) = happyShift action_36-action_33 _ = happyReduce_17--action_34 (28) = happyShift action_40-action_34 (12) = happyGoto action_39-action_34 _ = happyFail--action_35 (16) = happyShift action_12-action_35 (23) = happyShift action_15-action_35 (24) = happyShift action_16-action_35 (25) = happyShift action_17-action_35 (28) = happyShift action_19-action_35 (34) = happyShift action_20-action_35 (6) = happyGoto action_38-action_35 _ = happyFail--action_36 (16) = happyShift action_12-action_36 (23) = happyShift action_15-action_36 (24) = happyShift action_16-action_36 (25) = happyShift action_17-action_36 (28) = happyShift action_19-action_36 (34) = happyShift action_20-action_36 (6) = happyGoto action_37-action_36 _ = happyFail--action_37 _ = happyReduce_9--action_38 (31) = happyShift action_36-action_38 _ = happyReduce_8--action_39 _ = happyReduce_2--action_40 (28) = happyShift action_40-action_40 (12) = happyGoto action_54-action_40 _ = happyReduce_26--action_41 (30) = happyShift action_35-action_41 (31) = happyShift action_36-action_41 _ = happyReduce_16--action_42 (33) = happyShift action_53-action_42 _ = happyFail--action_43 (33) = happyShift action_52-action_43 _ = happyFail--action_44 (33) = happyShift action_51-action_44 _ = happyFail--action_45 (33) = happyShift action_50-action_45 _ = happyFail--action_46 (35) = happyShift action_49-action_46 _ = happyFail--action_47 _ = happyReduce_10--action_48 (30) = happyShift action_35-action_48 (31) = happyShift action_36-action_48 _ = happyReduce_3--action_49 (27) = happyShift action_59-action_49 _ = happyReduce_14--action_50 (29) = happyShift action_58-action_50 _ = happyFail--action_51 (29) = happyShift action_57-action_51 _ = happyFail--action_52 (29) = happyShift action_56-action_52 _ = happyFail--action_53 (29) = happyShift action_55-action_53 _ = happyFail--action_54 _ = happyReduce_25--action_55 (35) = happyShift action_63-action_55 _ = happyFail--action_56 (21) = happyShift action_62-action_56 _ = happyFail--action_57 (21) = happyShift action_61-action_57 _ = happyFail--action_58 (21) = happyShift action_60-action_58 _ = happyFail--action_59 _ = happyReduce_15--action_60 (33) = happyShift action_66-action_60 _ = happyFail--action_61 (33) = happyShift action_65-action_61 _ = happyFail--action_62 (33) = happyShift action_64-action_62 _ = happyFail--action_63 _ = happyReduce_7--action_64 (29) = happyShift action_69-action_64 _ = happyFail--action_65 (29) = happyShift action_68-action_65 _ = happyFail--action_66 (29) = happyShift action_67-action_66 _ = happyFail--action_67 (17) = happyShift action_71-action_67 (7) = happyGoto action_73-action_67 _ = happyReduce_13--action_68 (17) = happyShift action_71-action_68 (7) = happyGoto action_72-action_68 _ = happyReduce_13--action_69 (17) = happyShift action_71-action_69 (7) = happyGoto action_70-action_69 _ = happyReduce_13--action_70 (35) = happyShift action_76-action_70 _ = happyFail--action_71 _ = happyReduce_12--action_72 (35) = happyShift action_75-action_72 _ = happyFail--action_73 (35) = happyShift action_74-action_73 _ = happyFail--action_74 _ = happyReduce_6--action_75 _ = happyReduce_5--action_76 _ = happyReduce_4--happyReduce_1 = happySpecReduce_1 4 happyReduction_1-happyReduction_1 (HappyAbsSyn5 happy_var_1)- = HappyAbsSyn4- (RegionDec (fst happy_var_1) (snd happy_var_1)- )-happyReduction_1 _ = notHappyAtAll --happyReduce_2 = happyReduce 4 4 happyReduction_2-happyReduction_2 ((HappyAbsSyn12 happy_var_4) `HappyStk`- _ `HappyStk`- (HappyAbsSyn8 happy_var_2) `HappyStk`- _ `HappyStk`- happyRest)- = HappyAbsSyn4- (SpecDec happy_var_2 happy_var_4- ) `HappyStk` happyRest--happyReduce_3 = happyReduce 4 5 happyReduction_3-happyReduction_3 ((HappyAbsSyn6 happy_var_4) `HappyStk`- _ `HappyStk`- (HappyTerminal (TId happy_var_2)) `HappyStk`- _ `HappyStk`- happyRest)- = HappyAbsSyn5- ((happy_var_2, happy_var_4)- ) `HappyStk` happyRest--happyReduce_4 = happyReduce 10 6 happyReduction_4-happyReduction_4 (_ `HappyStk`- (HappyAbsSyn7 happy_var_9) `HappyStk`- (HappyTerminal (TNum happy_var_8)) `HappyStk`- _ `HappyStk`- _ `HappyStk`- (HappyTerminal (TNum happy_var_5)) `HappyStk`- _ `HappyStk`- _ `HappyStk`- _ `HappyStk`- _ `HappyStk`- happyRest)- = HappyAbsSyn6- (Forward (read happy_var_5) (read happy_var_8) happy_var_9- ) `HappyStk` happyRest--happyReduce_5 = happyReduce 10 6 happyReduction_5-happyReduction_5 (_ `HappyStk`- (HappyAbsSyn7 happy_var_9) `HappyStk`- (HappyTerminal (TNum happy_var_8)) `HappyStk`- _ `HappyStk`- _ `HappyStk`- (HappyTerminal (TNum happy_var_5)) `HappyStk`- _ `HappyStk`- _ `HappyStk`- _ `HappyStk`- _ `HappyStk`- happyRest)- = HappyAbsSyn6- (Backward (read happy_var_5) (read happy_var_8) happy_var_9- ) `HappyStk` happyRest--happyReduce_6 = happyReduce 10 6 happyReduction_6-happyReduction_6 (_ `HappyStk`- (HappyAbsSyn7 happy_var_9) `HappyStk`- (HappyTerminal (TNum happy_var_8)) `HappyStk`- _ `HappyStk`- _ `HappyStk`- (HappyTerminal (TNum happy_var_5)) `HappyStk`- _ `HappyStk`- _ `HappyStk`- _ `HappyStk`- _ `HappyStk`- happyRest)- = HappyAbsSyn6- (Centered (read happy_var_5) (read happy_var_8) happy_var_9- ) `HappyStk` happyRest--happyReduce_7 = happyReduce 6 6 happyReduction_7-happyReduction_7 (_ `HappyStk`- (HappyTerminal (TNum happy_var_5)) `HappyStk`- _ `HappyStk`- _ `HappyStk`- _ `HappyStk`- _ `HappyStk`- happyRest)- = HappyAbsSyn6- (Centered 0 (read happy_var_5) True- ) `HappyStk` happyRest--happyReduce_8 = happySpecReduce_3 6 happyReduction_8-happyReduction_8 (HappyAbsSyn6 happy_var_3)- _- (HappyAbsSyn6 happy_var_1)- = HappyAbsSyn6- (Or happy_var_1 happy_var_3- )-happyReduction_8 _ _ _ = notHappyAtAll --happyReduce_9 = happySpecReduce_3 6 happyReduction_9-happyReduction_9 (HappyAbsSyn6 happy_var_3)- _- (HappyAbsSyn6 happy_var_1)- = HappyAbsSyn6- (And happy_var_1 happy_var_3- )-happyReduction_9 _ _ _ = notHappyAtAll --happyReduce_10 = happySpecReduce_3 6 happyReduction_10-happyReduction_10 _- (HappyAbsSyn6 happy_var_2)- _- = HappyAbsSyn6- (happy_var_2- )-happyReduction_10 _ _ _ = notHappyAtAll --happyReduce_11 = happySpecReduce_1 6 happyReduction_11-happyReduction_11 (HappyTerminal (TId happy_var_1))- = HappyAbsSyn6- (Var happy_var_1- )-happyReduction_11 _ = notHappyAtAll --happyReduce_12 = happySpecReduce_1 7 happyReduction_12-happyReduction_12 _- = HappyAbsSyn7- (False- )--happyReduce_13 = happySpecReduce_0 7 happyReduction_13-happyReduction_13 = HappyAbsSyn7- (True- )--happyReduce_14 = happyReduce 4 8 happyReduction_14-happyReduction_14 (_ `HappyStk`- (HappyAbsSyn12 happy_var_3) `HappyStk`- _ `HappyStk`- _ `HappyStk`- happyRest)- = HappyAbsSyn8- (Temporal happy_var_3 False- ) `HappyStk` happyRest--happyReduce_15 = happyReduce 5 8 happyReduction_15-happyReduction_15 (_ `HappyStk`- _ `HappyStk`- (HappyAbsSyn12 happy_var_3) `HappyStk`- _ `HappyStk`- _ `HappyStk`- happyRest)- = HappyAbsSyn8- (Temporal happy_var_3 True- ) `HappyStk` happyRest--happyReduce_16 = happySpecReduce_3 8 happyReduction_16-happyReduction_16 (HappyAbsSyn6 happy_var_3)- (HappyAbsSyn9 happy_var_2)- (HappyAbsSyn10 happy_var_1)- = HappyAbsSyn8- (Spatial (happy_var_1 ++ [happy_var_2]) happy_var_3- )-happyReduction_16 _ _ _ = notHappyAtAll --happyReduce_17 = happySpecReduce_2 8 happyReduction_17-happyReduction_17 (HappyAbsSyn6 happy_var_2)- (HappyAbsSyn9 happy_var_1)- = HappyAbsSyn8- (Spatial [happy_var_1] happy_var_2- )-happyReduction_17 _ _ = notHappyAtAll --happyReduce_18 = happySpecReduce_2 8 happyReduction_18-happyReduction_18 (HappyAbsSyn6 happy_var_2)- (HappyAbsSyn9 happy_var_1)- = HappyAbsSyn8- (Spatial [happy_var_1] happy_var_2- )-happyReduction_18 _ _ = notHappyAtAll --happyReduce_19 = happySpecReduce_1 8 happyReduction_19-happyReduction_19 (HappyAbsSyn6 happy_var_1)- = HappyAbsSyn8- (Spatial [] happy_var_1- )-happyReduction_19 _ = notHappyAtAll --happyReduce_20 = happySpecReduce_1 9 happyReduction_20-happyReduction_20 _- = HappyAbsSyn9- (ReadOnce- )--happyReduce_21 = happySpecReduce_2 10 happyReduction_21-happyReduction_21 (HappyAbsSyn10 happy_var_2)- (HappyAbsSyn9 happy_var_1)- = HappyAbsSyn10- (happy_var_1 : happy_var_2- )-happyReduction_21 _ _ = notHappyAtAll --happyReduce_22 = happySpecReduce_1 10 happyReduction_22-happyReduction_22 (HappyAbsSyn9 happy_var_1)- = HappyAbsSyn10- ([happy_var_1]- )-happyReduction_22 _ = notHappyAtAll --happyReduce_23 = happySpecReduce_1 11 happyReduction_23-happyReduction_23 _- = HappyAbsSyn9- (AtMost- )--happyReduce_24 = happySpecReduce_1 11 happyReduction_24-happyReduction_24 _- = HappyAbsSyn9- (AtLeast- )--happyReduce_25 = happySpecReduce_2 12 happyReduction_25-happyReduction_25 (HappyAbsSyn12 happy_var_2)- (HappyTerminal (TId happy_var_1))- = HappyAbsSyn12- (happy_var_1 : happy_var_2- )-happyReduction_25 _ _ = notHappyAtAll --happyReduce_26 = happySpecReduce_1 12 happyReduction_26-happyReduction_26 (HappyTerminal (TId happy_var_1))- = HappyAbsSyn12- ([happy_var_1]- )-happyReduction_26 _ = notHappyAtAll --happyNewToken action sts stk [] =- action 37 37 notHappyAtAll (HappyState action) sts stk []--happyNewToken action sts stk (tk:tks) =- let cont i = action i i tk (HappyState action) sts stk tks in- case tk of {- TId "stencil" -> cont 13;- TId "region" -> cont 14;- TId "readonce" -> cont 15;- TId "reflexive" -> cont 16;- TId "irreflexive" -> cont 17;- TId "atmost" -> cont 18;- TId "atleast" -> cont 19;- TId "dims" -> cont 20;- TId "dim" -> cont 21;- TId "depth" -> cont 22;- TId "forward" -> cont 23;- TId "backward" -> cont 24;- TId "centered" -> cont 25;- TId "dependency" -> cont 26;- TId "mutual" -> cont 27;- TId happy_dollar_dollar -> cont 28;- TNum happy_dollar_dollar -> cont 29;- TPlus -> cont 30;- TStar -> cont 31;- TDoubleColon -> cont 32;- TEqual -> cont 33;- TLParen -> cont 34;- TRParen -> cont 35;- TComma -> cont 36;- _ -> happyError' (tk:tks)- }--happyError_ 37 tk tks = happyError' tks-happyError_ _ tk tks = happyError' (tk:tks)--happyThen :: () => Either AnnotationParseError a -> (a -> Either AnnotationParseError b) -> Either AnnotationParseError b-happyThen = (>>=)-happyReturn :: () => a -> Either AnnotationParseError a-happyReturn = (return)-happyThen1 m k tks = (>>=) m (\a -> k a tks)-happyReturn1 :: () => a -> b -> Either AnnotationParseError a-happyReturn1 = \a tks -> (return) a-happyError' :: () => [(Token)] -> Either AnnotationParseError a-happyError' = happyError--parseSpec tks = happySomeParser where- happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })--happySeq = happyDontSeq---data Specification- = RegionDec String Region- | SpecDec Spec [String]- deriving (Show, Eq, Ord, Typeable, Data)--data Region- = Forward Int Int Bool- | Backward Int Int Bool- | Centered Int Int Bool- | Or Region Region- | And Region Region- | Var String- deriving (Show, Eq, Ord, Typeable, Data)--data Spec- = Spatial [Mod] Region- | Temporal [String] Bool- deriving (Show, Eq, Ord, Typeable, Data)--data Mod- = AtLeast- | AtMost- | ReadOnce- deriving (Show, Eq, Ord, Typeable, Data)------------------------------------------------------data Token- = TDoubleColon- | TStar- | TPlus- | TEqual- | TComma- | TLParen- | TRParen- | TId String- | TNum String- deriving (Show)--addToTokens :: Token -> String -> Either AnnotationParseError [ Token ]-addToTokens tok rest = do- tokens <- lexer' rest- return $ tok : tokens--stripLeadingWhiteSpace (' ':xs) = stripLeadingWhiteSpace xs-stripLeadingWhiteSpace ('\t':xs) = stripLeadingWhiteSpace xs-stripLeadingWhiteSpace ('\n':xs) = stripLeadingWhiteSpace xs-stripLeadingWhiteSpace xs = xs---lexer :: String -> Either AnnotationParseError [ Token ]-lexer input | length (stripLeadingWhiteSpace input) >= 2 =- case stripLeadingWhiteSpace input of- -- Check the leading character is '=' for specification- '=':input' ->- -- First test to see if the input looks like an actual- -- specification of either a stencil or region- if (input' `hasPrefix` "stencil" || input' `hasPrefix` "region")- then lexer' input'- else Left NotAnnotation- _ -> Left NotAnnotation- where- hasPrefix [] str = False- hasPrefix (' ':xs) str = hasPrefix xs str- hasPrefix xs str = isPrefixOf str xs-lexer _ = Left NotAnnotation---lexer' :: String -> Either AnnotationParseError [ Token ]-lexer' [] = return []-lexer' (' ':xs) = lexer' xs-lexer' ('\t':xs) = lexer' xs-lexer' (':':':':xs) = addToTokens TDoubleColon xs-lexer' ('*':xs) = addToTokens TStar xs-lexer' ('+':xs) = addToTokens TPlus xs-lexer' ('=':xs) = addToTokens TEqual xs--- Comma hack: drop commas that are not separating numbers, in order to avoid need for 2-token lookahead.-lexer' (',':xs)- | x':xs' <- dropWhile isSpace xs, not (isNumber x') = lexer' (x':xs')- | otherwise = addToTokens TComma xs-lexer' ('(':xs) = addToTokens TLParen xs-lexer' (')':xs) = addToTokens TRParen xs-lexer' (x:xs)- | isLetter x = aux TId $ \ c -> isAlphaNum c || c == '_'- | isNumber x = aux TNum isNumber- | otherwise- = failWith $ "Not an indentifier " ++ show x- where- aux f p = (f target :) `fmap` lexer' rest- where (target, rest) = span p (x:xs)-lexer' x- = failWith $ "Not a valid piece of stencil syntax " ++ show x-------------------------------------------------------- specParser :: String -> Either AnnotationParseError Specification-specParser :: AnnotationParser Specification-specParser src = do- tokens <- lexer src- parseSpec tokens >>= modValidate---- Check whether modifiers are used correctly-modValidate :: Specification -> Either AnnotationParseError Specification-modValidate (SpecDec (Spatial mods r) vars) =- do mods' <- modValidate' $ sort mods- return $ SpecDec (Spatial mods' r) vars-- where modValidate' [] = return $ []-- modValidate' (AtLeast : AtLeast : xs)- = failWith "Duplicate 'atLeast' modifier; use at most one."-- modValidate' (AtMost : AtMost : xs)- = failWith "Duplicate 'atMost' modifier; use at most one."-- modValidate' (ReadOnce : ReadOnce : xs)- = failWith "Duplicate 'readOnce' modifier; use at most one."-- modValidate' (AtLeast : AtMost : xs)- = failWith $ "Conflicting modifiers: cannot use 'atLeast' and "- ++ "'atMost' together"-- modValidate' (x : xs)- = do xs' <- modValidate' xs- return $ x : xs'-modValidate x = return x--happyError :: [ Token ] -> Either AnnotationParseError a-happyError t = failWith $ "Could not parse specification at: " ++ show t-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<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
@@ -25,14 +25,11 @@ irreflexive { TId "irreflexive" } atMost { TId "atmost" } atLeast { TId "atleast" }- dims { TId "dims" } dim { TId "dim" } depth { TId "depth" } forward { TId "forward" } backward { TId "backward" } centered { TId "centered" }- dependency { TId "dependency" }- mutual { TId "mutual" } id { TId $$ } num { TNum $$ } '+' { TPlus }@@ -41,7 +38,6 @@ '=' { TEqual } '(' { TLParen } ')' { TRParen }- ',' { TComma } %left '+' %left '*'@@ -55,24 +51,45 @@ REGIONDEC :: { (String, Region) } : region '::' id '=' REGION { ($3, $5) } -REGION :: { Region }-: forward '(' depth '=' num dim '=' num REFL ')' { Forward (read $5) (read $8) $9}-| backward '(' depth '=' num dim '=' num REFL ')' { Backward (read $5) (read $8) $9}-| centered '(' depth '=' num dim '=' num REFL ')' { Centered (read $5) (read $8) $9}-| reflexive '(' dim '=' num ')' { Centered 0 (read $5) True }-| REGION '+' REGION { Or $1 $3 }-| REGION '*' REGION { And $1 $3 }-| '(' REGION ')' { $2 }-| id { Var $1 }+REGION :: { Region }+: forward '(' REGION_ATTRS ')' { applyAttr Forward $3 }+| backward '(' REGION_ATTRS ')' { applyAttr Backward $3 }+| centered '(' REGION_ATTRS ')' { applyAttr Centered $3 }+| reflexive '(' dim '=' num ')' { Centered 0 (read $5) True }+| REGION '+' REGION { Or $1 $3 }+| REGION '*' REGION { And $1 $3 }+| '(' REGION ')' { $2 }+| id { Var $1 } +REGION_ATTRS :: { (Depth Int, Dim Int, Bool) }+ : DEPTH DIM_REFL { ($1, fst $2, snd $2) }+ | DIM DEPTH_REFL { (fst $2, $1, snd $2) }+ | REFL DEPTH DIM { ($2, $3, $1) }+ | REFL DIM DEPTH { ($3, $2, $1) }++DIM_REFL :: { (Dim Int, Bool) }+DIM_REFL+ : REFL DIM { ($2, $1) }+ | DIM REFL { ($1, $2) }+ | DIM { ($1, True) }++DEPTH_REFL :: { (Depth Int, Bool) }+DEPTH_REFL+ : DEPTH REFL { ($1, $2) }+ | REFL DEPTH { ($2, $1) }+ | DEPTH { ($1, True) }++DEPTH :: { Depth Int }+DEPTH : depth '=' num { Depth $ read $3 }++DIM :: { Dim Int }+DIM : dim '=' num { Dim $ read $3 }+ REFL :: { Bool } : irreflexive { False }- | {- empty -} { True } SPECDEC :: { Spec }-: dependency '(' VARS ')' { Temporal $3 False }-| dependency '(' VARS ')' mutual { Temporal $3 True }-| APPROXMODS MOD REGION { Spatial ($1 ++ [$2]) $3 }+: APPROXMODS MOD REGION { Spatial ($1 ++ [$2]) $3 } | MOD REGION { Spatial [$1] $2 } | APPROXMOD REGION { Spatial [$1] $2 } | REGION { Spatial [] $1 }@@ -96,7 +113,14 @@ | id { [$1] } {+newtype Depth a = Depth a+newtype Dim a = Dim a +applyAttr :: (Int -> Int -> Bool -> Region)+ -> (Depth Int, Dim Int, Bool)+ -> Region+applyAttr constr (Depth d, Dim dim, irrefl) = constr d dim irrefl+ data Specification = RegionDec String Region | SpecDec Spec [String]@@ -111,9 +135,7 @@ | Var String deriving (Show, Eq, Ord, Typeable, Data) -data Spec- = Spatial [Mod] Region- | Temporal [String] Bool+data Spec = Spatial [Mod] Region deriving (Show, Eq, Ord, Typeable, Data) data Mod@@ -151,14 +173,18 @@ lexer input | length (stripLeadingWhiteSpace input) >= 2 = case stripLeadingWhiteSpace input of -- Check the leading character is '=' for specification- '=':input' ->- -- First test to see if the input looks like an actual- -- specification of either a stencil or region- if (input' `hasPrefix` "stencil" || input' `hasPrefix` "region")- then lexer' input'- else Left NotAnnotation+ '=':input' -> testAnnotation input'+ '!':input' -> testAnnotation input'+ '>':input' -> testAnnotation input'+ '<':input' -> testAnnotation input' _ -> Left NotAnnotation- where+ where+ testAnnotation inp =+ -- First test to see if the input looks like an actual+ -- specification of either a stencil or region+ if (inp `hasPrefix` "stencil" || inp `hasPrefix` "region")+ then lexer' inp+ else Left NotAnnotation hasPrefix [] str = False hasPrefix (' ':xs) str = hasPrefix xs str hasPrefix xs str = isPrefixOf str xs
src/Camfort/Specification/Stencils/InferenceBackend.hs view
@@ -47,28 +47,28 @@ mkTrivialSpan a = (a, a) inferFromIndices :: VecList Int -> Specification-inferFromIndices (VL ixs) =- setLinearity (fromBool mult) (Specification . Left . infer $ ixs')- where- (ixs', mult) = hasDuplicates ixs- infer :: (IsNatural n, Permutable n) => [Vec n Int] -> Result Spatial- infer = simplify . fromRegionsToSpec . inferMinimalVectorRegions+inferFromIndices (VL ixs) = Specification $+ case fromBool mult of+ Linear -> Single $ inferCore ixs'+ NonLinear -> Multiple $ inferCore ixs'+ where+ (ixs', mult) = hasDuplicates ixs -- Same as inferFromIndices but don't do any linearity checking -- (defaults to NonLinear). This is used when the front-end does -- the linearity check first as an optimimsation. inferFromIndicesWithoutLinearity :: VecList Int -> Specification inferFromIndicesWithoutLinearity (VL ixs) =- Specification . Left . infer $ ixs- where- infer :: (IsNatural n, Permutable n) => [Vec n Int] -> Result Spatial- infer = simplify . fromRegionsToSpec . inferMinimalVectorRegions+ Specification . Multiple . inferCore $ ixs -simplify :: Result Spatial -> Result Spatial+inferCore :: (IsNatural n, Permutable n) => [Vec n Int] -> Approximation Spatial+inferCore = simplify . fromRegionsToSpec . inferMinimalVectorRegions++simplify :: Approximation Spatial -> Approximation Spatial simplify = fmap simplifySpatial simplifySpatial :: Spatial -> Spatial-simplifySpatial (Spatial lin (Sum ps)) = Spatial lin (Sum ps')+simplifySpatial (Spatial (Sum ps)) = Spatial (Sum ps') where ps' = order (reducor ps normaliseNoSort size) order = sort . (map (Product . sort . unProd)) size :: [RegionProd] -> Int@@ -88,51 +88,51 @@ else reducor' ys where y' = f y -fromRegionsToSpec :: IsNatural n => [Span (Vec n Int)] -> Result Spatial-fromRegionsToSpec sps = foldr (\x y -> sum (toSpecND x) y) zero sps+fromRegionsToSpec :: IsNatural n => [Span (Vec n Int)] -> Approximation Spatial+fromRegionsToSpec = foldr (\x y -> sum (toSpecND x) y) zero -- toSpecND converts an n-dimensional region into an exact -- spatial specification or a bound of spatial specifications-toSpecND :: Span (Vec n Int) -> Result Spatial+toSpecND :: Span (Vec n Int) -> Approximation Spatial toSpecND = toSpecPerDim 1 where -- convert the region one dimension at a time.- toSpecPerDim :: Int -> Span (Vec n Int) -> Result Spatial+ toSpecPerDim :: Int -> Span (Vec n Int) -> Approximation Spatial toSpecPerDim d (Nil, Nil) = one toSpecPerDim d (Cons l ls, Cons u us) = prod (toSpec1D d l u) (toSpecPerDim (d + 1) (ls, us)) -- toSpec1D takes a dimension identifier, a lower and upper bound of a region in -- that dimension, and builds the simple directional spec.-toSpec1D :: Dimension -> Int -> Int -> Result Spatial+toSpec1D :: Dimension -> Int -> Int -> Approximation Spatial toSpec1D dim l u | l == absoluteRep || u == absoluteRep =- Exact $ Spatial NonLinear (Sum [Product []])+ Exact $ Spatial (Sum [Product []]) | l == 0 && u == 0 =- Exact $ Spatial NonLinear (Sum [Product [Centered 0 dim True]])+ Exact $ Spatial (Sum [Product [Centered 0 dim True]]) | l < 0 && u == 0 =- Exact $ Spatial NonLinear (Sum [Product [Backward (abs l) dim True]])+ Exact $ Spatial (Sum [Product [Backward (abs l) dim True]]) | l < 0 && u == (-1) =- Exact $ Spatial NonLinear (Sum [Product [Backward (abs l) dim False]])+ Exact $ Spatial (Sum [Product [Backward (abs l) dim False]]) | l == 0 && u > 0 =- Exact $ Spatial NonLinear (Sum [Product [Forward u dim True]])+ Exact $ Spatial (Sum [Product [Forward u dim True]]) | l == 1 && u > 0 =- Exact $ Spatial NonLinear (Sum [Product [Forward u dim False]])+ Exact $ Spatial (Sum [Product [Forward u dim False]]) | l < 0 && u > 0 && (abs l == u) =- Exact $ Spatial NonLinear (Sum [Product [Centered u dim True]])+ Exact $ Spatial (Sum [Product [Centered u dim True]]) | l < 0 && u > 0 && (abs l /= u) =- Exact $ Spatial NonLinear (Sum [Product [Backward (abs l) dim True],- Product [Forward u dim True]])+ Exact $ Spatial (Sum [Product [Backward (abs l) dim True],+ Product [Forward u dim True]]) -- Represents a non-contiguous region | otherwise =- upperBound $ Spatial NonLinear (Sum [Product+ upperBound $ Spatial (Sum [Product [if l > 0 then Forward u dim True else Backward (abs l) dim True]]) {- Normalise a span into the form (lower, upper) based on the first index -}
src/Camfort/Specification/Stencils/InferenceFrontend.hs view
@@ -79,28 +79,26 @@ type LogLine = (FU.SrcSpan, Either [([Variable], Specification)] (String,Variable)) -- The core of the inferer works within this monad type Inferer = WriterT [LogLine]- (ReaderT (Cycles, F.ProgramUnitName)+ (ReaderT (FAD.FlowsGraph A) (State InferState)) -type Cycles = [(F.Name, F.Name)]- type Params = (?flowsGraph :: FAD.FlowsGraph A, ?nameMap :: FAR.NameMap) runInferer :: FAD.InductionVarMapByASTBlock- -> Cycles- -> F.ProgramUnitName+ -> FAD.FlowsGraph A -> Inferer a -> (a, [LogLine])-runInferer ivmap cycles puName =+runInferer ivmap flTo = flip evalState (IS ivmap [])- . flip runReaderT (cycles, puName)+ . flip runReaderT flTo . runWriterT stencilInference :: FAR.NameMap -> InferMode+ -> Char -> F.ProgramFile (FA.Analysis A) -> (F.ProgramFile (FA.Analysis A), [LogLine])-stencilInference nameMap mode pf =+stencilInference nameMap mode marker pf = (F.ProgramFile mi cm_pus' blocks', log1 ++ log2) where -- Parse specification annotations and include them into the syntax tree@@ -114,10 +112,10 @@ else (pf, []) (cm_pus', log1) = runWriter (transformBiM perPU cm_pus)- (blocks', log2) = runInferer ivMap [] F.NamelessBlockData blocksInf+ (blocks', log2) = runInferer ivMap flTo blocksInf blocksInf = let ?flowsGraph = flTo ?nameMap = nameMap- in descendBiM (perBlockInfer mode) blocks+ in descendBiM (perBlockInfer mode marker) blocks -- Run inference per program unit, placing the flowsmap in scope perPU :: F.ProgramUnit (FA.Analysis A)@@ -127,8 +125,8 @@ let ?flowsGraph = flTo ?nameMap = nameMap in do- let pum = descendBiM (perBlockInfer mode) pu- let (pu', log) = runInferer ivMap [] (FA.puName pu) pum+ let pum = descendBiM (perBlockInfer mode marker) pu+ let (pu', log) = runInferer ivMap flTo pum tell log return pu' perPU pu = return pu@@ -155,26 +153,6 @@ -- get map of variable name ==> { defining AST-Block-IDs } dm = FAD.genDefMap bm --- | Return list of variable names that flow into themselves via a 2-cycle-findVarFlowCycles :: Data a => F.ProgramFile a -> [(F.Name, F.Name)]-findVarFlowCycles = FAR.underRenaming (findVarFlowCycles' . FAB.analyseBBlocks)-findVarFlowCycles' pf = cycs2- where- bm = FAD.genBlockMap pf -- get map of AST-Block-ID ==> corresponding AST-Block- bbm = FAB.genBBlockMap pf -- get map of program unit ==> basic block graph- sgr = FAB.genSuperBBGr bbm -- stitch all of the graphs together into a 'supergraph'- gr = FAB.superBBGrGraph sgr -- extract the supergraph itself- dm = FAD.genDefMap bm -- get map of variable name ==> { defining AST-Block-IDs }- rd = FAD.reachingDefinitions dm gr -- perform reaching definitions analysis- flTo = FAD.genFlowsToGraph bm dm gr rd -- create graph of definition "flows"- -- VarFlowsToMap: A -> { B, C } indicates that A contributes to B, C.- flMap = FAD.genVarFlowsToMap dm flTo -- create VarFlowsToMap- -- find 2-cycles: A -> B -> A- cycs2 = [ (n, m) | (n, ns) <- M.toList flMap- , m <- S.toList ns- , ms <- maybeToList $ M.lookup m flMap- , n `S.member` ms && n /= m ]- {- *** 1 . Core inference over blocks -} genSpecsAndReport :: Params@@ -211,9 +189,10 @@ -- Traverse Blocks in the AST and infer stencil specifications perBlockInfer :: Params- => InferMode -> F.Block (FA.Analysis A) -> Inferer (F.Block (FA.Analysis A))+ => InferMode -> Char -> F.Block (FA.Analysis A)+ -> Inferer (F.Block (FA.Analysis A)) -perBlockInfer Synth b@(F.BlComment ann span _) = do+perBlockInfer Synth _ b@(F.BlComment ann span _) = do -- If we have a comment that is actually a specification then record that -- this has been assigned so that we don't generate extra specifications -- that overlap with user-given oones@@ -231,7 +210,7 @@ _ -> return () return b -perBlockInfer mode b@(F.BlStatement ann span@(FU.SrcSpan lp up) _ stmnt)+perBlockInfer mode marker b@(F.BlStatement ann span@(FU.SrcSpan lp up) _ stmnt) | mode == AssignMode || mode == CombinedMode || mode == EvalMode || mode == Synth = do -- On all StExpressionAssigns that occur in stmt.... let lhses = [lhs | (F.StExpressionAssign _ _ lhs _)@@ -256,7 +235,7 @@ _ -> return []) if mode == Synth && not (null specs) then- let specComment = Synth.formatSpec (Just (tabs ++ "!= ")) ?nameMap (span, Left (concat specs'))+ let specComment = Synth.formatSpec (Just (tabs ++ '!':marker:" ")) ?nameMap (span, Left (concat specs')) specs' = map (mapMaybe noSpecAlready) specs noSpecAlready (vars, spec) = if null vars'@@ -265,13 +244,13 @@ where vars' = filter (\v -> not ((span, realName v) `elem` hasSpec)) vars realName v = v `fromMaybe` (v `M.lookup` ?nameMap) tabs = take (FU.posColumn lp - 1) (repeat ' ')- loc = fst $ O.srcSpanToSrcLocs span+ (FU.SrcSpan loc _) = span span' = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) ann' = ann { FA.prevAnnotation = (FA.prevAnnotation ann) { refactored = Just loc } } in return $ F.BlComment ann' span' specComment else return b -perBlockInfer mode b@(F.BlDo ann span x mDoSpec body) = do+perBlockInfer mode marker b@(F.BlDo ann span lab cname lab' mDoSpec body tlab) = do -- introduce any induction variables into the induction variable state if (mode == DoMode || mode == CombinedMode) && isStencilDo b@@ -279,13 +258,13 @@ else return [] -- descend into the body of the do-statement- body' <- mapM (descendBiM (perBlockInfer mode)) body+ body' <- mapM (descendBiM (perBlockInfer mode marker)) body -- Remove any induction variable from the state- return $ F.BlDo ann span x mDoSpec body'+ return $ F.BlDo ann span lab cname lab' mDoSpec body' tlab -perBlockInfer mode b = do+perBlockInfer mode marker b = do -- Go inside child blocks- mapM_ (descendBiM (perBlockInfer mode)) $ children b+ mapM_ (descendBiM (perBlockInfer mode marker)) $ children b return b genSpecifications :: Params@@ -309,15 +288,32 @@ . M.mapWithKey (\v -> indicesToSpec ivs v lhs) . M.unionsWith (++) - strength :: Monad m => (a, m b) -> m (a, b)- strength (a, mb) = mb >>= (\b -> return (a, b))- splitUpperAndLower = concatMap splitUpperAndLower'- splitUpperAndLower' (vs, Specification (Left (Bound (Just l) (Just u)))) =- [(vs, Specification (Left (Bound (Just l) Nothing))),- (vs, Specification (Left (Bound Nothing (Just u))))]+ splitUpperAndLower' (vs, Specification (Multiple (Bound (Just l) (Just u)))) =+ [(vs, Specification (Multiple (Bound (Just l) Nothing))),+ (vs, Specification (Multiple (Bound Nothing (Just u))))]+ splitUpperAndLower' (vs, Specification (Single (Bound (Just l) (Just u)))) =+ [(vs, Specification (Single (Bound (Just l) Nothing))),+ (vs, Specification (Single (Bound Nothing (Just u))))] splitUpperAndLower' x = [x] +genOffsets :: Params+ => FAD.InductionVarMapByASTBlock+ -> [Neighbour]+ -> [F.Block (FA.Analysis A)]+ -> Writer EvalLog [(Variable, (Bool, [[Int]]))]+genOffsets ivs lhs blocks = do+ let subscripts = evalState (mapM (genSubscripts True) blocks) []+ varToMaybeSpecs <- sequence . map strength . mkOffsets $ subscripts+ return $ catMaybes . map strength $ varToMaybeSpecs+ where+ mkOffsets = M.toList+ . M.mapWithKey (\v -> indicesToRelativisedOffsets ivs v lhs)+ . M.unionsWith (++)++strength :: Monad m => (a, m b) -> m (a, b)+strength (a, mb) = mb >>= (\b -> return (a, b))+ -- Generate all subscripting expressions (that are translations on -- induction variables) that flow to this block -- The State monad provides a list of the visited nodes so far@@ -366,7 +362,7 @@ getInductionVar _ = [] isStencilDo :: F.Block (FA.Analysis A) -> Bool-isStencilDo b@(F.BlDo _ span _ mDoSpec body) =+isStencilDo b@(F.BlDo _ span _ _ _ mDoSpec body _) = -- Check to see if the body contains any affine use of the induction variable -- as a subscript case getInductionVar mDoSpec of@@ -396,6 +392,18 @@ -> [[F.Index (FA.Analysis Annotation)]] -> Writer EvalLog (Maybe Specification) indicesToSpec ivs a lhs ixs = do+ mMultOffsets <- indicesToRelativisedOffsets ivs a lhs ixs+ return $ do+ (mult, offsets) <- mMultOffsets+ let spec = relativeIxsToSpec offsets+ fmap (setLinearity (fromBool mult)) spec++indicesToRelativisedOffsets :: FAD.InductionVarMapByASTBlock+ -> Variable+ -> [Neighbour]+ -> [[F.Index (FA.Analysis Annotation)]]+ -> Writer EvalLog (Maybe (Bool, [[Int]]))+indicesToRelativisedOffsets ivs a lhs ixs = do -- Convert indices to neighbourhood representation let rhses = map (map (ixToNeighbour ivs)) ixs @@ -423,14 +431,11 @@ let offsets = padZeros $ map (fromJust . mapM neighbourToOffset) rhses'' tell [("EVALMODE: dimensionality=" ++- show (case offsets of [] -> 0- _ -> length (head offsets)), a)]--- let spec = relativeIxsToSpec offsets- return $ fmap (setLinearity (fromBool mult)) spec+ show (if null offsets then 0 else length . head $ offsets), a)]+ return (Just $ (mult, offsets)) where hasNonNeighbourhoodRelatives xs = or (map (any ((==) NonNeighbour)) xs) + -- Given a list of the neighbourhood representation for the LHS, of size n -- and a list of size-n lists of offsets, relativise the offsets relativise :: [Neighbour] -> [[Neighbour]] -> [[Neighbour]]@@ -575,8 +580,6 @@ <- universeBi e :: [F.Expression (FA.Analysis a)] , let i = FA.varName e , i `elem` ivs]--expToNeighbour ivs e = Constant (F.ValInteger "0") --------------------------------------------------
src/Camfort/Specification/Stencils/Model.hs view
@@ -37,50 +37,46 @@ import qualified Data.List as DL import qualified Data.Map as DM -import Debug.Trace---- Relative multi-dimensional indices are represented by [Int]--- e.g. [0, 1, -1] corresponds to a subscript expression a(i, j+1, k-1)--- Specifications are mapped to (multi)sets of [Int] where--- the multiset representation is a Map to Bool giving--- False = multiplicity 1, True = multiplicity > 1--model :: Result Spatial -> Result (Multiset [Int])-model s = let ?globalDimensionality = dimensionality s- in mkModel s+{-| This function maps inner representation to a set of vectors of length+- given by `dim`. This is the mathematical representation of the+- specification. |-}+model :: Multiplicity (Approximation Spatial)+ -> Int+ -> Multiplicity (Approximation (Set [Int]))+model s dims =+ let ?globalDimensionality = dims+ in mkModel s --- Is an inferred specification equal to a declared specification,--- up to the mode? The first parameter must come from the inference and--- the second from a user-given declaration-eqByModel :: Specification -> Specification -> Bool-eqByModel infered declared =- let d1 = dimensionality infered- d2 = dimensionality declared- in let ?globalDimensionality = d1 `max` d2- in let modelInf = mkModel infered- modelDec = mkModel declared- in case (modelInf, modelDec) of- -- Test approximations first+consistent :: Multiplicity [[Int]]+ -> Multiplicity (Approximation Spatial)+ -> Bool+-- If the specification says "readOnce" but there are duplicates among+-- offsets, then there is no consistency.+--+-- Note that if the spec omits "readOnce" and the offsets happen to be+-- unique that is allowed as "readOnce" is an extra qualifier.+consistent (Multiple _) (Single _) = False+consistent mult1 spec =+ consistent' (model spec dimensionality)+ where+ dimensionality = length . head $ accesses+ consistent' m2 =+ case fromMult m2 of+ Exact unifiers ->+ consistent' (Multiple (Bound Nothing (Just unifiers))) &&+ consistent' (Multiple (Bound (Just unifiers) Nothing))+ Bound lus@Just{} uus@Just{} ->+ consistent' (Multiple (Bound lus Nothing)) &&+ consistent' (Multiple (Bound Nothing uus))+ Bound Nothing (Just unifiers) ->+ all (\access -> any (access `accepts`) unifiers) accesses+ Bound (Just unifiers) Nothing ->+ all (\unifier -> any (`accepts` unifier) accesses) unifiers - -- If only one bound is present in one model, but both are in the- -- other, then compare only the bounds present in both- (Bound (Just mdlLI) Nothing, Bound (Just mdlLD) _)- -> mdlLD <= mdlLI- (Bound Nothing (Just mdlUI), Bound _ (Just mdlUD))- -> mdlUI <= mdlUD- (Bound (Just mdlLI) (Just _), Bound (Just mdlLD) Nothing)- -> mdlLD <= mdlLI- (Bound (Just _ ) (Just mdlUI), Bound Nothing (Just mdlUD))- -> mdlUI <= mdlUD- (Exact s, Bound Nothing (Just mdlUD))- -> s <= mdlUD- (Exact s, Bound (Just mdlLD) Nothing)- -> mdlLD <= s- (Exact s, Bound (Just mdlLD) (Just mdlUD))- -> (mdlLD <= s) && (s <= mdlUD)- -- Otherwise do the normal comparison- (x, y) -> x == y+ accesses = fromMult mult1 + access `accepts` unifier =+ all (\(u,v) -> v == absoluteRep || u == v) (zip access unifier) -- Recursive `Model` class implemented for all parts of the spec. class Model spec where@@ -98,38 +94,37 @@ -- Return all the dimensions specified for in this spec dimensions :: spec -> [Int] --- Multiset representation where multiplicities are (-1) modulo 2+-- Set representation where multiplicities are (-1) modulo 2 -- that is, False = multiplicity 1, True = multiplicity > 1-type Multiset a = DM.Map a Bool+instance Model Specification where+ type Domain Specification = Multiplicity (Approximation (Set [Int])) --- Build a multiset representation from a list (of possibly repeated) elements-mkMultiset :: Ord a => [a] -> DM.Map a Bool-mkMultiset =- Prelude.foldr (\a map -> DM.insertWithKey multi a True map) DM.empty- where multi k x y = x || y+ mkModel (Specification s) = mkModel s -instance Model Specification where- type Domain Specification = Result (Multiset [Int])+ dimensionality (Specification s) = dimensionality s - mkModel (Specification (Left s)) = mkModel s- mkModel _ = error "Only spatial specs are modelled"+ dimensions (Specification s) = dimensions s - dimensionality (Specification (Left s)) = dimensionality s- dimensionality _ = 0+instance Model (Multiplicity (Approximation Spatial)) where+ type Domain (Multiplicity (Approximation Spatial)) =+ Multiplicity (Approximation (Set [Int])) - dimensions (Specification (Left s)) = dimensions s- dimensions _ = [0]+ mkModel (Multiple s) = Multiple (mkModel s)+ mkModel (Single s) = Single (mkModel s) --- Model a 'Result' of 'Spatial'-instance Model (Result Spatial) where- type Domain (Result Spatial) = Result (Multiset [Int])+ dimensionality mult = dimensionality $ fromMult mult + dimensions mult = dimensions $ fromMult mult++instance Model (Approximation Spatial) where+ type Domain (Approximation Spatial) = Approximation (Set [Int])+ mkModel = fmap mkModel dimensionality (Exact s) = dimensionality s- dimensionality (Bound l u) = (dimensionality l) `max` (dimensionality u)+ dimensionality (Bound l u) = dimensionality l `max` dimensionality u dimensions (Exact s) = dimensions s- dimensions (Bound l u) = (dimensions l) ++ (dimensions u)+ dimensions (Bound l u) = dimensions l ++ dimensions u -- Lifting of model to Maybe type instance Model a => Model (Maybe a) where@@ -143,18 +138,13 @@ -- Core part of the model instance Model Spatial where- type Domain Spatial = Multiset [Int]+ type Domain Spatial = Set [Int] - mkModel spec@(Spatial lin s) =- case lin of- Linear -> DM.fromList . map (,False) . toList $ indices- NonLinear -> DM.fromList . map (,True) . toList $ indices- where- indices = mkModel s+ mkModel (Spatial s) = mkModel s - dimensionality (Spatial _ s) = dimensionality s+ dimensionality (Spatial s) = dimensionality s - dimensions (Spatial _ s) = dimensions s+ dimensions (Spatial s) = dimensions s instance Model RegionSum where
src/Camfort/Specification/Stencils/Syntax.hs view
@@ -19,7 +19,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveFunctor #-} module Camfort.Specification.Stencils.Syntax where @@ -42,21 +42,21 @@ {- *** 0. Representations -} -- Representation of an inference result, either exact or with some bound-data Result a =+data Approximation a = Exact a | Bound (Maybe a) (Maybe a) deriving (Eq, Data, Typeable, Show) -fromExact :: Result a -> a+fromExact :: Approximation a -> a fromExact (Exact a) = a fromExact _ = error "Exception: fromExact on a non-exact result" -upperBound :: a -> Result a+upperBound :: a -> Approximation a upperBound x = Bound Nothing (Just x) -lowerBound :: a -> Result a+lowerBound :: a -> Approximation a lowerBound x = Bound (Just x) Nothing -instance Functor Result where+instance Functor Approximation where fmap f (Exact x) = Exact (f x) fmap f (Bound x y) = Bound (fmap f x) (fmap f y) @@ -81,7 +81,7 @@ pprintSpecDecls :: SpecDecls -> String pprintSpecDecls = concatMap (\(names, spec) ->- show spec ++ " :: " ++ (intercalate "," names) ++ "\n")+ show spec ++ " :: " ++ intercalate "," names ++ "\n") lookupAggregate :: Eq a => [([a], b)] -> a -> [b] lookupAggregate [] _ = []@@ -92,29 +92,20 @@ -- Top-level of specifications: may be either spatial or temporal data Specification =- Specification (Either (Result Spatial) Temporal)+ Specification (Multiplicity (Approximation Spatial)) deriving (Eq, Data, Typeable) --- ***********************--- Temporal specifications:--- Defines a list of variables which the subject--- of the specification depends upon-data Temporal = Dependency [String] Bool- deriving (Eq, Data, Typeable)+isEmpty :: Specification -> Bool+isEmpty (Specification mult) = isUnit . fromMult $ mult -- ********************** -- Spatial specifications:--- Comprises some modifiers on spatial specifications:--- * linearity--- * irreflexivity--- with the region, which is a regionSum+-- is a regionSum -- -- Regions are in disjunctive normal form (with respect to -- products on dimensions and sums): -- i.e., (A * B) U (C * D)...-data Spatial =- Spatial { modLinearity :: Linearity,- region :: RegionSum }+data Spatial = Spatial RegionSum deriving (Eq, Data, Typeable) -- Helpers for dealing with linearity information@@ -128,25 +119,20 @@ hasDuplicates :: Eq a => [a] -> ([a], Bool) hasDuplicates xs = (nub xs, nub xs /= xs) -setLinearity :: Linearity -> Specification -> Specification-setLinearity l (Specification (Left (Exact s))) =- Specification (Left (Exact (s { modLinearity = l })))-setLinearity l (Specification (Left (Bound sl su))) =- Specification (Left (Bound (sl >>= \s -> return $ s { modLinearity = l })- (su >>= \s -> return $ s { modLinearity = l })))-setLinearity l s = s--emptySpec = Specification . Left $ (one :: Result Spatial)-emptySpatialSpec = one :: Spatial+fromMult :: Multiplicity a -> a+fromMult (Multiple a) = a+fromMult (Single a) = a --- `isEmpty` predicate on which specifications are vacuous or--- functional empty (i.e., show not be displayed in an inference setting).-isEmpty :: Specification -> Bool-isEmpty (Specification (Right (Dependency [] _))) = True-isEmpty (Specification (Left s)) = isUnit s+setLinearity :: Linearity -> Specification -> Specification+setLinearity l (Specification mult)+ | l == Linear = Specification $ Single $ fromMult mult+ | l == NonLinear = Specification $ Multiple $ fromMult mult data Linearity = Linear | NonLinear deriving (Eq, Data, Typeable) +data Multiplicity a = Multiple a | Single a+ deriving (Eq, Data, Typeable, Functor, Show)+ type Dimension = Int -- spatial dimensions are 1 indexed type Depth = Int type IsRefl = Bool@@ -178,9 +164,9 @@ | otherwise = dep <= dep' -- Order in the way defined above: Forward <: Backward <: Centered- (Forward _ _ _) <= _ = True- (Backward _ _ _) <= (Centered _ _ _) = True- _ <= _ = False+ Forward{} <= _ = True+ Backward{} <= Centered{} = True+ _ <= _ = False -- Product of specifications newtype RegionProd = Product {unProd :: [Region]}@@ -196,33 +182,6 @@ -- Operations on specifications -specPlus :: Specification -> Specification -> Maybe Specification--specPlus (Specification (Left (Bound (Just l) Nothing)))- (Specification (Left (Bound Nothing (Just u)))) =- Just $ Specification (Left (Bound (Just l) (Just u)))--specPlus (Specification (Left (Bound Nothing (Just u))))- (Specification (Left (Bound (Just l) Nothing))) =- Just $ Specification (Left (Bound (Just l) (Just u)))--specPlus (Specification (Left (Bound (Just l1) Nothing)))- (Specification (Left (Bound (Just l2) Nothing))) =- Just $ Specification (Left (Bound (Just $ l1 `sum` l2) Nothing))--specPlus (Specification (Left (Bound Nothing (Just l1))))- (Specification (Left (Bound Nothing (Just l2)))) =- Just $ Specification (Left (Bound Nothing (Just $ l1 `sum` l2)))--specPlus (Specification (Left (Exact s1))) (Specification (Left (Exact s2))) =- Just $ Specification (Left (Exact $ s1 `sum` s2))--specPlus (Specification (Right (Dependency vs1 m1)))- (Specification (Right (Dependency vs2 m2))) | m1 == m2=- Just $ Specification (Right (Dependency (vs1 ++ vs2) m1))--specPlus _ _ = Nothing- regionPlus :: Region -> Region -> Maybe Region regionPlus (Forward dep dim reflx) (Backward dep' dim' reflx') | dep == dep' && dim == dim' = Just $ Centered dep dim (reflx || reflx')@@ -264,13 +223,13 @@ absorbReflexive' [] [] = Just ([], []) absorbReflexive' (Forward d dim reflx : rs) [Centered 0 dim' _]- | dim == dim' = Just ((Forward d dim True):rs, [])+ | dim == dim' = Just (Forward d dim True:rs, []) absorbReflexive' (Backward d dim reflx : rs) [Centered 0 dim' _]- | dim == dim' = Just ((Backward d dim True):rs, [])+ | dim == dim' = Just (Backward d dim True:rs, []) absorbReflexive' (Centered d dim reflx : rs) [Centered 0 dim' _]- | dim == dim' && d /= 0 = Just ((Centered d dim True):rs, [])+ | dim == dim' && d /= 0 = Just (Centered d dim True:rs, []) absorbReflexive' _ _ = Nothing @@ -398,29 +357,17 @@ isUnit Nothing = True isUnit (Just x) = isUnit x -instance RegionRig Linearity where- sum Linear Linear = Linear- sum _ _ = NonLinear- prod = sum- one = Linear- zero = Linear-- isUnit Linear = True- isUnit _ = False- instance RegionRig Spatial where- sum (Spatial lin s) (Spatial lin' s') =- Spatial (sum lin lin') (sum s s')+ sum (Spatial s) (Spatial s') = Spatial (sum s s') - prod (Spatial lin s) (Spatial lin' s') =- Spatial (prod lin lin') (prod s s')+ prod (Spatial s) (Spatial s') = Spatial (prod s s') - one = Spatial one one- zero = Spatial zero zero+ one = Spatial one+ zero = Spatial zero - isUnit (Spatial _ ss) = isUnit ss+ isUnit (Spatial ss) = isUnit ss -instance RegionRig (Result Spatial) where+instance RegionRig (Approximation Spatial) where sum (Exact s) (Exact s') = Exact (sum s s') sum (Exact s) (Bound l u) = Bound (sum (Just s) l) (sum (Just s) u) sum (Bound l u) (Bound l' u') = Bound (sum l l') (sum u u')@@ -446,7 +393,7 @@ sum (Sum ss) (Sum ss') = Sum $ normalise $ ss ++ ss' zero = Sum [] one = Sum [Product []]- isUnit s@(Sum ss) = s == zero || s == one || all ((==) (Product [])) ss+ isUnit s@(Sum ss) = s == zero || s == one || all (== Product []) ss -- Show a list with ',' separator showL :: Show a => [a] -> String@@ -459,10 +406,24 @@ -- Pretty print top-level specifications instance Show Specification where- show (Specification (Left sp)) = "stencil " ++ show sp- show (Specification (Right sp)) = "stencil " ++ show sp+ show (Specification sp) = "stencil " ++ show sp -instance {-# OVERLAPS #-} Show (Result Spatial) where+instance {-# OVERLAPS #-} Show (Multiplicity (Approximation Spatial)) where+ show mult+ | Multiple appr <- mult = apprStr empty appr+ | Single appr <- mult = apprStr "readOnce, " appr+ where+ apprStr linearity appr =+ case appr of+ Exact s -> linearity ++ show s+ Bound Nothing Nothing -> "empty"+ Bound Nothing (Just s) -> "atMost, " ++ linearity ++ show s+ Bound (Just s) Nothing -> "atLeast, " ++ linearity ++ show s+ Bound (Just sL) (Just sU) ->+ "atLeast, " ++ linearity ++ show sL +++ "; atMost, " ++ linearity ++ show sU++instance {-# OVERLAPS #-} Show (Approximation Spatial) where show (Exact s) = show s show (Bound Nothing Nothing) = "empty" show (Bound Nothing (Just s)) = "atMost, " ++ show s@@ -472,21 +433,11 @@ -- Pretty print spatial specs instance Show Spatial where- show (Spatial modLin region) =- intercalate ", " . catMaybes $ [lin, sregion]- where- -- Map "empty" spec to Nothing here- sregion = case show region of- "empty" -> Nothing- xs -> Just xs- lin = case modLin of- NonLinear -> Nothing- Linear -> Just "readOnce"---- Pretty print temporal specs-instance Show Temporal where- show (Dependency vars mutual) =- "dependency (" ++ showL vars ++ ")" ++ if mutual then ", mutual" else ""+ show (Spatial region) =+ -- Map "empty" spec to Nothing here+ case show region of+ "empty" -> ""+ xs -> xs -- Pretty print region sums instance Show RegionSum where@@ -497,12 +448,12 @@ show (Sum specs) = intercalate " + " ppspecs- where ppspecs = filter ((/=) "") $ map show specs+ where ppspecs = filter (/= "") $ map show specs instance Show RegionProd where show (Product []) = "" show (Product ss) =- intercalate "*" . (map (\s -> "(" ++ show s ++ ")")) $ ss+ intercalate "*" . map (\s -> "(" ++ show s ++ ")") $ ss instance Show Region where show (Forward dep dim reflx) = showRegion "forward" dep dim reflx
src/Camfort/Specification/Stencils/Synthesis.hs view
@@ -62,7 +62,7 @@ where realName v = v `fromMaybe` (v `M.lookup` nm) prefix' = case prefix of- Nothing -> show (spanLineCol span) ++ " \t"+ Nothing -> show span ++ " \t" Just pr -> pr formatSpec prefix nm (span, Left []) = ""@@ -70,39 +70,18 @@ (intercalate "\n" $ map (\s -> prefix' ++ doSpec s) specs) where prefix' = case prefix of- Nothing -> show (spanLineCol span) ++ " \t"+ Nothing -> show span ++ " \t" Just pr -> pr commaSep = intercalate ", " doSpec (arrayVar, spec) = show (fixSpec spec) ++ " :: " ++ commaSep (map realName arrayVar) realName v = v `fromMaybe` (v `M.lookup` nm)- fixSpec (Specification (Right (Dependency vs b))) =- Specification (Right (Dependency (map realName vs) b)) fixSpec s = s -lineCol :: FU.Position -> (Int, Int)-lineCol p = (fromIntegral $ FU.posLine p, fromIntegral $ FU.posColumn p)--spanLineCol :: FU.SrcSpan -> ((Int, Int), (Int, Int))-spanLineCol (FU.SrcSpan l u) = (lineCol l, lineCol u)- ------------------------ a = (head $ FA.initAnalysis [unitAnnotation]) { FA.insLabel = Just 0 } s = SrcSpan (Position 0 0 0) (Position 0 0 0) --- Given a spec, an array variable, and a list of inductive variables, generate--- a list of indexing expressions for the spec-synthesise :: Specification -> F.Name -> [F.Name] -> [F.Expression (FA.Analysis A)]-synthesise (Specification (Left (Exact spec))) v ixs =- map toSubscriptExpr . toList . fromExact . model $ (Exact spec)- where toSubscriptExpr (offs,_) = ixExprToSubscript v- . map (uncurry offsetToIx) $ zip ixs offs-synthesise _ _ _ = []--ixExprToSubscript :: F.Name -> [F.Index (FA.Analysis A)] -> F.Expression (FA.Analysis A)-ixExprToSubscript v es =- F.ExpSubscript a s (F.ExpValue a s (F.ValVariable v)) (F.AList a s es)- -- Make indexing expression for variable 'v' from an offset. -- essentially inverse to `ixToOffset` in StencilSpecification offsetToIx :: F.Name -> Int -> F.Index (FA.Analysis A)@@ -116,7 +95,3 @@ | otherwise = F.IxSingle a s Nothing (F.ExpBinary a s F.Subtraction (F.ExpValue a s (F.ValVariable v)) (F.ExpValue a s (F.ValInteger $ show (abs o))))--offsetToIxWithIVs :: [Variable] -> F.Name -> Int -> F.Index (FA.Analysis A)-offsetToIxWithIVs ivs v o = F.setAnnotation a ix- where ix = offsetToIx v o
src/Camfort/Specification/Units.hs view
@@ -27,18 +27,17 @@ (checkUnits, inferUnits, synthesiseUnits, inferCriticalVariables) where -import qualified Data.Map as M+import qualified Data.Map.Strict as M import Data.Char (isNumber) import Data.List (intercalate)-import Data.Maybe (fromMaybe, maybeToList, listToMaybe)+import Data.Maybe (fromMaybe, maybeToList, listToMaybe, mapMaybe) import Data.Generics.Uniplate.Operations import Control.Monad.State.Strict import Camfort.Helpers hiding (lineCol)+import Camfort.Helpers.Syntax import Camfort.Output import Camfort.Analysis.Annotations-import Camfort.Analysis.Syntax-import Camfort.Analysis.Types import Camfort.Input -- Provides the types and data accessors used in this module@@ -61,33 +60,35 @@ -- -- ************************************* -inferCriticalVariables, checkUnits, inferUnits, synthesiseUnits- :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> (Report, (Filename, F.ProgramFile Annotation))+inferCriticalVariables+ :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> (Report, Int) {-| Infer one possible set of critical variables for a program -} inferCriticalVariables uo (fname, pf)- | Right vars <- eVars = (okReport vars, (fname, pf))- | Left exc <- eVars = (errReport exc, (fname, pf))+ | Right vars <- eVars = okReport vars+ | Left exc <- eVars = (errReport exc, -1) where -- Format report- okReport [] = logs ++ "\n\n" ++ "No additional annotations are necessary.\n"- okReport vars = logs ++ "\n\n" ++ unlines [ fname ++ ": " ++ expReport ei | ei <- expInfo ]+ okReport [] = (logs ++ "\n" ++ fname ++ ":\n"+ ++ "No additional annotations are necessary.\n", 0)+ okReport vars = (logs ++ "\n" ++ fname ++ ": "+ ++ show numVars+ ++ " variable declarations suggested to be given a specification:\n"+ ++ unlines [ "\t" ++ expReport ei | ei <- expInfo ], numVars) where names = map showVar vars- expInfo = [ e | s@(F.StDeclaration {}) <- universeBi pfUA :: [F.Statement UA]- , e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi s :: [F.Expression UA]- , FA.varName e `elem` names ]+ expInfo = filter ((`elem` names) . FA.varName) $ declVariables pfUA+ numVars = length expInfo - expReport e = showSrcSpan (FU.getSpan e) ++ " " ++ unrename nameMap v- where v = FA.varName e+ expReport e = "(" ++ showSrcSpan (FU.getSpan e) ++ ")\t" ++ FA.srcName e varReport = intercalate ", " . map showVar - showVar (UnitVar v) = v- showVar (UnitLiteral _) = "<literal>"- showVar _ = "<bad>"+ showVar (UnitVar (_, s)) = s+ showVar (UnitLiteral _) = "<literal>"+ showVar _ = "<bad>" - errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs+ errReport exc = logs ++ "\n" ++ fname ++ ":\n" ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap }@@ -97,16 +98,49 @@ pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf nameMap = FAR.extractNameMap pfRenamed +checkUnits, inferUnits+ :: UnitOpts -> (Filename, F.ProgramFile Annotation) -> Report {-| Check units-of-measure for a program -} checkUnits uo (fname, pf)- | Right mCons <- eCons = (okReport mCons, (fname, pf))- | Left exc <- eCons = (errReport exc, (fname, pf))+ | Right mCons <- eCons = okReport mCons+ | Left exc <- eCons = errReport exc where -- Format report- okReport Nothing = fname ++ ": Consistent. " ++ show nVars ++ " variables checked.\n" ++ logs- okReport (Just cons) = logs ++ "\n\n" ++ fname ++ ": Inconsistent:\n" ++- unlines [ fname ++ ": " ++ srcSpan con ++ " constraint " ++ show (unrename nameMap con) | con <- cons ]+ okReport Nothing = logs ++ "\n" ++ fname ++ "\t: Consistent. " ++ show nVars ++ " variables checked."+ okReport (Just cons) = logs ++ "\n" ++ fname ++ "\t: Inconsistent:\n" ++ reportErrors cons++ reportErrors cons = unlines [ reportError con | con <- cons ]+ reportError con = " - at " ++ srcSpan con+ ++ pprintConstr (orient (unrename nameMap con))+ ++ additionalInfo con where+ -- Create additional info for errors+ additionalInfo con =+ if null (errorInfo con)+ then ""+ else "\n instead" ++ intercalate "\n" (mapNotFirst (pad 10) (errorInfo con))+ -- Create additional info about inconsistencies involving variables+ errorInfo con =+ [" '" ++ sName ++ "' is '" ++ pprintUnitInfo (unrename nameMap u) ++ "'"+ | UnitVar (vName, sName) <- universeBi con+ , u <- findUnitConstrFor con vName ]+ -- Find unit information for variable constraints+ findUnitConstrFor con v = mapMaybe (\con' -> if con == con'+ then Nothing+ else constrainedTo v con')+ (concat $ M.elems templateMap)+ constrainedTo v (ConEq (UnitVar (v', _)) u) | v == v' = Just u+ constrainedTo v (ConEq u (UnitVar (v', _))) | v == v' = Just u+ constrainedTo _ _ = Nothing++ mapNotFirst f [] = []+ mapNotFirst f (x : xs) = x : (map f xs)++ orient (ConEq u (UnitVar v)) = ConEq (UnitVar v) u+ orient c = c++ pad o = (++) (replicate o ' ')+ srcSpan con | Just ss <- findCon con = showSrcSpan ss ++ " " | otherwise = "" @@ -121,15 +155,16 @@ varReport = intercalate ", " . map showVar - showVar (UnitVar v) = v `fromMaybe` M.lookup v nameMap- showVar (UnitLiteral _) = "<literal>" -- FIXME- showVar _ = "<bad>"+ showVar (UnitVar (_, s)) = s+ showVar (UnitLiteral _) = "<literal>" -- FIXME+ showVar _ = "<bad>" - errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs+ errReport exc = logs ++ "\n" ++ fname ++ ":\t " ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap } (eCons, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInconsistentConstraints+ templateMap = usTemplateMap state pfUA :: F.ProgramFile UA pfUA = usProgramFile state -- the program file after units analysis is done @@ -146,20 +181,18 @@ This produces an output of all the unit information for a program -} inferUnits uo (fname, pf) | Right [] <- eVars = checkUnits uo (fname, pf)- | Right vars <- eVars = (okReport vars, (fname, pf))- | Left exc <- eVars = (errReport exc, (fname, pf))+ | Right vars <- eVars = okReport vars+ | Left exc <- eVars = errReport exc where -- Format report- okReport vars = logs ++ "\n\n" ++ unlines [ fname ++ ": " ++ expReport ei | ei <- expInfo ]+ okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] where- expInfo = [ (e, u) | s@(F.StDeclaration {}) <- universeBi pfUA :: [F.Statement UA]- , e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi s :: [F.Expression UA]- , u <- maybeToList (FA.varName e `lookup` vars) ]+ expInfo = [ (e, u) | e <- declVariables pfUA+ , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ] - expReport (e, u) = showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ unrename nameMap v- where v = FA.varName e+ expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e - errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs+ errReport exc = logs ++ "\n" ++ fname ++ ":\t" ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap }@@ -170,27 +203,29 @@ pfRenamed = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation $ pf nameMap = FAR.extractNameMap pfRenamed +synthesiseUnits :: UnitOpts+ -> Char+ -> (Filename, F.ProgramFile Annotation)+ -> (Report, (Filename, F.ProgramFile Annotation)) {-| Synthesis unspecified units for a program (after checking) -}-synthesiseUnits uo (fname, pf)- | Right [] <- eVars = checkUnits uo (fname, pf)+synthesiseUnits uo marker (fname, pf)+ | Right [] <- eVars = (checkUnits uo (fname, pf), (fname, pf)) | Right vars <- eVars = (okReport vars, (fname, pfFinal)) | Left exc <- eVars = (errReport exc, (fname, pfFinal)) where -- Format report- okReport vars = logs ++ "\n\n" ++ unlines [ fname ++ ": " ++ expReport ei | ei <- expInfo ]+ okReport vars = logs ++ "\n" ++ fname ++ ":\n" ++ unlines [ expReport ei | ei <- expInfo ] where- expInfo = [ (e, u) | s@(F.StDeclaration {}) <- universeBi pfUA :: [F.Statement UA]- , e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi s :: [F.Expression UA]- , u <- maybeToList (FA.varName e `lookup` vars) ]+ expInfo = [ (e, u) | e <- declVariables pfUA+ , u <- maybeToList ((FA.varName e, FA.srcName e) `lookup` vars) ] - expReport (e, u) = showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ (v `fromMaybe` M.lookup v nameMap)- where v = FA.varName e+ expReport (e, u) = " " ++ showSrcSpan (FU.getSpan e) ++ " unit " ++ show u ++ " :: " ++ FA.srcName e - errReport exc = fname ++ ": " ++ show exc ++ "\n" ++ logs+ errReport exc = logs ++ "\n" ++ fname ++ ":\t" ++ show exc -- run inference uOpts = uo { uoNameMap = nameMap }- (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables >>= runSynthesis+ (eVars, state, logs) = runUnitSolver uOpts pfRenamed $ initInference >> runInferVariables >>= runSynthesis marker pfUA = usProgramFile state -- the program file after units analysis is done pfFinal = fmap prevAnnotation . fmap FA.prevAnnotation $ pfUA -- strip annotations@@ -202,11 +237,11 @@ unrename nameMap = transformBi $ \ x -> x `fromMaybe` M.lookup x nameMap -showSrcLoc :: FU.Position -> String-showSrcLoc loc = show (lineCol loc) ++ ":" ++ show (lineCol loc)- showSrcSpan :: FU.SrcSpan -> String-showSrcSpan (FU.SrcSpan l u) = "(" ++ showSrcLoc l ++ " - " ++ showSrcLoc u ++ ")"+showSrcSpan (FU.SrcSpan l u) = show l -lineCol :: FU.Position -> (Int, Int)-lineCol p = (fromIntegral $ FU.posLine p, fromIntegral $ FU.posColumn p)+declVariables :: F.ProgramFile UA -> [F.Expression UA]+declVariables pf = flip mapMaybe (universeBi pf) $ \ d -> case d of+ F.DeclVariable _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ -> Just v+ F.DeclArray _ _ v@(F.ExpValue _ _ (F.ValVariable _)) _ _ _ -> Just v+ _ -> Nothing
src/Camfort/Specification/Units/Environment.hs view
@@ -20,9 +20,6 @@ module Camfort.Specification.Units.Environment where -import qualified Data.Label-import Data.Label.Mono (Lens)-import Data.Label.Monadic hiding (modify) import Control.Monad.State.Strict hiding (gets) import qualified Language.Fortran.AST as F@@ -39,6 +36,9 @@ import Text.Printf +-- | A (unique name, source name) variable+type VV = (F.Name, F.Name)+ -- | Description of the unit of an expression. data UnitInfo = UnitParamPosAbs (String, Int) -- an abstract parameter identified by PU name and argument position@@ -52,7 +52,7 @@ | UnitlessVar -- a unitless variable | UnitName String -- a basic unit | UnitAlias String -- the name of a unit alias- | UnitVar String -- variable with undetermined units (assumed to have unique name)+ | UnitVar VV -- variable with undetermined units: (unique name, source name) | UnitMul UnitInfo UnitInfo -- two units multiplied | UnitPow UnitInfo Double -- a unit raised to a constant power deriving (Eq, Ord, Data, Typeable)@@ -70,9 +70,9 @@ UnitlessVar -> "1" UnitName name -> name UnitAlias name -> name- UnitVar var -> printf "#<Var %s>" var+ UnitVar (vName, _) -> printf "#<Var %s>" vName UnitMul u1 (UnitPow u2 k)- | k < 0 -> maybeParen u1 ++ " / " ++ show (UnitPow u2 (-k))+ | k < 0 -> maybeParen u1 ++ " / " ++ maybeParen (UnitPow u2 (-k)) UnitMul u1 u2 -> maybeParenS u1 ++ " " ++ maybeParenS u2 UnitPow u 1 -> show u UnitPow u 0 -> "1"@@ -98,6 +98,16 @@ instance Show Constraint where show (ConEq u1 u2) = show u1 ++ " === " ++ show u2 show (ConConj cs) = intercalate " && " (map show cs)++pprintConstr :: Constraint -> String+pprintConstr (ConEq u1@(UnitVar _) u2@(UnitVar _))+ = "'" ++ pprintUnitInfo u1 ++ "' should have the same units as '" ++ pprintUnitInfo u2 ++ "'"+pprintConstr (ConEq u1 u2) = "'" ++ pprintUnitInfo u1 ++ "' should be '" ++ pprintUnitInfo u2 ++ "'"+pprintConstr (ConConj cs) = intercalate "\n\t and " (map pprintConstr cs)++pprintUnitInfo :: UnitInfo -> String+pprintUnitInfo (UnitVar (_, sName)) = printf "%s" sName+pprintUnitInfo ui = show ui --------------------------------------------------
src/Camfort/Specification/Units/InferenceBackend.hs view
@@ -35,7 +35,7 @@ import Control.Monad.State.Strict import Control.Monad.ST import Control.Arrow (first, second)-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Data.Array as A import Camfort.Analysis.Annotations@@ -82,7 +82,7 @@ -------------------------------------------------- -- | Returns list of formerly-undetermined variables and their units.-inferVariables :: Constraints -> [(String, UnitInfo)]+inferVariables :: Constraints -> [(VV, UnitInfo)] inferVariables [] = [] inferVariables cons | null inconsists = [ (var, if null units then UnitlessVar else foldl1 UnitMul units)
src/Camfort/Specification/Units/InferenceFrontend.hs view
@@ -27,8 +27,8 @@ import Data.Data (Data) import Data.List (nub)-import qualified Data.Map as M-import qualified Data.IntMap as IM+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IM import qualified Data.Set as S import Data.Maybe (isJust, fromMaybe, catMaybes) import Data.Generics.Uniplate.Operations@@ -39,7 +39,9 @@ import Control.Monad.RWS.Strict import qualified Language.Fortran.AST as F+import Language.Fortran.Parser.Utils (readReal, readInteger) import qualified Language.Fortran.Analysis as FA+import Language.Fortran.Analysis (varName, srcName) import Camfort.Analysis.CommentAnnotator (annotateComments) import Camfort.Analysis.Annotations@@ -129,7 +131,7 @@ -- | Return a list of variable names mapped to their corresponding -- unit that was inferred.-runInferVariables :: UnitSolver [(String, UnitInfo)]+runInferVariables :: UnitSolver [(VV, UnitInfo)] runInferVariables = do cons <- usConstraints `fmap` get return $ inferVariables cons@@ -156,14 +158,16 @@ fname = puName pu -- | Return the list of parameters paired with its positional index.-indexedParams :: F.ProgramUnit UA -> [(Int, String)]+indexedParams :: F.ProgramUnit UA -> [(Int, VV)] indexedParams pu- | F.PUFunction _ _ _ _ _ (Just paList) (Just r) _ _ <- pu = zip [0..] $ varName r : map varName (F.aStrip paList)- | F.PUFunction _ _ _ _ _ (Just paList) _ _ _ <- pu = zip [0..] $ fname : map varName (F.aStrip paList)- | F.PUSubroutine _ _ _ _ (Just paList) _ _ <- pu = zip [1..] $ map varName (F.aStrip paList)+ | F.PUFunction _ _ _ _ _ (Just paList) (Just r) _ _ <- pu = zip [0..] $ map toVV (r : F.aStrip paList)+ | F.PUFunction _ _ _ _ _ (Just paList) _ _ _ <- pu = zip [0..] $ (fname, sfname) : map toVV (F.aStrip paList)+ | F.PUSubroutine _ _ _ _ (Just paList) _ _ <- pu = zip [1..] $ map toVV (F.aStrip paList) | otherwise = [] where- fname = puName pu+ fname = puName pu+ sfname = puSrcName pu+ toVV e = (varName e, srcName e) -------------------------------------------------- @@ -183,14 +187,16 @@ toParamVar :: String -> F.Expression UA -> UnitSolver (F.Expression UA) toParamVar fname v@(F.ExpValue _ _ (F.ValVariable _)) = do let vname = varName v- modifyVarUnitMap $ M.insertWith (curry snd) vname (UnitParamVarAbs (fname, vname))+ let sname = srcName v+ modifyVarUnitMap $ M.insertWith (curry snd) (vname, sname) (UnitParamVarAbs (fname, vname)) return v toParamVar _ e = return e toUnitVar :: F.Expression UA -> UnitSolver (F.Expression UA) toUnitVar v@(F.ExpValue _ _ (F.ValVariable _)) = do let vname = varName v- modifyVarUnitMap $ M.insertWith (curry snd) vname (UnitVar vname)+ let sname = srcName v+ modifyVarUnitMap $ M.insertWith (curry snd) (vname, sname) (UnitVar (vname, sname)) return v toUnitVar e = return e @@ -218,17 +224,17 @@ -- Figure out the unique names of the referenced variables and -- then insert unit info under each of those names.+ insertUnitAssignments :: UnitInfo -> F.Block UA -> [String] -> UnitSolver () insertUnitAssignments info (F.BlStatement _ _ _ (F.StDeclaration _ _ _ _ decls)) varRealNames = do -- figure out the 'unique name' of the varRealName that was found in the comment -- FIXME: account for module renaming -- FIXME: might be more efficient to allow access to variable renaming environ at this program point- nameMap <- uoNameMap `fmap` ask- let m = M.fromList [ (varUniqueName, info) | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi decls- , varRealName <- varRealNames- , let varUniqueName = varName e- , maybe False (== varRealName) (varUniqueName `M.lookup` nameMap) ]+ let m = M.fromList [ ((varName e, srcName e), info)+ | e@(F.ExpValue _ _ (F.ValVariable _)) <- universeBi decls :: [F.Expression UA]+ , varRealName <- varRealNames+ , varRealName == FA.srcName e ] modifyVarUnitMap $ M.unionWith const m- modifyGivenVarSet . S.union . S.fromList . M.keys $ m+ modifyGivenVarSet . S.union . S.fromList . map fst . M.keys $ m -------------------------------------------------- @@ -238,7 +244,7 @@ annotateAllVariables = modifyProgramFileM $ \ pf -> do varUnitMap <- usVarUnitMap `fmap` get let annotateExp e@(F.ExpValue _ _ (F.ValVariable _))- | Just info <- M.lookup (varName e) varUnitMap = setUnitInfo info e+ | Just info <- M.lookup (varName e, srcName e) varUnitMap = setUnitInfo info e annotateExp e = e return $ transformBi annotateExp pf @@ -263,11 +269,11 @@ where -- Follow the LitMixed rules. expMixed e = case e of- F.ExpValue _ _ (F.ValInteger i) | read i == (0 :: Int) -> withLiterals genParamLit e- | otherwise -> withLiterals genUnitLiteral e- F.ExpValue _ _ (F.ValReal i) | read i == (0 :: Double) -> withLiterals genParamLit e- | otherwise -> withLiterals genUnitLiteral e- _ -> return e+ F.ExpValue _ _ (F.ValInteger i) | readInteger i == Just 0 -> withLiterals genParamLit e+ | otherwise -> withLiterals genUnitLiteral e+ F.ExpValue _ _ (F.ValReal i) | readReal i == Just 0 -> withLiterals genParamLit e+ | otherwise -> withLiterals genUnitLiteral e+ _ -> return e -- Set all literals to unitless. expUnitless e@@ -306,12 +312,7 @@ -- polymorphic calls that are uncovered, unless they are recursive -- calls that have already been seen in the current call stack. substInstance :: [F.Name] -> Constraints -> (F.Name, Int) -> UnitSolver Constraints-substInstance callStack output (name, callId)- -- Detected recursion: we do not support polymorphic-unit recursion,- -- ergo all subsequent recursive calls are assumed to have the same- -- unit-assignments as the first call.- | name `elem` callStack = return output- | otherwise = do+substInstance callStack output (name, callId) = do tmap <- gets usTemplateMap -- Look up the templates associated with the given function or@@ -327,9 +328,15 @@ -- set of templates. modify $ \ s -> s { usCallIdRemap = IM.empty } - -- If any new instances are discovered, also process them.+ -- If any new instances are discovered, also process them, unless recursive. let instances = nub [ (name, i) | UnitParamPosUse (name, _, i) <- universeBi template ]- template' <- foldM (substInstance (name:callStack)) [] instances+ template' <- if name `elem` callStack then+ -- Detected recursion: we do not support polymorphic-unit recursion,+ -- ergo all subsequent recursive calls are assumed to have the same+ -- unit-assignments as the first call.+ return []+ else+ foldM (substInstance (name:callStack)) [] instances -- Convert any remaining abstract parametric units into concrete ones. return . instantiate (name, callId) $ output ++ template ++ template'@@ -405,6 +412,7 @@ F.ExpBinary _ _ o e1 e2 | isOp AddOp o -> setF2C ConEq (getUnitInfo e1) (getUnitInfo e2) | isOp RelOp o -> setF2C ConEq (getUnitInfo e1) (getUnitInfo e2) F.ExpFunctionCall {} -> propagateFunctionCall e+ F.ExpSubscript _ _ e1 _ -> return $ maybeSetUnitInfo (getUnitInfo e1) e _ -> whenDebug (tell ("propagateExp: unhandled: " ++ show e)) >> return e where -- Shorter names for convenience functions.@@ -573,12 +581,50 @@ -------------------------------------------------- +-- Fortran semantics for interpretation of constant expressions+-- involving numeric literals.+data FNum = FReal Double | FInt Integer+fnumToDouble (FReal x) = x+fnumToDouble (FInt x) = fromIntegral x++fAdd, fSub, fMul, fDiv :: FNum -> FNum -> FNum+fAdd (FReal x) fy = FReal $ x + fnumToDouble fy+fAdd fx (FReal y) = FReal $ fnumToDouble fx + y+fAdd (FInt x) (FInt y) = FInt $ x + y+fSub (FReal x) fy = FReal $ x - fnumToDouble fy+fSub fx (FReal y) = FReal $ fnumToDouble fx - y+fSub (FInt x) (FInt y) = FInt $ x - y+fMul (FReal x) fy = FReal $ x * fnumToDouble fy+fMul fx (FReal y) = FReal $ fnumToDouble fx * y+fMul (FInt x) (FInt y) = FInt $ x * y+fDiv (FReal x) fy = FReal $ x / fnumToDouble fy+fDiv fx (FReal y) = FReal $ fnumToDouble fx / y+fDiv (FInt x) (FInt y) = FInt $ x `quot` y -- Haskell quot truncates towards zero, like Fortran+fPow (FReal x) fy = FReal $ x ** fnumToDouble fy+fPow fx (FReal y) = FReal $ fnumToDouble fx ** y+fPow (FInt x) (FInt y)+ | y >= 0 = FInt $ x ^ y+ | otherwise = FReal $ fromIntegral x ^^ y++fDivMaybe mx my+ | Just y <- my,+ fnumToDouble y == 0.0 = Nothing+ | otherwise = liftM2 fDiv mx my+ -- | Statically computes if the expression is a constant value. constantExpression :: F.Expression a -> Maybe Double-constantExpression (F.ExpValue _ _ (F.ValInteger i)) = Just $ read i-constantExpression (F.ExpValue _ _ (F.ValReal r)) = Just $ read r--- FIXME: expand...-constantExpression _ = Nothing+constantExpression e = fnumToDouble `fmap` ce e+ where+ ce e = case e of+ (F.ExpValue _ _ (F.ValInteger i)) -> FInt `fmap` readInteger i+ (F.ExpValue _ _ (F.ValReal r)) -> FReal `fmap` readReal r+ (F.ExpBinary _ _ F.Addition e1 e2) -> liftM2 fAdd (ce e1) (ce e2)+ (F.ExpBinary _ _ F.Subtraction e1 e2) -> liftM2 fSub (ce e1) (ce e2)+ (F.ExpBinary _ _ F.Multiplication e1 e2) -> liftM2 fMul (ce e1) (ce e2)+ (F.ExpBinary _ _ F.Division e1 e2) -> fDivMaybe (ce e1) (ce e2)+ (F.ExpBinary _ _ F.Exponentiation e1 e2) -> liftM2 fPow (ce e1) (ce e2)+ -- FIXME: expand...+ _ -> Nothing -- | Asks the question: is the operator within the given category? isOp :: BinOpKind -> F.BinaryOp -> Bool@@ -612,7 +658,7 @@ pf <- gets usProgramFile cons <- usConstraints `fmap` get vum <- usVarUnitMap `fmap` get- tell . unlines $ [ " " ++ show info ++ " :: " ++ n | (n, info) <- M.toList vum ]+ tell . unlines $ [ " " ++ show info ++ " :: " ++ n | ((n, _), info) <- M.toList vum ] tell "\n\n" uam <- usUnitAliasMap `fmap` get tell . unlines $ [ " " ++ n ++ " = " ++ show info | (n, info) <- M.toList uam ]@@ -648,7 +694,9 @@ puName :: F.ProgramUnit UA -> F.Name puName pu | F.Named n <- FA.puName pu = n- | otherwise = "_nameless"+ | otherwise = "_nameless" -varName :: F.Expression UA -> F.Name-varName = FA.varName+puSrcName :: F.ProgramUnit UA -> F.Name+puSrcName pu+ | F.Named n <- FA.puSrcName pu = n+ | otherwise = "_nameless"
src/Camfort/Specification/Units/Monad.hs view
@@ -19,7 +19,7 @@ {- | Defines the monad for the units-of-measure modules -} module Camfort.Specification.Units.Monad- ( UA, UnitSolver, UnitOpts(..), unitOpts0, UnitLogs, UnitState(..), LiteralsOpt(..), UnitException+ ( UA, VV, UnitSolver, UnitOpts(..), unitOpts0, UnitLogs, UnitState(..), LiteralsOpt(..), UnitException , whenDebug, modifyVarUnitMap, modifyGivenVarSet, modifyUnitAliasMap , VarUnitMap, GivenVarSet, UnitAliasMap, TemplateMap, CallIdMap , modifyTemplateMap, modifyProgramFile, modifyProgramFileM, modifyCallIdRemapM@@ -31,13 +31,13 @@ import Data.Char (toLower) import Data.Data (Data) import Data.List (find, isPrefixOf)-import qualified Data.Map as M-import qualified Data.IntMap as IM+import qualified Data.Map.Strict as M+import qualified Data.IntMap.Strict as IM import qualified Data.Set as S import qualified Language.Fortran.Analysis as FA import qualified Language.Fortran.Analysis.Renaming as FAR import qualified Language.Fortran.AST as F-import Camfort.Specification.Units.Environment (UnitInfo, UnitAnnotation, Constraints(..))+import Camfort.Specification.Units.Environment (UnitInfo, UnitAnnotation, Constraints(..), VV) import Camfort.Analysis.Annotations (Annotation, A, UA) --------------------------------------------------@@ -92,8 +92,8 @@ -------------------------------------------------- --- | Variable unique name => unit-type VarUnitMap = M.Map F.Name UnitInfo+-- | Variable => unit+type VarUnitMap = M.Map VV UnitInfo -- | Set of variables given explicit unit annotations type GivenVarSet = S.Set F.Name -- | Alias name => definition
src/Camfort/Specification/Units/Parser.y view
@@ -127,8 +127,9 @@ deriving (Show) lexer :: String -> Either AnnotationParseError [ Token ]-lexer ('=':xs) = lexer' xs-lexer _ = Left NotAnnotation+lexer (c:xs)+ | c `elem` ['=', '!', '>', '<'] = lexer' xs+ | otherwise = Left NotAnnotation addToTokens :: Token -> String -> Either AnnotationParseError [ Token ] addToTokens tok rest = do
src/Camfort/Specification/Units/Synthesis.hs view
@@ -25,10 +25,9 @@ import Data.Matrix import Data.Maybe import Data.Ratio (numerator, denominator)-import qualified Data.Map as M+import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.Generics.Uniplate.Operations-import Data.Label.Monadic hiding (modify) import Control.Monad.State.Strict hiding (gets) import Control.Monad.Reader import Control.Monad.Writer.Strict@@ -41,54 +40,51 @@ import qualified Camfort.Specification.Units.Parser as P import Camfort.Analysis.CommentAnnotator-import qualified Camfort.Output as O (srcSpanToSrcLocs) import Camfort.Analysis.Annotations hiding (Unitless) import Camfort.Specification.Units.Environment import Camfort.Specification.Units.Monad import qualified Debug.Trace as D -- | Insert unit declarations into the ProgramFile as comments.-runSynthesis :: [(String, UnitInfo)] -> UnitSolver [(String, UnitInfo)]-runSynthesis vars = do- modifyProgramFileM $ descendBiM (synthBlocks vars) -- descendBiM finds the head of lists+runSynthesis :: Char -> [(VV, UnitInfo)] -> UnitSolver [(VV, UnitInfo)]+runSynthesis marker vars = do+ modifyProgramFileM $ descendBiM (synthBlocks marker vars) -- descendBiM finds the head of lists return vars -- Should be invoked on the beginning of a list of blocks-synthBlocks :: [(String, UnitInfo)] -> [F.Block UA] -> UnitSolver [F.Block UA]-synthBlocks vars = fmap reverse . foldM (synthBlock vars) []+synthBlocks :: Char -> [(VV, UnitInfo)] -> [F.Block UA] -> UnitSolver [F.Block UA]+synthBlocks marker vars = fmap reverse . foldM (synthBlock marker vars) [] -- Process an individual block while building up a list of blocks (in -- reverse order) to ultimately replace the original list of -- blocks. We're looking for blocks containing declarations, in -- particular, in order to possibly insert a unit annotation before -- them.-synthBlock :: [(String, UnitInfo)] -> [F.Block UA] -> F.Block UA -> UnitSolver [F.Block UA]-synthBlock vars bs b@(F.BlStatement a ss@(FU.SrcSpan lp up) _ (F.StDeclaration _ _ _ _ decls)) = do+synthBlock :: Char -> [(VV, UnitInfo)] -> [F.Block UA] -> F.Block UA -> UnitSolver [F.Block UA]+synthBlock marker vars bs b@(F.BlStatement a ss@(FU.SrcSpan lp up) _ (F.StDeclaration _ _ _ _ decls)) = do pf <- usProgramFile `fmap` get- nMap <- uoNameMap `fmap` ask gvSet <- usGivenVarSet `fmap` get newBs <- fmap catMaybes . forM (universeBi decls) $ \ e -> case e of e@(F.ExpValue _ _ (F.ValVariable _))- | name `S.notMember` gvSet -- not a member of the already-given variables- , Just u <- lookup name vars -> do -- and a unit has been inferred- -- Pick the start source loc from the existing decl.- let loc = fst $ O.srcSpanToSrcLocs ss+ | vname `S.notMember` gvSet -- not a member of the already-given variables+ , Just u <- lookup (vname, sname) vars -> do -- and a unit has been inferred -- Create new annotation which labels this as a refactored node. let newA = a { FA.prevAnnotation = (FA.prevAnnotation a) { prevAnnotation = (prevAnnotation (FA.prevAnnotation a)) {- refactored = Just loc } } }+ refactored = Just lp } } } -- Create a zero-length span for the new comment node. let newSS = FU.SrcSpan (lp {FU.posColumn = 0}) (lp {FU.posColumn = 0}) -- Build the text of the comment with the unit annotation.- let txt = "= " ++ showUnitDecl nMap (e, u)+ let txt = marker:" " ++ showUnitDecl (e, u) let space = FU.posColumn lp - 1 let newB = F.BlComment newA newSS . insertSpacing space $ commentText pf txt return $ Just newB where- name = FA.varName e+ vname = FA.varName e+ sname = FA.srcName e (e :: F.Expression UA) -> return Nothing return (b:reverse newBs ++ bs)-synthBlock _ bs b = return (b:bs)+synthBlock _ _ bs b = return (b:bs) -- Insert the correct comment markers around the given text string, depending on Fortran version. -- FIXME: use Fortran meta information when I have finished adding it to ProgramFile.@@ -100,5 +96,4 @@ insertSpacing n = (replicate n ' ' ++) -- Pretty print a unit declaration.-showUnitDecl nameMap (e, u) = "unit(" ++ show u ++ ") :: " ++ (v `fromMaybe` M.lookup v nameMap)- where v = FA.varName e+showUnitDecl (e, u) = "unit(" ++ show u ++ ") :: " ++ FA.srcName e
src/Camfort/Transformation/CommonBlockElim.hs view
@@ -13,7 +13,9 @@ See the License for the specific language governing permissions and limitations under the License. -}-{-# LANGUAGE ImplicitParams, DeriveDataTypeable, TypeOperators #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-} module Camfort.Transformation.CommonBlockElim where @@ -24,308 +26,417 @@ import Data.Data import Data.List import Data.Ord-import qualified Data.Map as Data.Map+import qualified Data.Map as M import Data.Generics.Uniplate.Operations -import Language.Fortran-import Language.Fortran.Pretty+import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Analysis as FA+import qualified Language.Fortran.Analysis.Types as FAT+import qualified Language.Fortran.Util.Position as FU+import qualified Language.Fortran.ParserMonad as PM+import qualified Language.Fortran.PrettyPrint as PP import Camfort.Helpers-import Camfort.Traverse+import Camfort.Helpers.Syntax import Camfort.Analysis.Annotations-import Camfort.Analysis.Syntax-import Camfort.Analysis.Types-import Camfort.Transformation.Syntax --- Typed common block representation-type TCommon p = (Maybe String, [(Variable, Type p)])+-- Typed common-block representation+-- Tuple of:+-- * a (possible) common block name+-- * map from names to their types+type TCommon p = (Maybe F.Name, [(F.Name, F.BaseType)]) -- Typed and "located" common block representation+-- Right associated pairs tuple of:+-- * current filename+-- * current program unit name+-- * Typed common-block representation -- TODO: include column + line information-type TLCommon p = (Filename, (String, TCommon p))+type TLCommon p = (Filename, (F.Name, TCommon p)) +type A1 = FA.Analysis Annotation+type CommonState = State (Report, [TLCommon A])+ -- Top-level functions for eliminating common blocks in a set of files-commonElimToModules :: Directory -> [(Filename, Program A)] -> (Report, [(Filename, Program A)])+commonElimToModules ::+ Directory+ -> [(Filename, F.ProgramFile A)]+ -> (Report, [(Filename, F.ProgramFile A)], [(Filename, F.ProgramFile A)]) -- Eliminates common blocks in a program directory (and convert to modules)-commonElimToModules d ps = let (ps', (r, cg)) = runState (analyseCommons ps) ("", [])- (r', ps'') = introduceModules d cg- psR = updateUseDecls ps' cg- in (r ++ r', psR ++ ps'')+commonElimToModules d pfs =+ (r ++ r', pfs'', pfM)+ where+ (pfs', (r, cg)) = runState (analyseAndRmCommons pfs) ("", [])+ meta = F.MetaInfo PM.Fortran90+ (r', pfM) = introduceModules meta d cg+ pfs'' = updateUseDecls pfs' cg +analyseAndRmCommons :: [(Filename, F.ProgramFile A)]+ -> CommonState [(Filename, F.ProgramFile A)]+analyseAndRmCommons = mapM analysePerPF +analysePerPF ::+ (Filename, F.ProgramFile A) -> CommonState (Filename, F.ProgramFile A)+analysePerPF (fname, pf) = do+ let pf' = FA.initAnalysis pf+ let (pf'', tenv) = FAT.analyseTypes pf'+ pf''' <- transformBiM (analysePerPU tenv fname) pf''+ return (fname, fmap FA.prevAnnotation pf''') -analyseCommons :: [(Filename, Program A)] -> State (Report, [TLCommon A]) [(Filename, Program A)]-analyseCommons pss = let- defs' :: Filename -> ProgUnit A -> State (Report, [TLCommon A]) (ProgUnit A)- defs' fname p = case (getSubName p) of- Just pname -> transformBiM (collectCommons fname pname) p- Nothing -> case p of- IncludeProg a sp ds f ->- -- ("doing an include: " ++ (show fname)) `trace`- let -- create dummy block- a0 = unitAnnotation- b = Block a (UseBlock (UseNil a0) nullLoc)- (ImplicitNull a0) sp ds- (NullStmt a0 nullSpan)- in do (Block _ _ _ _ ds' _) <- transformBiM (collectCommons fname fname) b- return $ IncludeProg a sp ds' f- otherwise -> return p- -- defs' f (Sub _ _ _ (SubName _ n) _ b) rs = (concat rs) ++ [(f, (n, snd $ runState (collectTCommons' b) []))]- -- Don't support functions yet- -- defs' f (Function _ _ _ (SubName _ n) _ _ b) rs = (concat rs) ++ [(f, (n, snd $ runState (collectTCommons b) []))]- -- defs' _ _ rs = concat rs+analysePerPU ::+ FAT.TypeEnv -> Filename -> F.ProgramUnit A1 -> CommonState (F.ProgramUnit A1)+analysePerPU tenv fname p =+ transformBiM (collectAndRmCommons tenv fname (F.getName p)) p - in mapM (\(f, ps) -> do ps' <- mapM (transformBiM (defs' f)) ps- return (f, ps')) pss+collectAndRmCommons :: FAT.TypeEnv -> Filename -> F.ProgramUnitName+ -> F.Block A1 -> CommonState (F.Block A1)+collectAndRmCommons tenv fname pname = transformBiM commons+ where+ commons :: F.Statement A1 -> CommonState (F.Statement A1)+ commons f@(F.StCommon a s@(FU.SrcSpan p1 _) cgrps) = do+ mapM_ commonGroups (F.aStrip cgrps)+ let a' = onPrev (\ap -> ap {refactored = Just p1, deleteNode = True}) a+ return $ F.StCommon a' (deleteLine s) (F.AList a s [])+ commons f = return f -collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A)-collectCommons fname pname b =- let tenv = typeEnv b+ punitName (F.Named s) = s+ punitName _ = "" - commons' :: Decl A -> State (Report, [TLCommon A]) (Decl A)- commons' f@(Common a sp cname exprs) =- do let r' = (show $ srcLineCol $ fst sp) ++ ": removed common declaration\n"- (r, env) <- get- put (r ++ r', (fname, (pname, (cname, typeCommonExprs exprs))):env)- return $ (NullDecl (a { refactored = (Just $ fst sp) }) sp)- commons' f = return f+ -- Process a common group, adding blocks to the common state+ commonGroups :: F.CommonGroup A1 -> CommonState ()+ commonGroups (F.CommonGroup a (FU.SrcSpan p1 _) cname exprs) = do+ let r' = show p1 ++ ": removed common declaration\n"+ let tcommon = map typeCommonExprs (F.aStrip exprs)+ let info = (fname, (punitName pname, (commonNameFromAST cname, tcommon)))+ modify (\(r, infos) -> (r ++ r', info : infos)) - typeCommonExprs :: [Expr Annotation] -> [(Variable, Type Annotation)]- typeCommonExprs [] = []- typeCommonExprs ((Var _ sp [(VarName _ v, _)]):es) =- case (tenvLookup v tenv) of- Just t -> (v, t) : (typeCommonExprs es)- Nothing -> error $ "Variable " ++ (show v) ++ " is of an unknown type at: " ++ show sp- typeCommonExprs (e:_) = error $ "Not expecting a non-variable expression in expression at: " ++ show (srcSpan e)+ typeCommonExprs :: F.Expression A1 -> (F.Name, F.BaseType)+ typeCommonExprs (F.ExpValue _ sp (F.ValVariable v)) =+ case M.lookup v tenv of+ Just (FA.IDType (Just t) (Just FA.CTVariable)) -> (v, t)+ Just (FA.IDType (Just t) (Just FA.CTArray)) -> (v, t)+ _ -> error $ "Variable '" ++ show v+ ++ "' is of an unknown or higher-order type at: " ++ show sp+ ++ show (M.lookup v tenv) - in transformBiM commons' b+ typeCommonExprs e = error $ "Not expecting a non-variable expression \+ \in expression at: " ++ show (FU.getSpan e) + {- Comparison functions for common block names and variables -}-cmpTLConFName :: TLCommon A -> TLCommon A -> Ordering+cmpTLConFName :: TLCommon a -> TLCommon a -> Ordering cmpTLConFName (f1, (_, _)) (f2, (_, _)) = compare f1 f2 -cmpTLConPName :: TLCommon A -> TLCommon A -> Ordering+cmpTLConPName :: TLCommon a -> TLCommon a -> Ordering cmpTLConPName (_, (p1, _)) (_, (p2, _)) = compare p1 p2 -cmpTLConBNames :: TLCommon A -> TLCommon A -> Ordering+cmpTLConBNames :: TLCommon a -> TLCommon a -> Ordering cmpTLConBNames (_, (_, c1)) (_, (_, c2)) = cmpTConBNames c1 c2 -cmpTConBNames :: TCommon A -> TCommon A -> Ordering+cmpTConBNames :: TCommon a -> TCommon a -> Ordering cmpTConBNames (Nothing, _) (Nothing, _) = EQ cmpTConBNames (Nothing, _) (Just _, _) = LT cmpTConBNames (Just _, _) (Nothing, _) = GT-cmpTConBNames (Just n, _) (Just n', _) = if (n < n') then LT- else if (n > n') then GT else EQ+cmpTConBNames (Just n, _) (Just n', _)+ | n < n' = LT+ | n > n' = GT+ | otherwise = EQ --- Fold [TLCommon p] to get a list of ([(TLCommon p, Renamer p)], [(Filename, Program A)])--- How to decide which gets to be the "head" perhaps the one which triggers the *least* renaming (ooh!)--- (this is calculated by looking for the mode of the TLCommon (for a particular Common)--- (need to do gorouping, but sortBy is used already so... (IS THIS STABLE- does this matter?))+cmpVarName :: TLCommon a -> TLCommon a -> Ordering+cmpVarName (_, (_, (_, vtys1))) (_, (_, (_, vtys2))) =+ map fst vtys1 `compare` map fst vtys2 -onCommonBlock :: (TCommon A -> TCommon A) -> TLCommon A -> TLCommon A-onCommonBlock f (fname, (pname, tcommon)) = (fname, (pname, f tcommon))+-- Fold [TLCommon p] to get a list of ([(TLCommon p, Renamer p)],+-- [(Filename, F.ProgramFile A)]) How to decide which gets to be the+-- "head" perhaps the one which triggers the *least* renaming (ooh!)+-- (this is calculated by looking for the mode of the TLCommon (for a+-- particular Common) (need to do gorouping, but sortBy is used+-- already so... (IS THIS STABLE- does this matter?)) commonName Nothing = "Common" commonName (Just x) = x --- Freshen the names for a common block and generate a renamer from the old block to this+commonNameFromAST (Just (F.ExpValue _ _ (F.ValVariable v))) = Just v+commonNameFromAST _ = Nothing++-- Freshen the names for a common block and generate a renamer from+-- the old block to this freshenCommonNames :: TLCommon A -> (TLCommon A, RenamerCoercer) freshenCommonNames (fname, (pname, (cname, fields))) = let mkRenamerAndCommon (r, tc) (v, t) =- let v' = (caml $ commonName cname) ++ "_" ++ v- in (Data.Map.insert v (Just v', Nothing) r, (v', t) : tc)- (r, fields') = foldl mkRenamerAndCommon (Data.Map.empty, []) fields+ let v' = caml (commonName cname) ++ "_" ++ v+ in (M.insert v (Just v', Nothing) r, (v', t) : tc)+ (r, fields') = foldl mkRenamerAndCommon (M.empty, []) fields in ((fname, (pname, (cname, fields'))), Just r) --- From a list of typed and located common blocks--- group by the common block name, and then group/sort within such that the "mode" block is first+-- From a list of typed and located common blocks group by the common+-- block name, and then group/sort within such that the "mode" block+-- is first groupSortCommonBlock :: [TLCommon A] -> [[[TLCommon A]]]-groupSortCommonBlock commons = let -- Group by names of the common blocks- gcs = groupBy (\x y -> cmpEq $ cmpTLConBNames x y) commons- -- Group within by the different common block variable-type fields- gccs = map (sortBy (\y x -> length x `compare` length y) . group . sortBy cmpVarName) gcs- in gccs--cmpVarName :: TLCommon A -> TLCommon A -> Ordering-cmpVarName (fname1, (pname1, (name1, vtys1))) (fnam2, (pname2, (name2, vtys2))) = map fst vtys1 `compare` map fst vtys2+groupSortCommonBlock commons = gccs+ where+ -- Group by names of the common blocks+ gcs = groupBy (\x y -> cmpEq $ cmpTLConBNames x y) commons+ -- Group within by the different common block variable-type fields+ gccs = map (sortBy (\y x -> length x `compare` length y) . group . sortBy cmpVarName) gcs mkTLCommonRenamers :: [TLCommon A] -> [(TLCommon A, RenamerCoercer)]-mkTLCommonRenamers commons = case allCoherentCommonsP commons of- (r, False) -> error $ "Common blocks are incoherent!\n" ++ r -- (r, []) -- Incoherent commons- (_, True) -> let gccs = groupSortCommonBlock commons- -- Find the "mode" common block and freshen the names for this, creating- -- a renamer between this and every module- gcrcs = map (\grp -> -- grp are block decls all for the same block- let (com, r) = freshenCommonNames (head (head grp))- in map (\c -> (c, r)) (head grp) ++- map (\c -> (c, mkRenamerCoercerTLC c com)) (concat $ tail grp)) gccs- -- Now re-sort based on the file and program unit- gcrcs' = sortBy (cmpFst cmpTLConFName) (sortBy (cmpFst cmpTLConPName) (concat gcrcs))- in gcrcs'+mkTLCommonRenamers commons =+ case allCoherentCommons commons of+ (r, False) -> error $ "Common blocks are incoherent!\n" ++ r+ (_, True) -> commons'+ where+ gccs = groupSortCommonBlock commons+ -- Find the "mode" common block and freshen the names for+ -- this, creating a renamer between this and every module+ gcrcs = map (\grp -> -- grp are block decls all for the same block+ let (com, r) = freshenCommonNames (head (head grp))+ in map (\c -> (c, r)) (head grp) +++ map (\c -> (c, mkRenamerCoercerTLC c com)) (concat $ tail grp)) gccs+ -- Now re-sort based on the file and program unit+ commons' = sortBy (cmpFst cmpTLConFName) (sortBy (cmpFst cmpTLConPName) (concat gcrcs)) +type NameMap = M.Map F.Name F.Name -updateUseDecls :: [(Filename, Program A)] -> [TLCommon A] -> [(Filename, Program A)]-updateUseDecls fps tcs =- let tcrs = mkTLCommonRenamers tcs+-- Nothing represents an overall identity renamer/coercer for efficiency+-- a Nothing for a variable represent a variable-level (renamer) identity+-- a Nothing for a type represents a type-level (coercer) identity+type RenamerCoercer =+ Maybe (M.Map F.Name (Maybe F.Name, Maybe (F.BaseType, F.BaseType))) - concatUses :: Uses A -> Uses A -> Uses A- concatUses (UseNil p) y = y- concatUses (Uses p x us p') y = Uses p x (UseNil p) p'+applyRenaming :: (Typeable (t A), Data (t A)) => NameMap -> t A -> t A+applyRenaming r = transformBi rename+ where+ rename :: F.Value A -> F.Value A+ rename vn@(F.ValVariable v) =+ case M.lookup v r of+ Nothing -> vn+ Just v' -> F.ValVariable v' - inames :: Decl A -> Maybe String- inames (Include _ (Con _ _ inc)) = Just inc- inames _ = Nothing+class Renaming r where+ hasRenaming :: F.Name -> r -> Bool - importIncludeCommons :: ProgUnit A -> ProgUnit A- importIncludeCommons p = foldl (\p' iname -> ("Iname = " ++ iname) `trace` matchPUnitAlt iname p') p (reduceCollect inames p)+instance Renaming RenamerCoercer where+ hasRenaming _ Nothing = False+ hasRenaming v (Just rc) = M.member v rc - matchPUnitAlt :: Filename -> ProgUnit A -> ProgUnit A- matchPUnitAlt fname p = ("fname = " ++ fname ++ "\n" ++ (show ((lookups' fname) (lookups' fname tcrs)))) `trace`- let tcrs' = (lookups' fname) (lookups' fname tcrs)- srcloc = useSrcLoc p- uses = mkUseStatements srcloc tcrs'- p' = transformBi ((flip concatUses) uses) p- in let ?fname = fname in removeDecls (map snd tcrs') p'+-- sometimes we have a number of renamer coercers together+instance Renaming [RenamerCoercer] where+ hasRenaming v = any (hasRenaming v) +updateUseDecls ::+ [(Filename, F.ProgramFile A)] -> [TLCommon A] -> [(Filename, F.ProgramFile A)]+updateUseDecls fps tcs = map perPF fps+ where+ perPF (f, p@(F.ProgramFile (F.MetaInfo v) _ _)) =+ (f, transformBi (importIncludeCommons v) $ transformBi (matchPUnit v f) p)+ tcrs = mkTLCommonRenamers tcs - matchPUnit :: Filename -> ProgUnit A -> ProgUnit A- matchPUnit fname p = let pname = case getSubName p of- Nothing -> fname -- If no subname is available, use the filename- Just pname -> pname- tcrs' = (lookups' pname) (lookups' fname tcrs)- srcloc = useSrcLoc p- uses = mkUseStatements srcloc tcrs'- p' = transformBi ((flip concatUses) uses) p- in let ?fname = fname in removeDecls (map snd tcrs') p'+ inames :: F.Statement A -> Maybe String+ inames (F.StInclude _ _ (F.ExpValue _ _ (F.ValString fname))) = Just fname+ inames _ = Nothing - -- Given the list of renamed/coercerd variables form common blocks, remove any declaration sites- removeDecls :: (?fname :: Filename) => [RenamerCoercer] -> ProgUnit A -> ProgUnit A- removeDecls rcs p = let (p', remainingAssignments) = runState (transformBiM (removeDecl rcs) p) []- in addToProgUnit p' remainingAssignments+ importIncludeCommons :: PM.FortranVersion -> F.ProgramUnit A -> F.ProgramUnit A+ importIncludeCommons v p =+ foldl (flip (matchPUnit v)) p (reduceCollect inames p) - -- Removes a declaration and collects a list of any default values given at declaration time- -- (which then need to be turned into separate assignment statements)- removeDecl :: (?fname :: Filename) => [RenamerCoercer] -> Decl A -> State [Fortran A] (Decl A)- removeDecl rcs d@(Decl p srcP vars typ) =- (modify (++ assgns)) >> (return $ if (vars' == []) then NullDecl p' srcP- else Decl p' srcP vars' typ)- where- (assgns, vars') = foldl matchVar ([],[]) vars- p' = if (length vars == length vars') then p else p { refactored = Just (fst srcP) }+ insertUses :: [F.Block A] -> F.ProgramUnit A -> F.ProgramUnit A+ insertUses uses = descendBi insertUses'+ where insertUses' :: [F.Block A] -> [F.Block A]+ insertUses' bs = uses ++ bs - matchVar :: ([Fortran A], [(Expr A, Expr A, Maybe Int)])- -> (Expr A, Expr A, Maybe Int)- -> ([Fortran A], [(Expr A, Expr A, Maybe Int)])- matchVar (assgns, decls) dec@(lvar@(Var _ _ [(VarName _ v, _)]), e, _) =- if (hasRenaming v rcs) then- case e of- -- Renaming exists and no default, then remove- NullExpr _ _ -> (assgns, decls)- -- Renaming exists but has default, so create an assignment for this- e -> ((Assg p' srcP lvar e) : assgns, decls)- else -- no renaming, preserve declaration- (assgns, dec : decls)- matchVar (assgns, decls) _ = (assgns, decls)- removeDecl _ d = return d+ matchPUnit :: PM.FortranVersion -> Filename -> F.ProgramUnit A -> F.ProgramUnit A+ matchPUnit v fname p =+ removeDecls v (map snd tcrs') p'+ where+ pname = case F.getName p of+ F.Named pname -> pname+ -- If no subname is available, use the filename+ _ -> fname+ tcrs' = lookups' pname (lookups' fname tcrs)+ pos = getUnitStartPosition p+ uses = mkUseStatementBlocks pos tcrs'+ p' = insertUses uses p - in each fps (\(f, p) -> (f, map importIncludeCommons $ transformBi (matchPUnit f) p))+ -- Given the list of renamed/coercerd variables form common blocks,+ -- remove any declaration sites+ removeDecls :: PM.FortranVersion -> [RenamerCoercer] -> F.ProgramUnit A -> F.ProgramUnit A+ removeDecls v rcs p = addToProgramUnit v p' remainingAssignments+ where+ (p', remainingAssignments) = runState (transformBiM (removeDecl rcs) p) [] + -- Removes a declaration and collects a list of any default values given at+ -- declaration time (which then need to be turned into separate assignment+ -- statements)+ removeDecl :: [RenamerCoercer]+ -> F.Statement A -> State [F.Statement A] (F.Statement A)+ removeDecl rcs d@(F.StDeclaration a s@(FU.SrcSpan p1 _) typ attr decls) = do+ modify (++ assgns)+ return $ F.StDeclaration a' (deleteLine s) typ attr decls'+ where+ (F.AList al sl declsA) = decls+ decls' = F.AList al' sl declsA'+ (assgns, declsA') = foldl matchVar ([],[]) declsA+ -- Update annotation if declarations are being added+ (a', al') = if length declsA == length declsA'+ then (a, al)+ else (a {refactored = Just p1, deleteNode = True}+ , al {refactored = Just pl1})+ where (FU.SrcSpan pl1 _ ) = sl++ matchVar :: ([F.Statement A], [F.Declarator A]) -> F.Declarator A+ -> ([F.Statement A], [F.Declarator A])+ matchVar (assgns, decls)+ dec@(F.DeclVariable a s+ lvar@(F.ExpValue _ _ (F.ValVariable v)) len init) =+ if hasRenaming v rcs+ then case init of+ -- Renaming exists and no default, then remove+ Nothing -> (assgns, decls)+ -- Renaming exists but has default, so create an+ -- assignment for this+ Just initExpr ->+ ((F.StExpressionAssign a' s lvar initExpr) : assgns, decls)+ else -- no renaming, preserve declaration+ (assgns, dec : decls)+ matchVar (assgns, decls) _ = (assgns, decls)+ removeDecl _ d = return d++ -- Adds additional statements to the start of the statement block in a program unit-addToProgUnit :: ProgUnit A -> [Fortran A] -> ProgUnit A-addToProgUnit p [] = p-addToProgUnit (IncludeProg p sp decl Nothing) stmts = IncludeProg p sp decl (Just $- prependStatements (Just $ afterEnd sp) (NullStmt unitAnnotation (afterEnd sp)) stmts)-addToProgUnit (IncludeProg p sp decl (Just f)) stmts = IncludeProg p sp decl (Just $ prependStatements Nothing f stmts)-addToProgUnit p stmts = transformBi (flip addToBlock stmts) p+addToProgramUnit ::+ PM.FortranVersion -> F.ProgramUnit A -> [F.Statement A] -> F.ProgramUnit A+addToProgramUnit v pu stmnts = descendBi (addAfterDecls (map toBlock stmnts)) pu+ where+ -- Find the point where blocks are non-executable statements+ -- and become executable statements/blocks+ addAfterDecls :: [F.Block A] -> [F.Block A] -> [F.Block A]+ addAfterDecls [] ys = ys+ addAfterDecls [x] ys = x : ys+ addAfterDecls (x:(x':xs)) ys+ | F.nonExecutableStatementBlock v x && F.executableStatementBlock v x'+ = x : (ys ++ (x' : xs))+ | F.executableStatementBlock v x = ys ++ (x:(x':xs)) --- Add additional statements to the start of a block-addToBlock :: Block A -> [Fortran A] -> Block A-addToBlock b [] = b-addToBlock (Block p useBlock imps sp decls stmt) stmts = Block p useBlock imps sp decls (prependStatements Nothing stmt stmts)+ addAfterDecls (x:xs) ys = x : addAfterDecls xs ys --- Prepends statements onto a statement-prependStatements :: Maybe SrcSpan -> Fortran A -> [Fortran A] -> Fortran A-prependStatements sp stmt ss = FSeq p' sp' (foldl1 (FSeq p' sp') ss) stmt- where p' = (annotation stmt) { refactored = Just (fst sp') }- sp' = case sp of- Nothing -> srcSpan stmt- Just s -> s+ -- Convert a statement to a simple 'Statement' block+ toBlock :: F.Statement A -> F.Block A+ toBlock stmnt =+ F.BlStatement (F.getAnnotation stmnt) (FU.getSpan stmnt) Nothing stmnt -useSrcLoc :: ProgUnit A -> SrcLoc-useSrcLoc (Main _ _ _ _ b _) = useSrcLocB b-useSrcLoc (Sub _ _ _ _ _ b) = useSrcLocB b-useSrcLoc (Function _ _ _ _ _ _ b)= useSrcLocB b-useSrcLoc (Module _ s _ _ _ _ _) = fst s -- TOOD: this isn't very accurate-useSrcLoc (BlockData _ s _ _ _ _) = fst s-useSrcLocB (Block _ (UseBlock _ s) _ _ _ _) = s+getUnitStartPosition :: F.ProgramUnit A -> FU.SrcSpan+getUnitStartPosition (F.PUMain _ s _ [] _) = s+getUnitStartPosition (F.PUMain _ _ _ bs _) = FU.getSpan (head bs)+getUnitStartPosition (F.PUSubroutine _ s _ _ _ [] _) = s+getUnitStartPosition (F.PUSubroutine _ _ _ _ _ bs _) = FU.getSpan (head bs)+getUnitStartPosition (F.PUFunction _ s _ _ _ _ _ [] _) = s+getUnitStartPosition (F.PUFunction _ _ _ _ _ _ _ bs _) = FU.getSpan (head bs)+getUnitStartPosition (F.PUBlockData _ s _ []) = s+getUnitStartPosition (F.PUBlockData _ _ _ bs) = FU.getSpan (head bs) -renamerToUse :: RenamerCoercer -> [(Variable, Variable)]+renamerToUse :: RenamerCoercer -> [(F.Name, F.Name)] renamerToUse Nothing = [] renamerToUse (Just m) = let entryToPair v (Nothing, _) = [] entryToPair v (Just v', _) = [(v, v')]- in Data.Map.foldlWithKey (\xs v e -> (entryToPair v e) ++ xs) [] m+ in M.foldlWithKey (\xs v e -> entryToPair v e ++ xs) [] m -- make the use statements for a particular program unit's common blocks-mkUseStatements :: SrcLoc -> [(TCommon A, RenamerCoercer)] -> Uses A-mkUseStatements s [] = UseNil (unitAnnotation)-mkUseStatements s (((name, _), r):trs) =- let a = unitAnnotation { refactored = Just s, newNode = True } -- previously-- Just (toCol0 s)- in Uses a (Use (commonName name) (renamerToUse r)) (mkUseStatements s trs) a+mkUseStatementBlocks :: FU.SrcSpan -> [(TCommon A, RenamerCoercer)] -> [F.Block A]+mkUseStatementBlocks s = map mkUseStmnt+ where+ a = unitAnnotation { refactored = Just pos, newNode = True }+ (FU.SrcSpan pos pos') = s+ s' = FU.SrcSpan (toCol0 pos) pos'+ mkUseStmnt x@((name, _), r) = F.BlStatement a s' Nothing $+ F.StUse a s' useName F.Permissive useListA+ where useName = F.ExpValue a s' (F.ValVariable (caml (commonName name)))+ useListA = case useList of [] -> Nothing+ us -> Just (F.AList a s' (reverse us))+ useList = mkUses pos x + mkUses :: FU.Position -> (TCommon A, RenamerCoercer) -> [F.Use A]+ mkUses s ((name, _), r) = map useRenamer (renamerToUse r)++ useRenamer (v, vR) = F.UseRename a s' (F.ExpValue a s' (F.ValVariable v))+ (F.ExpValue a s' (F.ValVariable vR))+ mkRenamerCoercerTLC :: TLCommon A :? source -> TLCommon A :? target -> RenamerCoercer-mkRenamerCoercerTLC x@(fname, (pname, common1)) (_, (_, common2)) = mkRenamerCoercer common1 common2+mkRenamerCoercerTLC x@(fname, (pname, common1)) (_, (_, common2)) =+ mkRenamerCoercer common1 common2 mkRenamerCoercer :: TCommon A :? source -> TCommon A :? target -> RenamerCoercer mkRenamerCoercer (name1, vtys1) (name2, vtys2)- | name1 == name2 = if (vtys1 == vtys2) then Nothing else Just $ generate vtys1 vtys2 Data.Map.empty- | otherwise = error "Can't generate renamer between different common blocks\n"- where- generate [] [] theta = theta- generate ((var1, ty1):vtys1) ((var2, ty2):vtys2) theta =- let varR = if (var1 == var2) then Nothing else Just var2- typR = if (ty1 == ty2) then Nothing else Just (ty1, ty2)- in generate vtys1 vtys2 (Data.Map.insert var1 (varR, typR) theta)- generate _ _ _ = error "Common blocks of different field length\n"--allCoherentCommonsP :: [TLCommon A] -> (Report, Bool)-allCoherentCommonsP commons = foldM (\p (c1, c2) -> (coherentCommonsP c1 c2) >>= (\p' -> return $ p && p')) True (pairs commons)+ | name1 == name2 =+ if vtys1 == vtys2 then Nothing+ else Just $ generate vtys1 vtys2 M.empty+ | otherwise =+ error "Can't generate renamer between different common blocks\n"+ where+ generate [] [] theta = theta+ generate ((var1, ty1):vtys1) ((var2, ty2):vtys2) theta =+ generate vtys1 vtys2 (M.insert var1 (varR, typR) theta)+ where+ varR = if var1 == var2 then Nothing else Just var2+ typR = if ty1 == ty2 then Nothing else Just (ty1, ty2)+ generate _ _ _ = error "Common blocks of different field length\n" -coherentCommonsP :: TLCommon A -> TLCommon A -> (Report, Bool)-coherentCommonsP (f1, (p1, (n1, vtys1))) (f2, (p2, (n2, vtys2))) =- if (n1 == n2) then- let coherent :: [(Variable, Type A)] -> [(Variable, Type A)] -> (Report, Bool)- coherent [] [] = ("", True)- coherent ((var1, ty1):xs) ((var2, ty2):ys)- | af ty1 == af ty2 = let (r', c) = coherent xs ys- in (r', c && True)- | otherwise = let r = (var1 ++ ":" ++ (pprint ty1) ++ "(" ++ (show $ af ty1) ++ ")" ++ " differs from " ++- var2 ++ ":" ++ (pprint ty2) ++ "(" ++ (show $ af ty2) ++ ")" ++ "\n")- (r', _) = coherent xs ys- in (r ++ r', False)- coherent _ _ = ("Common blocks of different field lengths", False) -- Doesn't say which is longer- in coherent vtys1 vtys2+allCoherentCommons :: [TLCommon A] -> (Report, Bool)+allCoherentCommons commons =+ foldM (\p (c1, c2) -> coherentCommons c1 c2 >>= \p' -> return $ p && p')+ True (pairs commons) - else ("", True) -- Not sure if this is supposed to fail here- in retrospect I think no- -- False -> ("Trying to compare differently named common blocks: " ++ show n1 ++ " and " ++ show n2 ++ "\n", False)+coherentCommons :: TLCommon A -> TLCommon A -> (Report, Bool)+coherentCommons (f1, (p1, (n1, vtys1))) (f2, (p2, (n2, vtys2))) =+ if n1 == n2+ then coherentCommons' vtys1 vtys2+ else error $ "Trying to compare differently named common blocks: "+ ++ show n1 ++ " and " ++ show n2 ++ "\n" -introduceModules :: Directory -> [TLCommon A] -> (Report, [(Filename, Program A)])-introduceModules d cenv = mapM (mkModuleFile d) (map (head . head) (groupSortCommonBlock cenv))+coherentCommons' :: [(F.Name, F.BaseType)] -> [(F.Name, F.BaseType)] -> (Report, Bool)+coherentCommons' [] [] = ("", True)+coherentCommons' ((var1, ty1):xs) ((var2, ty2):ys)+ | af ty1 == af ty2 = let (r', c) = coherentCommons' xs ys+ in (r', c && True)+ | otherwise = let r = var1 ++ ":"+ ++ PP.pprintAndRender PM.Fortran90 ty1 Nothing+ ++ "(" ++ show (af ty1) ++ ")"+ ++ " differs from " ++ var2+ ++ ":" ++ PP.pprintAndRender PM.Fortran90 ty2 Nothing+ ++ "(" ++ show (af ty2) ++ ")" ++ "\n"+ (r', _) = coherentCommons' xs ys+ in (r ++ r', False)+ -- TODO - give more information in the error+coherentCommons' _ _ = ("Common blocks of different field lengths", False) +introduceModules ::+ F.MetaInfo -> Directory -> [TLCommon A]+ -> (Report, [(Filename, F.ProgramFile A)])+introduceModules meta dir cenv =+ mapM (mkModuleFile meta dir . head . head) (groupSortCommonBlock cenv) -mkModuleFile :: Directory -> (TLCommon A) -> (Report, (Filename, Program A))-mkModuleFile d (_, (_, (name, varTys))) =- let modname = commonName name- fullpath = d ++ "/" ++ modname ++ ".f90"- r = "Created module " ++ modname ++ " at " ++ fullpath ++ "\n"- in (r, (fullpath, [mkModule modname varTys modname]))+mkModuleFile ::+ F.MetaInfo -> Directory -> TLCommon A -> (Report, (Filename, F.ProgramFile A))+mkModuleFile meta dir (_, (_, (name, varTys))) =+ (r, (path, F.ProgramFile meta [([], mod)] []))+ where+ modname = commonName name+ path = dir ++ modname ++ ".f90"+ r = "Creating module " ++ modname ++ " at " ++ path ++ "\n"+ mod = mkModule modname varTys modname -mkModule :: String -> [(Variable, Type A)] -> String -> ProgUnit A+mkModule :: String -> [(F.Name, F.BaseType)] -> String -> F.ProgramUnit A mkModule name vtys fname =- let a = unitAnnotation { refactored = Just loc }- loc = SrcLoc (fname ++ ".f90") 0 0- sp = (loc, loc)- toDecl (v, t) = Decl a sp [(Var a sp [(VarName a (name ++ "_" ++ v), [])], NullExpr a sp, Nothing)] -- note here could pull in initialising definition? What if conflicts- highlight as potential source of error?- t- decls = foldl1 (DSeq a) (map toDecl vtys)- in Module a (loc, loc) (SubName a fname) (UseNil a) (ImplicitNone a) decls []+ F.PUModule a sp (caml fname) decls Nothing+ where+ a = unitAnnotation { refactored = Just loc, newNode = True }+ loc = FU.Position 0 0 0+ sp = FU.SrcSpan loc loc+ toDeclBlock (v, t) = F.BlStatement a sp Nothing (toStmt (v, t))+ toStmt (v, t) = F.StDeclaration a sp (toTypeSpec t) Nothing (toDeclarator v)+ toTypeSpec t = F.TypeSpec a sp t Nothing+ toDeclarator v = F.AList a sp+ [F.DeclVariable a sp+ (F.ExpValue a sp (F.ValVariable (caml name ++ "_" ++ v))) Nothing Nothing]+ decls = map toDeclBlock vtys
− src/Camfort/Transformation/CommonBlockElimToCalls.hs
@@ -1,178 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}-module Camfort.Transformation.CommonBlockElimToCalls where--import Control.Monad-import Control.Monad.State.Lazy--import Data.Generics.Uniplate.Operations--import Data.List--import Language.Fortran-import Language.Haskell.Syntax (SrcLoc(..))--import Camfort.Helpers-import Camfort.Traverse-import Camfort.Analysis.Annotations-import Camfort.Analysis.Syntax-import Camfort.Analysis.Types-import Camfort.Transformation.Syntax-import Camfort.Transformation.CommonBlockElim--import Debug.Trace--{- This is somewhat experimental and incomplete -}---- Top-level functions for eliminating common blocks in a set of files-commonElimToCalls :: Directory -> [(Filename, Program A)] -> (Report, [(Filename, Program A)])---- Eliminates common blocks in a program directory (and convert to calls)-commonElimToCalls d ps = let (ps', (r, cg)) = runState (analyseCommons ps) ("", [])- (r', ps'') = mapM (introduceCalls cg) ps'- in (r ++ r', ps'')--{-Extending calls version-}-introduceCalls :: [TLCommon A] -> (Filename, Program A) -> (Report, (Filename, Program A))-introduceCalls cenv (fname, ps) = do ps' <- mapM (transformBiM commonElim) ps- -- ps'' <- mapM (transformBiM commonElim'') ps'- return (fname, ps')-- where commonElim s@(Sub a sp mbt (SubName a' moduleName) (Arg p arg asp) b) = - - let commons = lookups moduleName (lookups fname cenv) - sortedC = sortBy cmpTConBNames commons- tArgs = extendArgs (nonNullArgs arg) asp (concatMap snd sortedC)- --ra = p { refactored = Just (fst sp) }- arg' = Arg unitAnnotation (ASeq unitAnnotation arg tArgs) asp- a' = a -- { pRefactored = Just sp }- r = (show $ srcLineCol $ snd asp) ++ ": changed common variables to parameters\n"- in do b' <- transformBiM (extendCalls fname moduleName cenv) b- (r, Sub a' sp mbt (SubName a' moduleName) arg' b')-- commonElim s = --case (getSubName s) of- -- Just n -> transformBiM (extendCalls fname n cenv) s- -- Nothing -> - transformBiM r s - where r :: ProgUnit A -> (Report, ProgUnit A)- r p = case getSubName p of- Just n -> transformBiM (extendCalls fname n cenv) p- Nothing -> return p---extendCalls :: String -> String -> [TLCommon A] -> Fortran A -> (Report, Fortran A)-extendCalls fname localSub cenv f@(Call p sp v@(Var _ _ ((VarName _ n, _):_)) (ArgList ap arglist)) =- let commons = lookups n (map snd cenv)- targetCommonNames = map fst (sortBy cmpTConBNames commons)-- localCommons = lookups localSub (lookups fname cenv)- localCommons' = sortBy cmpTConBNames localCommons-- p' = p { refactored = Just $ toCol0 $ fst sp }- ap' = ap { refactored = Just $ fst sp } -- arglist' = toArgList p' sp (select targetCommonNames localCommons')- r = (show $ srcLineCol $ fst sp) ++ ": call, added common variables as parameters\n"- in (r, Call p' sp v (ArgList ap' $ ESeq p' sp arglist arglist'))- - -- Nothing -> error "Source has less commons than the target!"-extendCalls _ _ _ f = return f- --toArgList :: A -> SrcSpan -> [(Variable, Type A)] -> Expr A-toArgList p sp [] = NullExpr p sp-toArgList p sp ((v, _):xs) = ESeq p sp (Var p sp [(VarName p v, [])]) (toArgList p sp xs)--select :: [Maybe String] -> [TCommon A] -> [(Variable, Type A)]-select [] _ = []-select x [] = error $ "Source has less commons than the target!" ++ show x-select a@(x:xs) b@((y, e):yes) | x == y = e ++ select xs yes- | otherwise = select xs yes--nonNullArgs (ASeq _ _ _) = True-nonNullArgs (ArgName _ _) = True-nonNullArgs (NullArg _) = False---extendArgs nonNullArgs sp' args = if nonNullArgs then - let p' = unitAnnotation { refactored = Just $ snd sp' }- in ASeq p' (ArgName p' "") (extendArgs' sp' args)- else extendArgs' sp' args- --extendArgs' _ [] = NullArg unitAnnotation-extendArgs' sp' ((v, t):vts) = - let p' = unitAnnotation { refactored = Just $ fst sp' }- in ASeq p' (ArgName p' v) (extendArgs' sp' vts)--{- blockExtendDecls (Block a s i sp ds f) ds' = Block a s i sp (DSeq unitAnnotation ds ds') f- - extendArgs _ [] = (NullDecl unitAnnotation, NullArg unitAnnotation)- extendArgs sp' ((v, t):vts) = - let p' = unitAnnotation { refactored = Just $ toCol0 $ fst sp' }- dec = Decl p' [(Var p' sp' [(VarName p' v, [])], NullExpr p' sp')] t- arg = ArgName p' v- (decs, args) = extendArgs sp' vts- in (DSeq p' dec decs, ASeq p' arg args)--}-----{-- collectTCommons :: [Program Annotation] -> State (TCommons Annotation) [Program Annotation]- collectTCommons p = transformBiM collectTCommons' p -(transformBiM collectTCommons)--}---collectCommons :: Filename -> String -> Block A -> State (Report, [TLCommon A]) (Block A)-collectCommons fname pname b = - let tenv = typeEnv b- - commons' :: Decl A -> State (Report, [TLCommon A]) (Decl A)- commons' f@(Common a sp cname exprs) = - do let r' = (show $ srcLineCol $ fst sp) ++ ": removed common declaration\n"- (r, env) <- get- put (r ++ r', (fname, (pname, (cname, typeCommonExprs exprs))):env)- return $ (NullDecl (a { refactored = (Just $ fst sp) }) sp)- commons' f = return f-- typeCommonExprs :: [Expr Annotation] -> [(Variable, Type Annotation)]- typeCommonExprs [] = []- typeCommonExprs ((Var _ sp [(VarName _ v, _)]):es) = - case (tenvLookup v tenv) of- Just t -> (v, t) : (typeCommonExprs es)- Nothing -> error $ "Variable " ++ (show v) ++ " is of an unknown type at: " ++ show sp- typeCommonExprs (e:_) = error $ "Not expecting a non-variable expression in expression at: " ++ show (srcSpan e)-- in transformBiM commons' b --{---- Turn common blocks into type defs-- commonToTypeDefs :: String -> [(String, [Program Annotation])] -> IO Report- commonToTypeDefs d = - let name = d ++ "Types"- unitSrcLoc = SrcLoc (name ++ ".f90") 0 0- decls = undefined- mod = Module () (unitSrcLoc, unitSrcLoc) (SubName () name) [] ImplicitNode decls []- in let ?variant = DefaultPP in writeFile (d ++ "/" ++ name ++ ".f90") (outputF mod)-- - commonToTypeDefs' :: String -> (String, [Program Annotation]) -> [Decls]- commonToTypeDefs' = undefined -- DerivedTypeDef p --}
src/Camfort/Transformation/DeadCode.hs view
@@ -15,44 +15,74 @@ -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-} module Camfort.Transformation.DeadCode where import Camfort.Analysis.Annotations-import Camfort.Analysis.LVA-import Camfort.Analysis.Syntax-import Camfort.Transformation.Syntax-import Camfort.Traverse-import Language.Fortran-+import qualified Language.Fortran.Analysis.DataFlow as FAD+import qualified Language.Fortran.Analysis.Renaming as FAR+import qualified Language.Fortran.Analysis.BBlocks as FAB+import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Util.Position as FU+import qualified Language.Fortran.Analysis as FA import Camfort.Helpers+import Camfort.Helpers.Syntax -import Generics.Deriving.Copoint+import qualified Data.IntMap as IM+import qualified Data.Set as S+import Data.Generics.Uniplate.Operations+import Data.Maybe import GHC.Generics import Debug.Trace -import Data.Generics.Uniplate.Operations+-- Eliminate dead code from a program, based on the fortran-src+-- live-variable analysis -deadCode :: Bool -> (Filename, Program Annotation) -> (Report, (Filename, Program Annotation))-deadCode flag (fname, p) =- let (r, p') = mapM ((transformBi elimEmptyFseq) . transformBiM (elimDead flag)) (lva p)- in if r == "" then (r, (fname, p'))- else (r, (fname, p')) >>= (deadCode flag)+-- Currently only strips out dead code through simple variable assignments+-- but not through array-subscript assignmernts+deadCode :: Bool -> (Filename, F.ProgramFile A)+ -> (Report, (Filename, F.ProgramFile A))+deadCode flag (fname, pf) = (report, (fname, fmap FA.prevAnnotation pf'))+ where+ (report, pf'') = deadCode' flag lva pf'+ -- initialise analysis+ pf' = FAB.analyseBBlocks . FAR.analyseRenames . FA.initAnalysis $ pf+ -- get map of program unit ==> basic block graph+ bbm = FAB.genBBlockMap pf'+ -- build the supergraph of global dependency+ sgr = FAB.genSuperBBGr bbm+ -- extract the supergraph itself+ gr = FAB.superBBGrGraph sgr+ -- live variables+ lva = FAD.liveVariableAnalysis gr -elimEmptyFseq :: Fortran Annotation -> Fortran Annotation-elimEmptyFseq (FSeq _ _ (NullStmt _ _) n2@(NullStmt _ _)) = n2-elimEmptyFseq f = f+deadCode' :: Bool -> FAD.InOutMap (S.Set F.Name)+ -> F.ProgramFile (FA.Analysis A)+ -> (Report, F.ProgramFile (FA.Analysis A))+deadCode' flag lva pf =+ if null report+ then (report, pf')+ else (report, pf') >>= deadCode' flag lva+ where+ (report, pf') = transformBiM (perStmt flag lva) pf -elimDead :: Bool -> Fortran Annotation -> (Report, Fortran Annotation)-elimDead flag x@(Assg a sp@(s1, s2) e1 e2) | (pRefactored a) == flag =- let lOut = liveOut a- -- currently assumes an assign defines only one access (which is usual)- in if ((varExprToAccesses e1) == []) || ((head $ varExprToAccesses e1) `elem` lOut) then - return x- else let report = "o" ++ (show . srcLineCol $ s1) ++ ": removed dead code\n"- in (report, NullStmt (a { refactored = (Just s1) }) (dropLine sp))-elimDead _ x = return x- +-- Core of the transformation happens here on assignment statements+perStmt :: Bool+ -> FAD.InOutMap (S.Set F.Name)+ -> F.Statement (FA.Analysis A) -> (Report, F.Statement (FA.Analysis A))+perStmt flag lva x@(F.StExpressionAssign a sp@(FU.SrcSpan s1 s2) e1 e2)+ | pRefactored (FA.prevAnnotation a) == flag =+ fromMaybe ("", x) $+ do label <- FA.insLabel a+ (_, out) <- IM.lookup label lva+ assignedName <- extractVariable e1+ if assignedName `S.member` out+ then Nothing+ else -- Dead assignment+ Just (report, F.StExpressionAssign a' (dropLine sp) e1 e2)+ where report = "o" ++ show s1 ++ ": removed dead code\n"+ -- Set annotation to mark statement for elimination in+ -- the reprinter+ a' = onPrev (\ap -> ap {refactored = Just s1}) a+perStmt _ _ x = return x
− src/Camfort/Transformation/DerivedTypeIntro.hs
@@ -1,259 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Camfort.Transformation.DerivedTypeIntro where--import Data.Data-import Data.List hiding (union, insert)-import Data.Maybe-import Data.Set hiding (foldl, map)--import Data.Generics.Uniplate.Operations--import Control.Monad.State.Lazy--import Debug.Trace--import qualified Data.Map as Data.Map--import Language.Fortran--import Camfort.Analysis.Annotations-import Camfort.Analysis.IntermediateReps-import Camfort.Analysis.Syntax-import Camfort.Transformation.Syntax-import Camfort.Analysis.Types--import Camfort.Helpers-import Camfort.Traverse--typeStruct :: [(Filename, Program Annotation)] -> (Report, [(Filename, Program Annotation)])-typeStruct fps = mapM (\(f, ps) -> mapM typeStructPerProgram ps >>= (\ps' -> return (f, ps'))) fps---- raph data structures used to build interference graphs--type Graph v a = [((v, v), a)] -- Note, this is graphs with labelled edges--type WeightedEdge v a = ((v, v), (a, Int))-type WeightedGraph v a = [WeightedEdge v a]---- vertices :: WeightedGraph v a -> [v] (also works for Graph v a)-vertices = concatMap (\((x, y), _) -> [x, y])---- isVertex :: v -> WeightedGraph v a -> Bool (also works Graph v a)-isVertex v wgs = elem v (vertices wgs)--getVertex v [] = Nothing-getVertex v (((v1, v2), d):es) = if v == v1 || v == v2 then Just d- else getVertex v es- ---- on-interprocedural version first --typeStructPerProgram :: ProgUnit Annotation -> (Report, ProgUnit Annotation)-typeStructPerProgram p = descendBiM- (\b@(Block a uses implicits span decs blockBody) ->- let - tenv = typeEnv b- - -- Compute graph of semantically related projection variables- es = Exprs `topFrom` b- prjVarsWTarget = map locsFromArrayIndex es - iGraph = toInterferenceGraph prjVarsWTarget- wiGraph = calculateWeights iGraph -- weighted inteference graph- wgf = decomposeWeightedGraph wiGraph-- -- Generate definitions- tDefsAndNames = evalState (mapM (mkTypeDef tenv (fst span, fst span)) wgf) 0-- nwgf = zip wgf (map snd tDefsAndNames)-- rAnnotation = if (length tDefsAndNames > 0)- then unitAnnotation { refactored = Just (fst span) }- else unitAnnotation-- blockBody' = elimProjectionDefs blockBody iGraph-- decs' = foldl (DSeq unitAnnotation) decs (map fst tDefsAndNames)- a' = if (length tDefsAndNames > 0) then a { refactored = Just (fst span) } else a- in -- Create outgoing block- (show wiGraph ++ "\n\n" ++ show wgf, Block a' uses implicits span decs' blockBody')) p---- - Graph Access Variable here is a graph with projection variables at nodes--- - and the array target that they both index as the edge label--toInterferenceGraph :: [[(Variable, Access)]] -> Graph Access Variable -toInterferenceGraph pvars = let rel = concatMap listToSymmRelation pvars- matchingArrayTargets r ((a, x), (b, y)) - | a == b = ((x, y), a) : r- | otherwise = r- in foldl matchingArrayTargets [] rel---listToSymmRelation :: [a] -> [(a, a)] -listToSymmRelation [] = []-listToSymmRelation (x:xs) = ((repeat x) `zip` xs) ++ (listToSymmRelation xs)----- heck coherence of original manual projection approach--correctManualImpl ranges stmt graph = - let (_, pvarmap) = runState (transformBiM collect stmt) Data.Map.empty- in Data.Map.foldWithKey- (\arr vixs p -> case (lookup arr ranges) of- Just (l, u) -> (sort (map snd vixs) == [l..u]) && p) True pvarmap-- where - collect :: Fortran A -> State (Data.Map.Map Variable [(Variable, Integer)]) (Fortran A)- collect a@(Assg p sp e1 e2) = - do indexMap <- get- case (do v <- varExprToVariable e1- arr <- getVertex (VarA v) graph- case e2 of - (ConS _ _ val) -> - case (Data.Map.lookup arr indexMap) of- Just ixs -> - case (lookup v ixs) of- Just val' -> Nothing -- error "Repeated definition of projection"- Nothing -> Just $ Data.Map.update (\ixs -> Just $ ((v, read $ val) : ixs)) arr indexMap- Nothing -> Just $ Data.Map.insert arr [(v, read $ val)] indexMap) of- Just indexMap' -> do put indexMap'; return a- Nothing -> return a- collect f = return f---elimProjectionDefs :: Fortran A -> Graph Access Variable -> Fortran A-elimProjectionDefs stmt graph = transformBi ef stmt- where ef a@(Assg p sp e1 e2) = - case (varExprToVariable e1) of- Just v -> if (isVertex (VarA v) graph) then- NullStmt (p { refactored = Just $ dropLine' sp }) sp- else a- Nothing -> a- ef f = f- --arrayAccessToProjection :: Fortran A -> Graph Access Variable -> Fortran A-arrayAccessToProjection = undefined----- ounts number of duplicate edges and makes this the "weight"--calculateWeights :: (Eq (AnnotationFree a), Eq (AnnotationFree v), Ord a, Ord v) => Graph v a -> WeightedGraph v a-calculateWeights xs = calcWs (sort xs) 1- where calcWs [] _ = []- calcWs [((v1, v2), a)] n = [((v1, v2), (a, n))]- calcWs (e@((v1, v2), a):(e':es)) n | ((af e == af e') || (af e == (af (swap e'))))- = calcWs (e':es) (n + 1)- | otherwise = ((v1, v2), (a, n)) : (calcWs (e':es) 1)--swap ((a, b), v) = ((b, a), v)---- inds the variables that are used to index arrays directly--locsFromArrayIndex :: Data t => t -> [(Variable, Access)]-locsFromArrayIndex x = - concat . concat $ - each (Vars `from` x)- (\(Var _ _ ves) -> - each ves (\(VarName _ v, ixs) -> - if (not $ all isConstant ixs) - then map (\x -> (v, x)) (Locs `from` ixs)- else []))- ----findMatch v ix ((wg, n):wgns) = vertices - ---- replaceAccess :: [(WeightedGraph Variable Access, Variable)] -> Block Annotation -> Block Annotation--- replaceAccess wgns x = transformBi (\t@(VarName _ v, ixs) -> t) x--- --- --mkTyDecl :: SrcSpan -> Variable -> Type Annotation -> Decl Annotation-mkTyDecl sp v t = let ua = unitAnnotation- in Decl ua sp [(Var ua sp [(VarName ua v, [])], NullExpr ua sp, Nothing)] t--mkTypeDef :: TypeEnv Annotation -> SrcSpan -> WeightedGraph Access Variable -> State Int (Decl Annotation, String)-mkTypeDef tenv sp wg = (inventName wg) >>= (\name -> - let edgeToDecls ((vx, vy), (va, w)) = - case (lookup va tenv) of- Just t -> [mkTyDecl sp (accessToVarName vx) (arrayElementType t),- mkTyDecl sp (accessToVarName vy) (arrayElementType t)]- Nothing -> error $ "Can't find the type of " ++ show va ++ "\n"-- ra = unitAnnotation { refactored = Just (fst sp) } -- (_, (arrayVar, _)) = head wg-- tdecls = concatMap edgeToDecls wg- typeDecl = DerivedTypeDef ra sp (SubName ra name) [] [] tdecls-- typeCons = BaseType ra (DerivedType ra (SubName ra name)) [] (NullExpr ra sp) (NullExpr ra sp)- valDecl = Decl ra sp [(Var ra sp [(VarName ra (arrayVar ++ name), [])] , NullExpr ra sp, Nothing)] typeCons- in return $ (DSeq unitAnnotation typeDecl valDecl, name))--inventName :: WeightedGraph Access Variable -> State Int String-inventName graph = do n <- get- put (n + 1)- let vs = vertices graph- return $ map mode (transpose (map accessToVarName vs)) ++ (show n)--- -mode :: String -> Char-mode x = let freqs = (map (\x -> (head x, length x))) . group . sort $ x- sortedFreqs = sortBy (\x -> \y -> (snd x) `compare` (snd y)) freqs- max = last sortedFreqs- in -- mode or 'X' if mode is less than the majority- if (snd max) > ((length x) `div` 2) then fst max else 'X'--decomposeWeightedGraph :: forall v a . (Show v, Ord v, Ord a) => WeightedGraph v a -> [WeightedGraph v a]-decomposeWeightedGraph g = map snd (concatMap (foldl binEdge []) (groupBy groupOnArrayVar (sortBy sortOnArrayVar g)))- where groupOnArrayVar (_, (av, _)) (_, (av', _)) = av == av'- sortOnArrayVar (_, (av, _)) (_, (av', _)) = compare av av'---- ap snd (foldl binEdge [] g)---- bins" edges into a list of graphs with a set of their vertices--binEdge :: (Show v, Ord v, Ord a) => [(Set v, WeightedGraph v a)] -> WeightedEdge v a -> [(Set v, WeightedGraph v a)]-binEdge bins e@((x, y), _) = - let findBin v [] = ((insert x empty, []), [])- findBin v ((vs, es):bs) | member v vs = ((insert v vs, es), bs)- | otherwise = let (n, bs') = findBin v bs- in (n, (vs, es) : bs')- ((vs, es), bins') = findBin x bins- ((vs', es'), bins'') = findBin y bins'- in (vs `union` vs', e : (es ++ es')) : bins''- - ----- binEdge bins e@((x, y), _) = let r = binVertex y e (binVertex x e bins) in (show r) `trace` r---- binVertex :: Ord a => a -> WeightedEdge a -> [(Set a, WeightedGraph a)] -> [(Set a, WeightedGraph a)]--- binVertex x e ss = bin' x e ss [] Nothing--- where bin' x e [] bs' Nothing = (insert x empty, [e]) : bs'--- bin' x e [] bs' (Just s) = s : bs'--- --- bin' x e ((vs, es):bs) bs' ms | member x vs = --- case ms of --- Nothing -> bin' x e bs bs' (Just (insert x vs, e:es))--- Just (vs', es') -> bin' x e bs bs' (Just (union vs' (insert x vs'), (e:es) ++ es'))--- | otherwise = bin' x e bs ((vs, es):bs) ms
src/Camfort/Transformation/EquivalenceElim.hs view
@@ -14,96 +14,155 @@ limitations under the License. -} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE FlexibleContexts #-} module Camfort.Transformation.EquivalenceElim where import Data.Data import Data.List-+import qualified Data.Map as M import Data.Generics.Uniplate.Operations import Control.Monad.State.Lazy -import Language.Fortran+import qualified Language.Fortran.AST as F+import qualified Language.Fortran.Analysis.Types as FAT (analyseTypes, TypeEnv)+import qualified Language.Fortran.Util.Position as FU+import qualified Language.Fortran.Analysis.Renaming as FAR+import qualified Language.Fortran.Analysis as FA import Camfort.Output-import Camfort.Traverse import Camfort.Helpers--import Language.Fortran.Pretty-+import Camfort.Helpers.Syntax import Camfort.Analysis.Annotations-import Camfort.Analysis.Syntax-import Camfort.Analysis.Types- import Camfort.Transformation.DeadCode-import Camfort.Transformation.Syntax import Debug.Trace -type RfEqState = ([[Expr Annotation]], Int, Report)+type A1 = FA.Analysis Annotation+type RmEqState = ([[F.Expression A1]], Int, Report) -refactorEquivalences :: (Filename, Program Annotation) -> (Report, (Filename, Program Annotation))-refactorEquivalences (fname, p) = - let ?fname = fname- in do p' <- mapM (transformBiM equivalences) p- deadCode True (fname, p')- where equivalences :: (?fname :: String) => Block Annotation -> (Report, Block Annotation)- equivalences b = let equiv = do b' <- rmEquivalences b- transformBiM (addCopy (typeEnv b)) b'- (b', (_, _, r)) = runState equiv ([], 0, "")- in (r, b')+refactorEquivalences ::+ (Filename, F.ProgramFile A) -> (Report, (Filename, F.ProgramFile A))+refactorEquivalences (fname, pf) = do+ -- initialise analysis+ let pf' = FAR.analyseRenames . FA.initAnalysis $ pf+ -- calculate types+ let (pf'', typeEnv) = FAT.analyseTypes pf'+ -- Remove equivalences and add appropriate copy statements+ pf''' <- refactoring typeEnv pf''+ -- Lastly deadcode eliminate any redundant copy statements+ -- generated by the refactoring (but don't dead code elim+ -- existing code)+ deadCode True (fname, fmap FA.prevAnnotation pf''')+ where+ refactoring :: FAT.TypeEnv -> F.ProgramFile A1 -> (Report, F.ProgramFile A1)+ refactoring tenv pf = (report, pf')+ where+ (pf', (_, _, report)) = runState equiv ([], 0, "") -addCopy :: (?fname :: String) => TypeEnv Annotation -> Fortran Annotation -> State RfEqState (Fortran Annotation)-addCopy tys x@(Assg a sp@(s1, s2) e1 e2) | not (pRefactored a) =- do eqs <- equivalents e1- if (length eqs > 1) then + equiv = do pf' <- transformBiM perBlockRmEquiv pf+ descendBiM (addCopysPerBlockGroup tenv) pf' - - let a' = a { refactored = Just s1 }- sp' = refactorSpan sp- eqs' = deleteBy (\x -> \y -> (af x) == (af y)) e1 eqs -- remove self from list+addCopysPerBlockGroup :: FAT.TypeEnv -> [F.Block A1] -> State RmEqState [F.Block A1]+addCopysPerBlockGroup tenv blocks = do+ blockss <- mapM (addCopysPerBlock tenv) blocks+ return $ concat blockss - -- Create copy statements- mkCopy (n, e') = let sp' = refactorSpanN n sp- in - case ((varExprToVariable e1) >>= (\v1' -> varExprToVariable e' >>= (\v' -> return $ eqType v1' v' tys))) of- Nothing -> Assg a' sp' e' e1 -- could be an error- Just False -> Assg a' sp' e' (Var a' sp' [(VarName a' "transfer", [e1, e'])])- Just True -> Assg a' sp' e' e1- eqs'' = map mkCopy (zip [0..(length eqs')] eqs')+addCopysPerBlock :: FAT.TypeEnv -> F.Block A1 -> State RmEqState [F.Block A1]+addCopysPerBlock tenv x@(F.BlStatement a0 s0 lab+ (F.StExpressionAssign a sp@(FU.SrcSpan s1 s2) dstE srcE))+ | not (pRefactored $ FA.prevAnnotation a) = do+ -- Find all variables/cells that are equivalent to the target+ -- of this assignment+ eqs <- equivalentsToExpr dstE+ -- If there is only one, then it must refer to itself, so do nothing+ if length eqs <= 1+ then return [x]+ -- If there are more than one, copy statements must be generated+ else do+ (equivs, n, r) <- get - -- Reporting- (l, c) = srcLineCol s1- reportF (e', i) = ?fname ++ show (l + i, c) ++ ": addded copy: " ++ (pprint e') ++ " due to refactored equivalence\n"- report n = concatMap reportF (zip eqs'' [n..(n + length eqs'')])+ -- Remove the destination from the equivalents+ let eqs' = deleteBy (\x y -> af x == af y) dstE eqs - in do -- Update refactoring state- (equivs, n, r) <- get- put (equivs, n + (length eqs'), r ++ (report n))+ -- Make copy statements+ let pos = afterAligned sp+ let copies = map (mkCopy tenv pos dstE) eqs' - -- Sequence original assignment with new assignments- return $ FSeq a sp x (foldl1 (FSeq a' sp') eqs'')- else- return x-addCopy tys x = return x + -- Reporting+ let (FU.Position _ c l) = s1+ let reportF i = show (l + i) ++ ":" ++ show c+ ++ ": added copy due to refactored equivalence\n"+ let report n = concatMap reportF [n..(n + length copies - 1)] + -- Update refactoring state+ put (equivs, n + length eqs', r ++ report n)+ -- Sequence original assignment with new assignments+ return $ x : copies -rmEquivalences :: (?fname :: String) => (Block Annotation) -> State RfEqState (Block Annotation)-rmEquivalences = transformBiM rmEquiv'- where rmEquiv' :: Decl Annotation -> State RfEqState (Decl Annotation)- rmEquiv' f@(Equivalence a sp equivs) =- do (ess, n, r) <- get- put (equivs:ess, n - 1, r ++ ?fname ++ (show . srcLineCol . fst $ sp) ++ ": removed equivalence \n")- return (NullDecl (a { refactored = (Just $ fst sp) }) (dropLine sp))- rmEquiv' f = return f+addCopysPerBlock tenv x = do+ x' <- descendBiM (addCopysPerBlockGroup tenv) x+ return [x'] --- equivalents e" returns a list of variables/memory cells that have been equivalenced with "e". --- -equivalents :: (?fname :: String) => Expr Annotation -> State RfEqState [Expr Annotation]-equivalents x = let inGroup x [] = []- inGroup x (xs:xss) = if (AnnotationFree x `elem` (map AnnotationFree xs)) then xs- else inGroup x xss- in do (equivs, _, _) <- get - return (inGroup x equivs)+-- see if two expressions have the same type+equalTypes tenv e e' = do+ v1 <- extractVariable e+ v2 <- extractVariable e'+ t1 <- M.lookup v1 tenv+ t2 <- M.lookup v2 tenv+ if t1 == t2 then Just t1 else Nothing++-- Create copy statements. Parameters:+-- * A type environment to find out if a type cast is needed+-- * A SrcPos where the copy statements are going to inserted at+-- * The source expression+-- * The number of copies to increment the line by+-- paired with the destination expression+mkCopy :: FAT.TypeEnv+ -> FU.Position+ -> F.Expression A1 -> F.Expression A1 -> F.Block A1+mkCopy tenv pos srcE dstE = FA.initAnalysis $+ F.BlStatement a sp Nothing $+ case equalTypes tenv srcE dstE of+ -- Types not equal, so create a transfer+ Nothing -> F.StExpressionAssign a sp dstE' call+ where+ call = F.ExpFunctionCall a sp transf argst+ transf = F.ExpValue a sp (F.ValVariable "transfer")+ argst = Just (F.AList a sp args)+ args = map (F.Argument a sp Nothing) [srcE', dstE']+ -- Types are equal, simple a assignment+ Just t -> F.StExpressionAssign a sp dstE' srcE'+ where+ -- Set position to be at col = 0+ sp = FU.SrcSpan (toCol0 pos) (toCol0 pos)+ -- But store the aligned position in refactored so+ -- that the reprint algorithm can add the appropriate indentation+ a = unitAnnotation { refactored = Just pos, newNode = True }+ dstE' = FA.stripAnalysis dstE+ srcE' = FA.stripAnalysis srcE++perBlockRmEquiv :: F.Block A1 -> State RmEqState (F.Block A1)+perBlockRmEquiv = transformBiM perStatementRmEquiv++perStatementRmEquiv :: F.Statement A1 -> State RmEqState (F.Statement A1)+perStatementRmEquiv f@(F.StEquivalence a sp@(FU.SrcSpan spL spU) equivs) = do+ (ess, n, r) <- get+ let report = r ++ show spL ++ ": removed equivalence \n"+ put (((map F.aStrip) . F.aStrip $ equivs) ++ ess, n - 1, r ++ report)+ let a' = onPrev (\ap -> ap {refactored = Just spL, deleteNode = True}) a+ return (F.StEquivalence a' (deleteLine sp) equivs)+perStatementRmEquiv f = return f++-- 'equivalents e' returns a list of variables/memory cells+-- that have been equivalenced with "e".+equivalentsToExpr :: F.Expression A1 -> State RmEqState [F.Expression A1]+equivalentsToExpr x = do+ (equivs, _, _) <- get+ return (inGroup x equivs)+ where+ inGroup x [] = []+ inGroup x (xs:xss) =+ if AnnotationFree x `elem` map AnnotationFree xs+ then xs+ else inGroup x xss
− src/Camfort/Transformation/Syntax.hs
@@ -1,127 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}--{-# LANGUAGE DeriveGeneric #-}--module Camfort.Transformation.Syntax where---- tandard imports --import Data.Char-import Data.List-import Control.Monad.State.Lazy-import qualified Data.Map as Data.Map---- ata-type generics imports--import Data.Data-import Data.Generics.Uniplate.Data-import Data.Generics.Uniplate.Operations-import Data.Generics.Zipper-import Data.Typeable---- amFort specific functionality--import Camfort.Analysis.Annotations-import Camfort.Analysis.IntermediateReps-import Camfort.Traverse-import Language.Fortran---- import Language.Haskell.Syntax (SrcLoc(..))---- ODO: Needs fixing with the spans - need to pull apart and put back together--reassociate :: Fortran Annotation -> Fortran Annotation-reassociate (FSeq a1 sp1 (FSeq a2 sp2 a b) c) = FSeq a1 sp1 (reassociate a) (FSeq a2 sp2 (reassociate b) (reassociate c))-reassociate t = t---- reassociate :: Fortran Annotation -> Fortran Annotation--- reassociate (FSeq a1 sp1 (FSeq a2 sp2 a b) c) = FSeq a1 sp1 (reassociate a) (FSeq a2 sp2 (reassociate b) (reassociate c))--- reassociate t = t----- elpers to do with source locations and parsing--refactorSpan :: SrcSpan -> SrcSpan-refactorSpan (SrcLoc f ll cl, SrcLoc _ lu cu) = (SrcLoc f (lu+1) 0, SrcLoc f lu cu)--refactorSpanN :: Int -> SrcSpan -> SrcSpan-refactorSpanN n (SrcLoc f ll cl, SrcLoc _ lu cu) = (SrcLoc f (lu+1+n) 0, SrcLoc f (lu+n) cu)--incLine (SrcLoc f l c) = SrcLoc f (l + 1) c-decLine (SrcLoc f l c) = SrcLoc f (l - 1) c-incCol (SrcLoc f l c) = SrcLoc f l (c + 1)-decCol (SrcLoc f l c) = SrcLoc f l (c - 1)-toCol0 (SrcLoc f l c) = SrcLoc f l 0---- ropLine extends a span to the start of the next line--- his is particularly useful if a whole line is being redacted from a source file--linesCovered :: SrcLoc -> SrcLoc -> Int-linesCovered (SrcLoc _ l1 _) (SrcLoc _ l2 _) = l2 - l1 + 1--dropLine :: SrcSpan -> SrcSpan-dropLine (s1, SrcLoc f l c) = (s1, SrcLoc f (l+1) 0)--dropLine' :: SrcSpan -> SrcLoc-dropLine' (SrcLoc f l c, _) = SrcLoc f l 0--srcLineCol :: SrcLoc -> (Int, Int)-srcLineCol (SrcLoc _ l c) = (l, c)--minaa (SrcLoc f l c) = (SrcLoc f (l-1) c)--nullLoc :: SrcLoc-nullLoc = SrcLoc "" 0 0--nullSpan :: SrcSpan-nullSpan = (nullLoc, nullLoc)--afterEnd :: SrcSpan -> SrcSpan-afterEnd (_, SrcLoc f l c) = (SrcLoc f (l+1) 0, SrcLoc f (l+1) 0)---- ariable renaming--caml (x:xs) = (toUpper x) : xs--type Renamer = Data.Map.Map Variable Variable--type RenamerCoercer = Maybe (Data.Map.Map Variable (Maybe Variable, Maybe (Type A, Type A)))- -- Nothing represents an overall identity renamer/coercer for efficiency- -- a Nothing for a variable represent a variable-level (renamer) identity - -- a Nothing for a type represents a type-level (coercer) identity--applyRenaming :: (Typeable (t A), Data (t A)) => Renamer -> (t A) -> (t A)-applyRenaming r = transformBi ((\vn@(VarName p v) -> case Data.Map.lookup v r of- Nothing -> vn- Just v' -> VarName p v')::(VarName A -> VarName A))--class Renaming r where- hasRenaming :: Variable -> r -> Bool--instance Renaming RenamerCoercer where- hasRenaming _ Nothing = False- hasRenaming v (Just rc) = Data.Map.member v rc---- sometimes we have a number of renamer coercers together-instance Renaming [RenamerCoercer] where- hasRenaming v rcss = or (map (hasRenaming v) rcss)
− src/Camfort/Traverse.hs
@@ -1,183 +0,0 @@-{-- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish-- Licensed under the Apache License, Version 2.0 (the "License");- you may not use this file except in compliance with the License.- You may obtain a copy of the License at-- http://www.apache.org/licenses/LICENSE-2.0-- Unless required by applicable law or agreed to in writing, software- distributed under the License is distributed on an "AS IS" BASIS,- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.- See the License for the specific language governing permissions and- limitations under the License.--}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}--module Camfort.Traverse where--import Camfort.Analysis.Annotations-import Language.Fortran--import Generics.Deriving.Base-import Generics.Deriving.Copoint-import GHC.Generics--import Control.Monad.Trans.Writer.Lazy--import Data.Generics.Zipper-import Data.Generics.Aliases-import Data.Generics.Str-import Data.Generics.Uniplate.Operations--import Language.Fortran.Lexer--import Control.Comonad--import Data.Data-import Data.Maybe-import Data.Monoid--import Debug.Trace--#if __GLASGOW_HASKELL__ < 800-instance Monoid x => Monad ((,) x) where- return a = (mempty, a)- (x, a) >>= k = let (x', b) = k a- in (mappend x x', b)-#endif----- Data-type generic comonad-style traversal--extendBi :: (Biplate (from a) (to a), RComonad to) => (to a -> a) -> (from a) -> (from a)-extendBi f x = case biplate x of- (current, generate) -> generate $ strMap (rextend f) current--reduceCollect :: (Data s, Data t, Uniplate t, Biplate t s) => (s -> Maybe a) -> t -> [a]-reduceCollect k x = execWriter (transformBiM (\y -> do case k y of- Just x -> tell [x]- Nothing -> return ()- return y) x)---- Data-type generic comonad-style traversal with zipper (contextual traversal)--everywhere :: (Zipper a -> Zipper a) -> Zipper a -> Zipper a-everywhere k z = let everywhere' = enterRight . enterDown . k-- enterDown z = case (down' z) of- Just dz -> let dz' = everywhere' dz- in case (up $ dz') of- Just uz -> uz- Nothing -> dz'- Nothing -> z-- enterRight z = case (right z) of- Just rz -> let rz' = everywhere' rz- in case (left $ rz') of- Just lz -> lz- Nothing -> rz'- Nothing -> z- in everywhere' z--zfmap :: Data a => (a -> a) -> Zipper (d a) -> Zipper (d a)-zfmap f x = zeverywhere (mkT f) x---- This one is less useful as the definitions for comonads are then very annoying--extendBi' :: (Biplate (from a) (to a), Comonad to) => (to a -> a) -> (from a) -> (from a)-extendBi' f x = case biplate x of- (current, generate) -> generate $ strMap (extend f) current--class RComonad t where- rextract :: t a -> a- rextend :: (t a -> a) -> t a -> t a--class RFunctor t where- rfmap :: (a -> a) -> t a -> t a--instance RComonad Fortran where- rextract x = tag x-- rextend k y@(Assg _ sp e1 e2) = Assg (k y) sp e1 e2- rextend k y@(For _ sp v e1 e2 e3 fs) = For (k y) sp v e1 e2 e3 (rextend k fs)- rextend k y@(FSeq _ sp f1 f2) = FSeq (k y) sp (rextend k f1) (rextend k f2)- rextend k y@(If _ sp e f1 fes f3) = let fes' = map (\(e, f) -> (e, rextend k f)) fes- f3' = case f3 of- Nothing -> Nothing- Just f3a -> Just (rextend k f3a)- in If (k y) sp e (rextend k f1) fes' f3'- rextend k y@(Allocate _ sp e1 e2) = Allocate (k y) sp e1 e2- rextend k y@(Backspace _ sp sp') = Backspace (k y) sp sp'- rextend k y@(Call _ sp e as) = Call (k y) sp e as- rextend k y@(Open _ sp s) = Open (k y) sp s- rextend k y@(Close _ sp s) = Close (k y) sp s- rextend k y@(Continue _ sp) = Continue (k y) sp- rextend k y@(Cycle _ sp s) = Cycle (k y) sp s- rextend k y@(Deallocate _ sp es e) = Deallocate (k y) sp es e- rextend k y@(Endfile _ sp s) = Endfile (k y) sp s- rextend k y@(Exit _ sp s) = Exit (k y) sp s- rextend k y@(Forall _ sp es f) = Forall (k y) sp es (rextend k f)- rextend k y@(Goto _ sp s) = Goto (k y) sp s- rextend k y@(Nullify _ sp e) = Nullify (k y) sp e- rextend k y@(Inquire _ sp s e) = Inquire (k y) sp s e- rextend k y@(Rewind _ sp s) = Rewind (k y) sp s- rextend k y@(Stop _ sp e) = Stop (k y) sp e- rextend k y@(Where _ sp e f Nothing) = Where (k y) sp e (rextend k f) Nothing- rextend k y@(Where _ sp e f (Just f')) = Where (k y) sp e (rextend k f) (Just (rextend k f'))- rextend k y@(Write _ sp s e) = Write (k y) sp s e- rextend k y@(PointerAssg _ sp e1 e2) = PointerAssg (k y) sp e1 e2- rextend k y@(Return _ sp e) = Return (k y) sp e- rextend k y@(Label _ sp s f) = Label (k y) sp s (rextend k f)- rextend k y@(Print _ sp e es) = Print (k y) sp e es- rextend k y@(ReadS _ sp s e) = ReadS (k y) sp s e- rextend k y@(TextStmt _ sp s) = TextStmt (k y) sp s- rextend k y@(NullStmt _ sp) = NullStmt (k y) sp--class Refill d where- refill :: d a -> a -> d a--instance Refill Fortran where- refill y@(Assg _ sp e1 e2) a = Assg a sp e1 e2- refill y@(For _ sp v e1 e2 e3 fs) a = For a sp v e1 e2 e3 fs- refill y@(DoWhile _ sp e f) a = DoWhile a sp e f- refill y@(FSeq _ sp f1 f2) a = FSeq a sp f1 f2- refill y@(If _ sp e f1 fes f3) a = If a sp e f1 fes f3- refill y@(Allocate _ sp e1 e2) a = Allocate a sp e1 e2- refill y@(Backspace _ sp sp') a = Backspace a sp sp'- refill y@(Call _ sp e as) a = Call a sp e as- refill y@(Open _ sp s) a = Open a sp s- refill y@(Close _ sp s) a = Close a sp s- refill y@(Continue _ sp) a = Continue a sp- refill y@(Cycle _ sp s) a = Cycle a sp s- refill y@(DataStmt _ sp p) a = DataStmt a sp p- refill y@(Deallocate _ sp es e) a = Deallocate a sp es e- refill y@(Endfile _ sp s) a = Endfile a sp s- refill y@(Exit _ sp s) a = Exit a sp s- refill y@(Forall _ sp es f) a = Forall a sp es f- refill y@(Format _ sp s) a = Format a sp s- refill y@(Goto _ sp s) a = Goto a sp s- refill y@(Nullify _ sp e) a = Nullify a sp e- refill y@(Inquire _ sp s e) a = Inquire a sp s e- refill y@(Pause _ sp s) a = Pause a sp s- refill y@(Rewind _ sp s) a = Rewind a sp s- refill y@(Stop _ sp e) a = Stop a sp e- refill y@(Where _ sp e f f') a = Where a sp e f f'- refill y@(Write _ sp s e) a = Write a sp s e- refill y@(PointerAssg _ sp e1 e2) a = PointerAssg a sp e1 e2- refill y@(Return _ sp e) a = Return a sp e- refill y@(Label _ sp s f) a = Label a sp s f- refill y@(Print _ sp e es) a = Print a sp e es- refill y@(ReadS _ sp s e) a = ReadS a sp s e- refill y@(TextStmt _ sp s) a = TextStmt a sp s- refill y@(NullStmt _ sp) a = NullStmt a sp---annotation :: Tagged g => g a -> a-annotation = tag
src/Main.hs view
@@ -30,15 +30,13 @@ import Camfort.Functionality import Data.Text (pack, unpack, split)-import qualified Data.Map as M import Data.Maybe {-| The entry point to CamFort. Displays user information, and handlers which functionality is being requested -} main = do- putStrLn introMsg args <- getArgs-+ putStrLn "" if length args >= 2 then let (func : (inp : _)) = args@@ -59,9 +57,11 @@ fun inp (excluded_files opts) outp opts Nothing -> putStrLn fullUsageInfo - else if length args == 1- then putStrLn $ usage ++ "Please specify an input file/directory"- else putStrLn fullUsageInfo+ else do+ putStrLn introMsg+ if length args == 1+ then putStrLn $ usage ++ "Please specify an input file/directory"+ else putStrLn fullUsageInfo -- * Options for CamFort and information on the different modes @@ -80,6 +80,10 @@ "stencil specification inference mode. ID = Do, Assign, or Both" , Option [] ["debug"] (NoArg Debug) "enable debug mode"+ , Option [] ["doxygen"] (NoArg Doxygen)+ "synthesise annotations compatible with Doxygen"+ , Option [] ["ford"] (NoArg Ford)+ "synthesise annotations compatible with Ford" ] compilerOpts :: [String] -> IO ([Flag], [String])@@ -102,10 +106,7 @@ , String))] refactorings = [("common", (common, "common block elimination")),- ("commonArg", (commonToArgs,- "common block elimination (to parameter passing)")), ("equivalence", (equivalences, "equivalence elimination")),- ("dataType", (typeStructuring, "derived data type introduction")), ("dead", (dead, "dead-code elimination"))] {-| List of analses provided by CamFort -}@@ -113,22 +114,21 @@ , (FileOrDir -> [Filename] -> FileOrDir -> Options -> IO () , String))] analyses =- [--("asts", (asts,--- "blank analysis, outputs analysis files with AST information")),--- ("lva", (lvaA, "live-variable analysis")),+ [ ("count", (countVarDecls, "count variable declarations")), ("ast", (ast, "print the raw AST -- for development purposes")), ("stencils-check", (stencilsCheck, "stencil spec checking")), ("stencils-infer", (stencilsInfer, "stencil spec inference")), ("stencils-synth", (stencilsSynth, "stencil spec synthesis")), ("units-suggest", (unitsCriticals,- "suggest variables to annotate for units-of-measure for maximum coverage")),+ "suggest variables to annotate with\+ \units-of-measure for maximum coverage")), ("units-check", (unitsCheck, "unit-of-measure checking")), ("units-infer", (unitsInfer, "unit-of-measure inference")), ("units-synth", (unitsSynth, "unit-of-measure synthesise specs.")) ] -- * Usage and about information-version = "0.804"+version = "0.900" introMsg = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure." usage = "Usage: camfort <MODE> <INPUT> [OUTPUT] [OPTIONS...]\n" menu =
tests/Camfort/Analysis/CommentAnnotatorSpec.hs view
@@ -37,8 +37,8 @@ let parser _ = Left $ ProbablyAnnotation "This is a warning." :: Either AnnotationParseError String shouldBe (runWriter (annotateComments parser pf5))- (pf5e, [ "Error (1:1,1:1): This is a warning."- , "Error (1:1,1:1): This is a warning." ])+ (pf5e, [ "Error (1:1)-(1:1): This is a warning."+ , "Error (1:1)-(1:1): This is a warning." ]) data A = A { annLink :: Maybe (Block A)
tests/Camfort/Specification/Stencils/CheckSpec.hs view
@@ -3,86 +3,62 @@ module Camfort.Specification.Stencils.CheckSpec (spec) where import Camfort.Analysis.CommentAnnotator-import Camfort.Specification.Stencils.Model import Camfort.Specification.Stencils.CheckBackend import Camfort.Specification.Stencils.CheckFrontend import qualified Camfort.Specification.Stencils.Grammar as SYN import Camfort.Specification.Stencils.Syntax -import Test.Hspec hiding (Spec)-import qualified Test.Hspec as Test+import Test.Hspec promoteErrors :: Either String x -> Either AnnotationParseError x promoteErrors (Left x) = Left (ProbablyAnnotation x) promoteErrors (Right x) = Right x -parseAndConvert x = let ?renv = [] in SYN.specParser x >>= (promoteErrors . synToAst)+parseAndConvert x =+ let ?renv = []+ in SYN.specParser x >>= (promoteErrors . synToAst) extract (Right (Right [(_, s)])) = s -spec :: Test.Spec-spec = describe "Stencils - Check" $ do- it "parse and convert simple exact stencil (1)" $- (parseAndConvert "= stencil forward(depth=1, dim=1) :: x")- `shouldBe`- (Right $ Right $ [(["x"], Specification $ Left $- Exact (Spatial NonLinear (Sum [Product [Forward 1 1 True]])))])-- it "parse and convert simple exact stencil (2)" $- (parseAndConvert "= stencil forward(depth=1, dim=1) :: x, y, z")- `shouldBe`- (Right $ Right $ [(["x","y","z"], Specification $ Left $- Exact (Spatial NonLinear (Sum [Product [Forward 1 1 True]])))])-- it "parse and convert simple exact stencil with irreflexive (2a)" $- (parseAndConvert "= stencil centered(depth=1, dim=2, irreflexive) :: x, y, z")- `shouldBe`- (Right $ Right $ [(["x","y","z"], Specification $ Left $- Exact (Spatial NonLinear (Sum [Product [Centered 1 2 False]])))])-- it "parse and convert simple exact stencil with irreflexive (2b)" $- let ?dimensionality = 2 in- ((extract $- parseAndConvert "= stencil centered(depth=1, dim=2, irreflexive) :: x, y, z")- `eqByModel`- (Specification $ Left $ Exact (Spatial NonLinear- (Sum [Product [Centered 1 2 False]]))))- `shouldBe` True-+spec :: Spec+spec =+ describe "Stencils - Check" $ do+ describe "Parsing comments into internal rep" $ do+ it "parse and convert simple exact stencil (1)" $+ parseAndConvert "= stencil forward(depth=1, dim=1) :: x"+ `shouldBe`+ (Right $ Right [(["x"], Specification $+ Multiple $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) - it "parse and convert simple upper bounded stencil (3)" $- (parseAndConvert "= stencil atmost, forward(depth=1, dim=1) :: x")- `shouldBe`- (Right $ Right $ [(["x"], Specification $ Left $- Bound Nothing (Just $ Spatial NonLinear- (Sum [Product [Forward 1 1 True]])))])+ it "parse and convert simple exact stencil (2)" $+ parseAndConvert "= stencil forward(depth=1, dim=1) :: x, y, z"+ `shouldBe`+ (Right $ Right [(["x","y","z"], Specification $+ Multiple $ Exact (Spatial (Sum [Product [Forward 1 1 True]])))]) - it "parse and convert simple lower bounded stencil (4)" $- (parseAndConvert "= stencil atleast, backward(depth=2, dim=1) :: x")- `shouldBe`- (Right $ Right $ [(["x"], Specification $ Left $- Bound (Just $ Spatial NonLinear- (Sum [Product [Backward 2 1 True]])) Nothing)])+ it "parse and convert simple exact stencil with irreflexive (2a)" $+ parseAndConvert "= stencil centered(depth=1, dim=2, irreflexive) :: x, y, z"+ `shouldBe`+ (Right $ Right [(["x","y","z"], Specification $+ Multiple $ Exact (Spatial (Sum [Product [Centered 1 2 False]])))]) -{- This is no longer applicable- it "parse and convert modified bounded stencil (4)" $- (parseAndConvert "= stencil reflexive(dims=1), irreflexive(dims=2), centered(depth=1, dim=3) :: x")- `shouldBe`- (Right $ Right $ [(["x"], Specification $ Left $- Exact (Spatial NonLinear [2] (Sum [Product [Centered 1 3]])))])--}+ it "parse and convert simple upper bounded stencil (3)" $+ parseAndConvert "= stencil atmost, forward(depth=1, dim=1) :: x"+ `shouldBe`+ (Right $ Right [(["x"], Specification $+ Multiple $ Bound Nothing (Just $ Spatial+ (Sum [Product [Forward 1 1 True]])))]) - it "parse and convert stencil requiring distribution (5)" $- (parseAndConvert "= stencil atleast, readonce, (forward(depth=1, dim=1) * ((centered(depth=1, dim=2)) + backward(depth=3, dim=4))) :: frob")- `shouldBe`- (Right $ Right $ [(["frob"], Specification $ Left $- Bound (Just $ Spatial Linear- (Sum [Product [Forward 1 1 True, Centered 1 2 True],- Product [Forward 1 1 True, Backward 3 4 True]])) Nothing)])+ it "parse and convert simple lower bounded stencil (4)" $+ parseAndConvert "= stencil atleast, backward(depth=2, dim=1) :: x"+ `shouldBe`+ (Right $ Right [(["x"], Specification $+ Multiple $ Bound (Just $ Spatial+ (Sum [Product [Backward 2 1 True]])) Nothing)]) - it "parse and convert stencil with irreflexivity on a product(6)" $- let ?dimensionality = 2 in- ((extract $- parseAndConvert "= stencil forward(depth=1, dim=2, irreflexive)*backward(depth=1,dim=1) :: x, y, z")- `eqByModel`- (Specification $ Left $ Exact (Spatial NonLinear- (Sum [Product [Forward 1 2 False, Backward 1 1 True]]))))+ it "parse and convert stencil requiring distribution (5)" $+ parseAndConvert "= stencil atleast, readonce, (forward(depth=1, dim=1) * ((centered(depth=1, dim=2)) + backward(depth=3, dim=4))) :: frob"+ `shouldBe`+ (Right $ Right [(["frob"], Specification $+ Single $ Bound (Just $ Spatial+ (Sum [Product [Forward 1 1 True, Centered 1 2 True],+ Product [Forward 1 1 True, Backward 3 4 True]])) Nothing)])
tests/Camfort/Specification/Stencils/GrammarSpec.hs view
@@ -47,10 +47,15 @@ `shouldBe` Right (RegionDec "r" (Or (Forward 1 1 True) (Backward 2 2 True))) - it "temporal" $- parse "= stencil dependency(a,b,c,foo), mutual :: foo, bar"+ it "region defn syntactic permutation" $+ parse "= region :: r = forward(dim=1,depth=1) + backward(depth=2, dim=2)" `shouldBe`- Right (SpecDec (Temporal ["a","b","c","foo"] True) ["foo", "bar"])+ Right (RegionDec "r" (Or (Forward 1 1 True) (Backward 2 2 True)))++ it "region defn irreflx syntactic permutation" $+ parse "= region :: r = forward(irreflexive,dim=1,depth=1) + backward(depth=2,irreflexive,dim=2)"+ `shouldBe`+ Right (RegionDec "r" (Or (Forward 1 1 False) (Backward 2 2 False))) {- Should no longer be possible it "complex stencil" $
tests/Camfort/Specification/Stencils/ModelSpec.hs view
@@ -16,7 +16,7 @@ import Data.Bits import Data.List-import Data.Map hiding (map)+import Data.Set (toList) import Test.Hspec import Test.QuickCheck@@ -24,41 +24,98 @@ spec :: Spec spec = do+ describe "Consistency of model vs access patterns" $ do+ let singleOneDimSpec = Single $ Exact $ Spatial $ Sum+ [ Product [ Forward 1 1 True ] ]+ it "1D readOnce - positive" $ do+ let acs = Single [[0], [1]]+ consistent acs singleOneDimSpec `shouldBe` True++ it "1D readOnce - negative" $ do+ let acs = Multiple [[0], [1]]+ consistent acs singleOneDimSpec `shouldBe` False++ let reflCentOneDimSpec = Single $ Exact $ Spatial $ Sum+ [ Product [ Centered 1 1 False ] ]+ it "1D centered irreflexive - positive" $ do+ let acs = Single [[-1], [1]]+ consistent acs reflCentOneDimSpec `shouldBe` True++ let centeredAcs = Single [[-1], [0], [1]]+ it "1D centered irreflexive - negative" $+ consistent centeredAcs reflCentOneDimSpec `shouldBe` False++ it "1D centered irreflexive lower bound - positive" $ do+ let spec = Single $ Bound+ (Just $ Spatial $ Sum [ Product [ Centered 1 1 False ] ])+ Nothing+ consistent centeredAcs spec `shouldBe` True++ it "1D centered irreflexive upper bound - negative" $ do+ let spec = Single $ Bound+ Nothing+ (Just $ Spatial $ Sum [ Product [ Centered 1 1 False ] ])+ consistent centeredAcs spec `shouldBe` False++ it "1D double bounded" $ do+ let acs = Single [ [-3], [-2], [-1], [0], [1], [3] ]+ let spec = Single $ Bound+ (Just $ Spatial $ Sum [ Product [ Centered 1 1 True ] ])+ (Just $ Spatial $ Sum [ Product [ Centered 1 3 True ] ])+ consistent acs spec `shouldBe` True++ it "1D spec 3D access" $ do+ let acs = Single [ [0,1,-2], [absoluteRep, 2,3] ]+ let spec = Single $ Exact $+ Spatial $ Sum [ Product [ Forward 2 2 False ] ]+ consistent acs spec `shouldBe` True++ let twoDimSpec = Single $ Exact $+ Spatial $ Sum [ Product [ Centered 0 1 True, Forward 1 2 True ] ]++ it "2 dimensional spec example" $ do+ let acs = Single [ [0,0], [0,1] ]+ consistent acs twoDimSpec `shouldBe` True++ it "Constant access not allowed in otherwise fine access pattern" $ do+ let acs = Single [ [0,0], [0,1], [absoluteRep, absoluteRep] ]+ consistent acs twoDimSpec `shouldBe` False+ describe "Stencils - Model" $ do- describe "Test soundness of model 1" $ modelHasLeftInverse+ describe "Test soundness of model 1" modelHasLeftInverse describe "Test soundness of model 2" $ modelHasApproxLeftInverse variations2 describe "Test soundness of model 3" $ modelHasApproxLeftInverse variations3 describe "Consistency of model with paper" $ do- describe "Quickcheck" $ it "" $ property $ propPairwisePerm+ describe "Quickcheck" $ it "" $ property propPairwisePerm describe "Manual for absolute rep" $ do it "Check absolute rep (0)" $- (sort $ pp [1,2,absoluteRep] [5,1,7])- `shouldBe` (sort $ pairwisePerm [1,2,absoluteRep] [5,1,7])+ sort (pp [1,2,absoluteRep] [5,1,7])+ `shouldBe` sort (pairwisePerm [1,2,absoluteRep] [5,1,7]) it "Check absolute rep (1)" $- (sort $ pp [1,absoluteRep] [5,1])- `shouldBe` (sort $ pairwisePerm [1,absoluteRep] [5,1])+ sort (pp [1,absoluteRep] [5,1])+ `shouldBe` sort (pairwisePerm [1,absoluteRep] [5,1]) it "Check absolute rep (2)" $- (sort $ pp [absoluteRep,2,absoluteRep] [absoluteRep,1,7])- `shouldBe` (sort $ pairwisePerm [absoluteRep,2,absoluteRep] [absoluteRep,1,7])+ sort (pp [absoluteRep,2,absoluteRep] [absoluteRep,1,7])+ `shouldBe` sort (pairwisePerm [absoluteRep,2,absoluteRep] [absoluteRep,1,7]) propPairwisePerm :: [Int] -> [Int] -> Bool-propPairwisePerm x y = if (length x == length y && length x < 16)- then (sort . nub $ pp x y)- == (sort . nub $ pairwisePerm x y)- else True+propPairwisePerm x y =+ if length x == length y && length x < 16+ then (sort . nub $ pp x y) == (sort . nub $ pairwisePerm x y)+ else True pp :: [Int] -> [Int] -> [[Int]] pp x y = let n = length x in map (\i ->- map (\j ->- ((x !! j) `times` (not (testBit i j))- `plus` ((y !! j) `times` testBit i j))+ map (\j -> ((x !! j) `times` not (testBit i j))+ `plus`+ ((y !! j) `times` testBit i j) ) [0..(n-1)] ) [0 :: Int .. ((2^n)-1)] where times x True = x@@ -66,70 +123,89 @@ plus x y = x + y -variations :: [([[Int]], Syn.Result Spatial)]+variations :: [([[Int]], Syn.Multiplicity (Syn.Approximation Spatial))] variations = [ ([ [1], [0] ],- Exact $ Spatial NonLinear (Sum [Product [Forward 1 1 True]]))+ Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True]])) , ([ [absoluteRep,1], [absoluteRep,0] ],- Exact $ Spatial NonLinear (Sum [Product [Forward 1 2 True]]))+ Multiple $ Exact $ Spatial (Sum [Product [Forward 1 2 True]])) , ([ [1,1], [0,1], [1,0], [0,0] ],- Exact $ Spatial NonLinear (Sum [Product [Forward 1 1 True, Forward 1 2 True]]))+ Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 True]])) , ([ [-1, 1], [0, 1] ],- Exact $ Spatial NonLinear (Sum [Product [Backward 1 1 True, Forward 1 2 False]]))+ Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Forward 1 2 False]])) , ([ [-1], [0] ],- Exact $ Spatial NonLinear (Sum [Product [Backward 1 1 True]]))+ Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True]])) , ([ [absoluteRep,-1], [absoluteRep,0] ],- Exact $ Spatial NonLinear (Sum [Product [Backward 1 2 True]]))+ Multiple $ Exact $ Spatial (Sum [Product [Backward 1 2 True]])) , ([ [-1,-1], [0,-1], [-1,0], [0,0] ],- Exact $ Spatial NonLinear (Sum [Product [Backward 1 1 True, Backward 1 2 True]]))+ Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 2 True]])) , ( [ [0,-1], [1,-1], [0,0], [1,0], [1,1], [0,1], [2,-1], [2,0], [2,1] ],- Exact $ Spatial NonLinear+ Multiple $ Exact $ Spatial (Sum [Product [ Forward 2 1 True, Centered 1 2 True ] ] )) , ( [ [-1,0], [-1,1], [0,0], [0,1], [1,1], [1,0], [-1,2], [0,2], [1,2] ],- Exact $ Spatial NonLinear+ Multiple $ Exact $ Spatial (Sum [Product [ Forward 2 2 True, Centered 1 1 True ] ] )) ] -variations2 :: [(Syn.Result [[Int]], Int, Syn.Result Spatial)]+variations2 :: [( Syn.Multiplicity (Syn.Approximation [[Int]])+ , Int+ , Syn.Multiplicity (Syn.Approximation Spatial) )] variations2 = [ -- Stencil which has some absolute component (not represented in the spec)- (Exact [ [0, absoluteRep], [1, absoluteRep] ], 2,- Exact $ Spatial NonLinear (Sum [Product [Forward 1 1 True]]))+ ( Multiple $ Exact [ [0, absoluteRep], [1, absoluteRep] ]+ , 2+ , Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True]])+ ) -- Spec on bounds- , (Bound Nothing (Just $ [ [0, absoluteRep], [1, absoluteRep],- [2, absoluteRep] ]), 2,- Bound Nothing- (Just $ Spatial NonLinear (Sum [Product [Forward 2 1 True]])))- ]+ , ( Multiple $ Bound Nothing (Just [ [0, absoluteRep], [1, absoluteRep]+ , [2, absoluteRep] ])+ , 2+ , Multiple $ Bound Nothing+ (Just $ Spatial (Sum [Product [Forward 2 1 True]]))+ )+ ] -variations3 :: [(Syn.Result [[Int]], Int, Syn.Result Spatial)]+variations3 :: [( Syn.Multiplicity (Syn.Approximation [[Int]])+ , Int+ , Syn.Multiplicity (Syn.Approximation Spatial) )] variations3 = [ -- Spec on bounds- (Bound Nothing (Just $ [ [0, absoluteRep, 0], [1, absoluteRep, 0],- [2, absoluteRep, 0],- [0, absoluteRep, 1], [1, absoluteRep, 1],- [2, absoluteRep, 1]]), 3,- Bound Nothing- (Just $ Spatial NonLinear (Sum [Product [Forward 1 3 True, Forward 2 1 True]])))+ ( Multiple $+ Bound Nothing (Just [ [0, absoluteRep, 0], [1, absoluteRep, 0]+ , [2, absoluteRep, 0], [0, absoluteRep, 1]+ , [1, absoluteRep, 1], [2, absoluteRep, 1]])+ , 3+ , Multiple $+ Bound Nothing (Just $ Spatial (Sum [Product [ Forward 1 3 True+ , Forward 2 1 True ]]))+ ) ] modelHasLeftInverse = mapM_ check (zip variations [0..])- where check ((ixs, spec), n) = it ("("++show n++")") $ sort mdl `shouldBe` sort ixs- where mdl = map fst . toList . fromExact . model $ spec+ where+ check ((ixs, spec), n) =+ it ("("++show n++")") $+ sort mdl `shouldBe` sort ixs+ where+ mdl = toList . fromExact . fromMult . model' $ spec+ model' = flip model $ length . head $ ixs modelHasApproxLeftInverse vars = mapM_ check (zip vars [(0 :: Int)..])- where check ((ixs, dims, spec), n) =- it ("("++show n++")") $ mdl' `shouldBe` (fmap sort ixs)- where mdl = let ?globalDimensionality = dims in mkModel spec- mdl' = fmap (sort . map fst . toList) mdl+ where+ check ((ixs, dims, spec), n) =+ it ("("++show n++")") $ mdl `shouldBe` fmap sort <$> ixs+ where+ mdl =+ let ?globalDimensionality = dims+ in fmap (sort . toList) <$> mkModel spec
+ tests/Camfort/Specification/Stencils/example2.f view
@@ -0,0 +1,45 @@+ program example2+ implicit none++ integer i, j, imax, jmax+ parameter (imax = 3, jmax = 3)+ real a(0:imax,0:jmax), b(0:imax,0:jmax), c, x++c= region :: r1 = centered(depth=1, dim=1)++c some kind of setup+ do 1 i = 0, imax+ do 2 j = 0, jmax+ a(i,j) = i+j+ 2 continue+ 1 continue++c compute mean+ do 3 i = 1, (imax-1)+ do 4 j = 1, (jmax-1)+ if (.true.) then+c= region :: r2 = centered(depth=1, dim=2)+ x = a(i-1,j) + a(i,j) + a(i+1,j) + abs(0)+c= stencil readOnce, (reflexive(dim=1))*r2 + (reflexive(dim=2))*r1 :: a + b(i,j) = (x + a(i,j-1) + a(i,j+1)) / 5.0+c No specification should be inferred here+ b(0,0) = a(i, j)+ end if+ 4 continue+ x = a(i,0)+ y = a(i-1,0)+c= stencil readOnce, backward(depth=1, dim=1) :: a + b(i,0) = (x + y)/2.0+ 3 continue++ b(i,j) = a(i,j)++ do i=1, imax+ do j=1, jmx+ x = a(1,j+1) + a(1,j-1)+ a(i,j) = a(i,1) + a(i+1 ,1) + a(i-1,1) + a(1,j) + x+ a(i,j) = a(i,j) + a(1,1)+ end do+ end do++ end
+ tests/Camfort/Specification/Stencils/example3.f view
@@ -0,0 +1,31 @@+ program example3+ implicit none++ integer i, x, y, imax, xmax, ymax+ parameter (imax = 3, jmax = 3)++ real a(0:imax,0:jmax), b(0:imax,0:jmax), c(0:imax), d(0:imax), acc++ do i=1,imax+ do x=1,xmax+ do y=1,ymax+ acc = acc + a(x,y,i)+ end do+ end do+ 1 b(1,i) = acc+ end do++ do i=1,imax+c Label 1 should get same spec as this line+ b(1,i) = a(:,:,i)+ end do++ c(:) = d(:)+ c(:) = a(0,:)++c No spec here+ do i=1,imax+ c(i) = d(:)+ end do++ end
+ tests/Camfort/Specification/Stencils/example4.f view
@@ -0,0 +1,8 @@+ program example4+ logical BAR = .true.+ integer X(0:5)+ integer J+ do J=1, 10+ IF (BAR) X(J) = X(J)+1+ end do+ end
tests/Camfort/Specification/StencilsSpec.hs view
@@ -12,6 +12,7 @@ import Camfort.Functionality import Camfort.Helpers.Vec+import Camfort.Input import Camfort.Specification.Stencils import Camfort.Specification.Stencils.Synthesis import Camfort.Specification.Stencils.Model@@ -93,7 +94,7 @@ shouldBe (composeConsecutiveSpans (Cons 1 (Cons 0 Nil), Cons 1 (Cons 0 Nil)) (Cons 2 (Cons 0 Nil), Cons 2 (Cons 0 Nil)))- ([(Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil))])+ [(Cons 1 (Cons 0 Nil), Cons 2 (Cons 0 Nil))] it "composeRegions failing on (1,0)-(2,0) span and (4,0)-(5,0) span" $ shouldBe (composeConsecutiveSpans@@ -123,35 +124,36 @@ describe "Example stencil inferences" $ do it "five point stencil 2D" $- (inferFromIndices $ VL fivepoint)+ inferFromIndices (VL fivepoint) `shouldBe`- (exactSp $ Spatial Linear+ (Specification $ Single $ Exact $ Spatial (Sum [ Product [ Centered 0 1 True, Centered 1 2 True] , Product [ Centered 0 2 True, Centered 1 1 True] ])) it "seven point stencil 2D" $- (inferFromIndices $ VL sevenpoint)+ inferFromIndices (VL sevenpoint) `shouldBe`- (exactSp $ Spatial Linear+ (Specification $ Single $ Exact $ Spatial (Sum [ Product [ Centered 0 1 True, Centered 0 2 True, Centered 1 3 True] , Product [ Centered 0 1 True, Centered 0 3 True, Centered 1 2 True] , Product [ Centered 0 2 True, Centered 0 3 True, Centered 1 1 True] ])) it "five point stencil 2D with blip" $- (inferFromIndices $ VL fivepointErr)+ inferFromIndices (VL fivepointErr) `shouldBe`- (exactSp $ Spatial Linear+ (Specification $ Single $ Exact $ Spatial (Sum [ Product [ Forward 1 1 True, Forward 1 2 True], Product [ Centered 0 1 True, Centered 1 2 True], Product [ Centered 0 2 True, Centered 1 1 True] ])) it "centered forward" $- (inferFromIndices $ VL centeredFwd)+ inferFromIndices (VL centeredFwd) `shouldBe`- (exactSp $ Spatial Linear (Sum [ Product [ Forward 1 1 True- , Centered 1 2 True] ]))+ (Specification $ Single $ Exact $ Spatial+ (Sum [ Product [ Forward 1 1 True+ , Centered 1 2 True] ])) describe "2D stencil verification" $ mapM_ (test2DSpecVariation (Neighbour "i" 0) (Neighbour "j" 0)) variations@@ -167,77 +169,77 @@ "extracting offsets from indexing expressions; and vice versa") $ it "isomorphism" $ property prop_extract_synth_inverse - describe ("Inconsistent induction variable usage tests") $ do+ describe "Inconsistent induction variable usage tests" $ do it "consistent (1) a(i,j) = b(i+1,j+1) + b(i,j)" $- (indicesToSpec' ["i", "j"]- [Neighbour "i" 0, Neighbour "j" 0]- [[offsetToIx "i" 1, offsetToIx "j" 1],- [offsetToIx "i" 0, offsetToIx "j" 0]])- `shouldBe` (Just $ Specification $ Left $ Exact- (Spatial Linear+ indicesToSpec' ["i", "j"]+ [Neighbour "i" 0, Neighbour "j" 0]+ [[offsetToIx "i" 1, offsetToIx "j" 1],+ [offsetToIx "i" 0, offsetToIx "j" 0]]+ `shouldBe` (Just $ Specification $ Single $ Exact+ (Spatial (Sum [Product [Forward 1 1 False, Forward 1 2 False], Product [Centered 0 1 True, Centered 0 2 True]]))) it "consistent (2) a(i,c,j) = b(i,j+1) + b(i,j) \ \:: forward(depth=1,dim=2)*reflexive(dim=1)" $- (indicesToSpec' ["i", "j"]+ indicesToSpec' ["i", "j"] [Neighbour "i" 0, Constant (F.ValInteger "0"), Neighbour "j" 0] [[offsetToIx "i" 0, offsetToIx "j" 1],- [offsetToIx "i" 0, offsetToIx "j" 0]])- `shouldBe` (Just $ Specification $ Left $ Exact- (Spatial Linear+ [offsetToIx "i" 0, offsetToIx "j" 0]]+ `shouldBe` (Just $ Specification $ Single $ Exact+ (Spatial (Sum [Product [Forward 1 2 True, Centered 0 1 True]]))) it "consistent (3) a(i+1,c,j) = b(j,i+1) + b(j,i) \ \:: backward(depth=1,dim=2)*reflexive(dim=1)" $- (indicesToSpec' ["i", "j"]+ indicesToSpec' ["i", "j"] [Neighbour "i" 1, Constant (F.ValInteger "0"), Neighbour "j" 0] [[offsetToIx "j" 0, offsetToIx "i" 1],- [offsetToIx "j" 0, offsetToIx "i" 0]])- `shouldBe` (Just $ Specification $ Left $ Exact- (Spatial Linear+ [offsetToIx "j" 0, offsetToIx "i" 0]]+ `shouldBe` (Just $ Specification $ Single $ Exact+ (Spatial (Sum [Product [Backward 1 2 True, Centered 0 1 True]]))) it "consistent (4) a(i+1,j) = b(0,i+1) + b(0,i) \ \:: backward(depth=1,dim=2)" $- (indicesToSpec' ["i", "j"]+ indicesToSpec' ["i", "j"] [Neighbour "i" 1, Neighbour "j" 0] [[offsetToIx "j" absoluteRep, offsetToIx "i" 1],- [offsetToIx "j" absoluteRep, offsetToIx "i" 0]])- `shouldBe` (Just $ Specification $ Left $ Exact- (Spatial Linear+ [offsetToIx "j" absoluteRep, offsetToIx "i" 0]]+ `shouldBe` (Just $ Specification $ Single $ Exact+ (Spatial (Sum [Product [Backward 1 2 True]]))) it "consistent (5) a(i) = b(i,i+1) \ \:: reflexive(dim=1)*forward(depth=1,dim=2,irreflexive)" $- (indicesToSpec' ["i", "j"]+ indicesToSpec' ["i", "j"] [Neighbour "i" 0]- [[offsetToIx "i" 0, offsetToIx "i" 1]])- `shouldBe` (Just $ Specification $ Left $ Exact- (Spatial Linear+ [[offsetToIx "i" 0, offsetToIx "i" 1]]+ `shouldBe` (Just $ Specification $ Single $ Exact+ (Spatial (Sum [Product [Forward 1 2 False, Centered 0 1 True]]))) it "consistent (6) a(i) = b(i) + b(0) \ \:: reflexive(dim=1)" $- (indicesToSpec' ["i", "j"]+ indicesToSpec' ["i", "j"] [Neighbour "i" 0]- [[offsetToIx "i" 0], [offsetToIx "i" absoluteRep]])- `shouldBe` (Just $ Specification $ Left $ Exact- (Spatial Linear+ [[offsetToIx "i" 0], [offsetToIx "i" absoluteRep]]+ `shouldBe` (Just $ Specification $ Single $ Exact+ (Spatial (Sum [Product [Centered 0 1 True]]))) it "inconsistent (1) RHS" $- (indicesToSpec' ["i", "j"]+ indicesToSpec' ["i", "j"] [Neighbour "i" 0, Neighbour "j" 0] [[offsetToIx "i" 1, offsetToIx "j" 1],- [offsetToIx "j" 0, offsetToIx "i" 0]])+ [offsetToIx "j" 0, offsetToIx "i" 0]] `shouldBe` Nothing it "inconsistent (2) RHS to LHS" $- (indicesToSpec' ["i", "j"]+ indicesToSpec' ["i", "j"] [Neighbour "i" 0] [[offsetToIx "i" 1, offsetToIx "j" 1],- [offsetToIx "j" 0, offsetToIx "i" 0]])+ [offsetToIx "j" 0, offsetToIx "i" 0]] `shouldBe` Nothing -------------------------@@ -245,52 +247,40 @@ ------------------------- let file = "tests/Camfort/Specification/Stencils/example2.f"- program <- runIO $ readForparseSrcDir file []+ program <- runIO $ readParseSrcDir file [] describe "integration test on inference for example2.f" $ do it "stencil infer" $- (fst $ callAndSummarise (infer AssignMode) program)+ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` "\ntests/Camfort/Specification/Stencils/example2.f\n\- \((24,8),(24,53)) \tstencil readOnce, (reflexive(dim=1))*(centered(depth=1, dim=2)) \+ \(24:8)-(24:53) \tstencil readOnce, (reflexive(dim=1))*(centered(depth=1, dim=2)) \ \+ (reflexive(dim=2))*(centered(depth=1, dim=1)) :: a\n\- \((32,7),(32,26)) \tstencil readOnce, (backward(depth=1, dim=1)) :: a\n\- \((40,8),(40,62)) \tstencil readOnce, (centered(depth=1, dim=1)) \+ \(32:7)-(32:26) \tstencil readOnce, (backward(depth=1, dim=1)) :: a\n\+ \(40:8)-(40:62) \tstencil readOnce, (centered(depth=1, dim=1)) \ \+ (centered(depth=1, dim=2)) :: a\n\- \((41,8),(41,35)) \tstencil readOnce, (reflexive(dim=1))*(reflexive(dim=2)) :: a"+ \(41:8)-(41:35) \tstencil readOnce, (reflexive(dim=1))*(reflexive(dim=2)) :: a" it "stencil check" $- (fst $ callAndSummarise (\f p -> (check f p, p)) program)+ fst (callAndSummarise (\f p -> (check f p, p)) program) `shouldBe` "\ntests/Camfort/Specification/Stencils/example2.f\n\- \(24:8,24:53)\tCorrect.\n(32:7,32:26)\tCorrect."+ \(23:1)-(23:86)\tCorrect.\n(31:1)-(31:56)\tCorrect." let file = "tests/Camfort/Specification/Stencils/example3.f"- program <- runIO $ readForparseSrcDir file []-- -- describe "integration test on inference for example3.f" $ do- -- it "stencil infer" $- -- (fst $ callAndSummarise (infer AssignMode) program)- -- `shouldBe`- -- "\ntests/Camfort/Specification/Stencils/example3.f\n\- -- \((15,2),(15,20)) \tstencil readOnce, (reflexive(dim=3)) :: a\n\- -- \((20,8),(20,26)) \tstencil readOnce, (reflexive(dim=3)) :: a\n\- -- \((23,7),(23,17)) \tstencil readOnce, (reflexive(dim=1)) :: d\n\- -- \((24,7),(24,19)) \tstencil readOnce, (reflexive(dim=2)) :: a\n"+ program <- runIO $ readParseSrcDir file [] let file = "tests/Camfort/Specification/Stencils/example4.f"- program <- runIO $ readForparseSrcDir file []+ program <- runIO $ readParseSrcDir file [] - describe "integration test on inference for example4.f" $ do+ describe "integration test on inference for example4.f" $ it "stencil infer" $- (fst $ callAndSummarise (infer AssignMode) program)+ fst (callAndSummarise (infer AssignMode '=') program) `shouldBe` "\ntests/Camfort/Specification/Stencils/example4.f\n\- \((6,8),(6,33)) \tstencil (reflexive(dim=1)) :: x"+ \(6:8)-(6:33) \tstencil (reflexive(dim=1)) :: x" -exactSp = Specification . Left . Exact- {- Properties of `spanBoundingBox`: idempotent and associative -} prop_spanBoundingIdem :: Natural n -> Span (Vec n Int) -> Bool prop_spanBoundingIdem w x = spanBoundingBox x x == normaliseSpan x@@ -348,109 +338,107 @@ return $ Cons x xs test2DSpecVariation a b (input, expectation) =- it ("format=" ++ show input) $ do-+ it ("format=" ++ show input) $ -- Test inference- (indicesToSpec' ["i", "j"]- [a, b]- (map fromFormatToIx input))+ indicesToSpec' ["i", "j"] [a, b] (map fromFormatToIx input) `shouldBe` Just expectedSpec where- expectedSpec = Specification . Left $ expectation+ expectedSpec = Specification expectation fromFormatToIx [ri,rj] = [ offsetToIx "i" ri, offsetToIx "j" rj ] -indicesToSpec' ivs lhs = fst . runWriter . (indicesToSpec ivmap "a" lhs)+indicesToSpec' ivs lhs = fst . runWriter . indicesToSpec ivmap "a" lhs where ivmap = IM.singleton 0 (S.fromList ivs) variations = [ ( [ [0,0] ]- , Exact $ Spatial Linear (Sum [Product [ Centered 0 1 True, Centered 0 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [ Centered 0 1 True, Centered 0 2 True]]) ) , ( [ [1,0] ]- , Exact $ Spatial Linear (Sum [Product [Forward 1 1 False, Centered 0 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 False, Centered 0 2 True]]) ) , ( [ [1,0], [0,0], [0,0] ]- , Exact $ Spatial NonLinear (Sum [Product [Forward 1 1 True, Centered 0 2 True]])+ , Multiple $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Centered 0 2 True]]) ) , ( [ [0,1], [0,0] ]- , Exact $ Spatial Linear (Sum [Product [Forward 1 2 True, Centered 0 1 True]])+ , Single $ Exact $ Spatial (Sum [Product [Forward 1 2 True, Centered 0 1 True]]) ) , ( [ [1,1], [0,1], [1,0], [0,0] ]- , Exact $ Spatial Linear (Sum [Product [Forward 1 1 True, Forward 1 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 True]]) ) , ( [ [-1,0], [0,0] ]- , Exact $ Spatial Linear (Sum [Product [Backward 1 1 True, Centered 0 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Centered 0 2 True]]) ) , ( [ [0,-1], [0,0], [0,-1] ]- , Exact $ Spatial NonLinear (Sum [Product [Backward 1 2 True, Centered 0 1 True]])+ , Multiple $ Exact $ Spatial (Sum [Product [Backward 1 2 True, Centered 0 1 True]]) ) , ( [ [-1,-1], [0,-1], [-1,0], [0,0], [0, -1] ]- , Exact $ Spatial NonLinear (Sum [Product [Backward 1 1 True, Backward 1 2 True]])+ , Multiple $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 2 True]]) ) , ( [ [0,-1], [1,-1], [0,0], [1,0], [1,1], [0,1] ]- , Exact $ Spatial Linear $ Sum [ Product [ Forward 1 1 True, Centered 1 2 True] ]+ , Single $ Exact $ Spatial $ Sum [ Product [ Forward 1 1 True, Centered 1 2 True] ] ) -- Stencil which is non-contiguous in one direction , ( [ [0, 4], [1, 4] ]- , Bound (Just (Spatial Linear (Sum [Product [Forward 1 1 True]])))- (Just (Spatial Linear (Sum [Product [Forward 1 1 True, Forward 4 2 True]])))+ , Single $ Bound (Just (Spatial (Sum [ Product [ Forward 1 1 True ] ])))+ (Just (Spatial (Sum [ Product [ Forward 1 1 True+ , Forward 4 2 True ] ]))) ) ] variationsRel = [ -- Stencil which has non-relative indices in one dimension (Neighbour "i" 0, Constant (F.ValInteger "0"), [ [0, absoluteRep], [1, absoluteRep] ]- , Exact $ Spatial Linear (Sum [Product [Forward 1 1 True]])+ , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 True]]) ) , (Neighbour "i" 1, Neighbour "j" 0, [ [0,0] ]- , Exact $ Spatial Linear (Sum [Product [ Backward 1 1 False, Centered 0 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [ Backward 1 1 False, Centered 0 2 True]]) ) , (Neighbour "i" 0, Neighbour "j" 1, [ [0,1] ]- , Exact $ Spatial Linear (Sum [Product [Centered 0 1 True, Centered 0 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 0 2 True]]) ) , (Neighbour "i" 1, Neighbour "j" (-1), [ [1,0], [0,0], [0,0] ]- , Exact $ Spatial NonLinear (Sum [Product [Forward 1 2 False, Backward 1 1 True]])+ , Multiple $ Exact $ Spatial (Sum [Product [Forward 1 2 False, Backward 1 1 True]]) ) , (Neighbour "i" 0, Neighbour "j" (-1), [ [0,1], [0,0] ]- , Exact $ Spatial Linear (Sum [Product [Forward 2 2 False, Centered 0 1 True]])+ , Single $ Exact $ Spatial (Sum [Product [Forward 2 2 False, Centered 0 1 True]]) ) -- [0,1] [0,0] [0,-1] , (Neighbour "i" 1, Neighbour "j" 0, [ [1,1], [1,0], [1,-1] ]- , Exact $ Spatial Linear (Sum [Product [Centered 0 1 True, Centered 1 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [Centered 0 1 True, Centered 1 2 True]]) ) , (Neighbour "i" 1, Neighbour "j" 0, [ [-2,0], [-1,0] ]- , Bound (Just (Spatial Linear (Sum [Product [Centered 0 2 True]])))- (Just (Spatial Linear (Sum [Product [Backward 3 1 True, Centered 0 2 True]]))))+ , Single $ Bound (Just (Spatial (Sum [Product [ Centered 0 2 True ]])))+ (Just (Spatial (Sum [Product [ Backward 3 1 True+ , Centered 0 2 True ]])))) , (Constant (F.ValInteger "0"), Neighbour "j" 0, [ [absoluteRep,1], [absoluteRep,0], [absoluteRep,-1] ]- , Exact $ Spatial Linear (Sum [Product [Centered 1 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [Centered 1 2 True]]) ) ] test3DSpecVariation (input, expectation) =- it ("format=" ++ show input) $ do-+ it ("format=" ++ show input) $ -- Test inference- (indicesToSpec' ["i", "j", "k"]- [Neighbour "i" 0, Neighbour "j" 0, Neighbour "k" 0]- (map fromFormatToIx input))+ indicesToSpec' ["i", "j", "k"]+ [Neighbour "i" 0, Neighbour "j" 0, Neighbour "k" 0]+ (map fromFormatToIx input) `shouldBe` Just expectedSpec where- expectedSpec = Specification . Left $ expectation+ expectedSpec = Specification expectation fromFormatToIx [ri,rj,rk] = [offsetToIx "i" ri, offsetToIx "j" rj, offsetToIx "k" rk] variations3D = [ ( [ [-1,0,-1], [0,0,-1], [-1,0,0], [0,0,0] ]- , Exact $ Spatial Linear (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]]) ) , ( [ [1,1,0], [0,1,0] ]- , Exact $ Spatial Linear (Sum [Product [Forward 1 1 True, Forward 1 2 False, Centered 0 3 True]])+ , Single $ Exact $ Spatial (Sum [Product [Forward 1 1 True, Forward 1 2 False, Centered 0 3 True]]) ) , ( [ [-1,0,-1], [0,0,-1], [-1,0,0], [0,0,0] ]- , Exact $ Spatial Linear (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]])+ , Single $ Exact $ Spatial (Sum [Product [Backward 1 1 True, Backward 1 3 True, Centered 0 2 True]]) ) ]
+ tests/Camfort/Specification/Units/ex1.f90 view
@@ -0,0 +1,29 @@+program energy+ != unit :: speed = m/s++ != unit (m / s** (2)) :: gravity+ != unit (m) :: height+ != unit (kg) :: mass+ real, parameter :: mass = 3.00, gravity = 9.81, height = 4.20+ != unit (kg m** (2) / s** (2)) :: potential_energy+ real :: potential_energy++ != unit (1) :: half+ != unit (speed) :: velocity+ real, parameter :: half = 0.5, velocity = 4.00+ != unit (kg m** (2) / s** (2)) :: kinetic_energy+ != unit (kg m** (2) / s** (2)) :: total_energy+ real :: kinetic_energy, total_energy++ potential_energy = mass * gravity * height+ kinetic_energy = half * mass * square(velocity)++ total_energy = potential_energy + kinetic_energy++ contains++ real function square(x)+ real x+ square = x * x+ end function square+end program energy
+ tests/Camfort/Specification/Units/ex2.f90 view
@@ -0,0 +1,11 @@+program energy++ != unit (m) :: height+ != unit (kg) :: mass+ real, parameter :: mass = 3.00, gravity = .81, height = 4.20++ != unit (kg m** (2) / s** (2)) :: potential_energy+ real :: potential_energy+ + potential_energy = mass * gravity * height+end program energy
+ tests/Camfort/Specification/Units/ex3.f90 view
@@ -0,0 +1,14 @@+program energy++ != unit (m) :: height+ != unit (kg) :: mass+ real, parameter :: mass = 3.00, gravity = .81, height = 4.20++ integer :: i = 0+ integer :: j = i+ + != unit (kg m**2 / s**2) :: potential_energy+ real :: potential_energy+ + potential_energy = mass * gravity * height+end program energy
+ tests/Camfort/Specification/Units/param.f90 view
@@ -0,0 +1,10 @@+ program param+ implicit none+ != unit(m) :: x, y+ real, parameter :: x = 4, y = 5+ != unit(s) :: t+ real, parameter :: t = 2+ real :: v1, v2+ v1 = x / t+ v2 = y / t+ end program
tests/Camfort/Specification/UnitsSpec.hs view
@@ -3,16 +3,24 @@ import qualified Data.ByteString.Char8 as B +import Language.Fortran.Parser.Any+import qualified Language.Fortran.Analysis as FA+import qualified Language.Fortran.Analysis.Renaming as FAR import Camfort.Input import Camfort.Functionality import Camfort.Output+import Camfort.Analysis.Annotations import Camfort.Specification.Units+import Camfort.Specification.Units.Monad+import Camfort.Specification.Units.InferenceFrontend import Camfort.Specification.Units.InferenceBackend import Camfort.Specification.Units.Environment import Data.List import Data.Maybe+import Data.Either import qualified Data.Array as A import qualified Numeric.LinearAlgebra as H+import qualified Data.Map.Strict as M import Numeric.LinearAlgebra ( atIndex, (<>), (><), rank, (?), toLists, toList, fromLists, fromList, rows, cols, takeRows, takeColumns, dropRows, dropColumns, subMatrix, diag, build, fromBlocks,@@ -23,8 +31,56 @@ import Test.QuickCheck import Test.Hspec.QuickCheck +runFrontendInit litMode pf = usConstraints state+ where+ pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf+ uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode }+ (_, state, logs) = runUnitSolver uOpts pf' initInference++runUnits litMode pf m = (r, usConstraints state)+ where+ pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf+ uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = False, uoLiterals = litMode }+ (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m++runUnits' litMode pf m = (state, logs)+ where+ pf' = FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf+ uOpts = unitOpts0 { uoNameMap = M.empty, uoDebug = True, uoLiterals = litMode }+ (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m++runUnitsRenamed' litMode pf m = (state, logs)+ where+ pf' = FAR.analyseRenames . FA.initAnalysis . fmap mkUnitAnnotation . fmap (const unitAnnotation) $ pf+ uOpts = unitOpts0 { uoNameMap = FAR.extractNameMap pf', uoDebug = True, uoLiterals = litMode }+ (r, state, logs) = runUnitSolver uOpts pf' $ initInference >> m+ spec :: Spec spec = do+ describe "Unit Inference Frontend" $ do+ describe "Literal Mode" $ do+ it "litTest1 Mixed" $ do+ head (fromJust (head (rights [fst (runUnits LitMixed litTest1 runInconsistentConstraints)]))) `shouldSatisfy`+ conParamEq (ConEq (UnitName "a") (UnitMul (UnitName "a") (UnitVar ("j", "j"))))+ it "litTest1 Poly" $ do+ head (fromJust (head (rights [fst (runUnits LitPoly litTest1 runInconsistentConstraints)]))) `shouldSatisfy`+ conParamEq (ConEq (UnitName "a") (UnitMul (UnitName "a") (UnitVar ("j", "j"))))+ it "litTest1 Unitless" $ do+ head (fromJust (head (rights [fst (runUnits LitUnitless litTest1 runInconsistentConstraints)]))) `shouldSatisfy`+ conParamEq (ConEq (UnitName "a") (UnitVar ("k", "k")))+ describe "Polymorphic functions" $ do+ it "squarePoly1" $ do+ show (sort (head (rights [fst (runUnits LitMixed squarePoly1 runInferVariables)]))) `shouldBe`+ show (sort [(("a", "a"),UnitName "m"),(("b", "b"), UnitName "s"),(("x", "x"),UnitPow (UnitName "m") 2.0),(("y", "y"),UnitPow (UnitName "s") 2.0)])+ describe "Recursive functions" $ do+ it "Recursive Addition is OK" $ do+ show (sort (head (rights [fst (runUnits LitMixed recursive1 runInferVariables)]))) `shouldBe`+ show (sort [(("y", "y"),UnitName "m"),(("z", "z"), UnitName "m")])+ describe "Recursive functions" $ do+ it "Recursive Multiplication is not OK" $ do+ head (fromJust (head (rights [fst (runUnits LitMixed recursive2 runInconsistentConstraints)]))) `shouldSatisfy`+ conParamEq (ConEq (UnitParamPosAbs ("recur", 0)) (UnitParamPosAbs ("recur", 2)))+ describe "Unit Inference Backend" $ do describe "Flatten constraints" $ do it "testCons1" $ do@@ -47,9 +103,9 @@ it "testCons2" $ do criticalVariables testCons2 `shouldSatisfy` null it "testCons3" $ do- criticalVariables testCons3 `shouldBe` [UnitVar "c",UnitVar "e"]+ criticalVariables testCons3 `shouldBe` [UnitVar ("c", "c"), UnitVar ("e", "e")] it "testCons4" $ do- criticalVariables testCons4 `shouldBe` [UnitVar "simple2_a22"]+ criticalVariables testCons4 `shouldBe` [UnitVar ("simple2_a22", "simple2_a22")] it "testCons5" $ do criticalVariables testCons5 `shouldSatisfy` null describe "Infer Variables" $ do@@ -59,16 +115,16 @@ -------------------------------------------------- testCons1 = [ ConEq (UnitName "kg") (UnitName "m")- , ConEq (UnitVar "x") (UnitName "m")- , ConEq (UnitVar "y") (UnitName "kg")]+ , ConEq (UnitVar ("x", "x")) (UnitName "m")+ , ConEq (UnitVar ("y", "y")) (UnitName "kg")] testCons1_flattened = [([UnitPow (UnitName "kg") 1.0],[UnitPow (UnitName "m") 1.0])- ,([UnitPow (UnitVar "x") 1.0],[UnitPow (UnitName "m") 1.0])- ,([UnitPow (UnitVar "y") 1.0],[UnitPow (UnitName "kg") 1.0])]+ ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0])+ ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])] testCons1_shifted = [([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "kg") (-1.0)])- ,([UnitPow (UnitVar "x") 1.0],[UnitPow (UnitName "m") 1.0])- ,([UnitPow (UnitVar "y") 1.0],[UnitPow (UnitName "kg") 1.0])]+ ,([UnitPow (UnitVar ("x", "x")) 1.0],[UnitPow (UnitName "m") 1.0])+ ,([UnitPow (UnitVar ("y", "y")) 1.0],[UnitPow (UnitName "kg") 1.0])] -------------------------------------------------- @@ -76,11 +132,11 @@ ,ConEq (UnitName "m") (UnitMul (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0))) (UnitName "s")) ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) (-1.0))) ,ConEq (UnitName "s") (UnitParamPosUse ("simple1_sqr6",1,0))- ,ConEq (UnitVar "simple1_a5") (UnitAlias "accel")- ,ConEq (UnitVar "simple1_t4") (UnitName "s")- ,ConEq (UnitVar "simple1_v3") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0)))- ,ConEq (UnitVar "simple1_x1") (UnitName "m")- ,ConEq (UnitVar "simple1_y2") (UnitName "m")+ ,ConEq (UnitVar ("simple1_a5", "simple1_a5")) (UnitAlias "accel")+ ,ConEq (UnitVar ("simple1_t4", "simple1_t4")) (UnitName "s")+ ,ConEq (UnitVar ("simple1_v3", "simple1_v3")) (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-1.0)))+ ,ConEq (UnitVar ("simple1_x1", "simple1_x1")) (UnitName "m")+ ,ConEq (UnitVar ("simple1_y2", "simple1_y2")) (UnitName "m") ,ConEq (UnitParamPosUse ("simple1_sqr6",0,0)) (UnitParamPosUse ("simple1_mul7",0,1)) ,ConEq (UnitParamPosUse ("simple1_sqr6",1,0)) (UnitParamPosUse ("simple1_mul7",1,1)) ,ConEq (UnitParamPosUse ("simple1_sqr6",1,0)) (UnitParamPosUse ("simple1_mul7",2,1))@@ -91,37 +147,107 @@ ,([],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "m") (-1.0)]) ,([UnitPow (UnitAlias "accel") 1.0,UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) 1.0],[UnitPow (UnitName "m") 1.0]) ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) (-1.0)],[UnitPow (UnitName "s") (-1.0)])- ,([UnitPow (UnitVar "simple1_a5") 1.0,UnitPow (UnitAlias "accel") (-1.0)],[])- ,([UnitPow (UnitVar "simple1_t4") 1.0],[UnitPow (UnitName "s") 1.0])- ,([UnitPow (UnitVar "simple1_v3") 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0)])- ,([UnitPow (UnitVar "simple1_x1") 1.0],[UnitPow (UnitName "m") 1.0])- ,([UnitPow (UnitVar "simple1_y2") 1.0],[UnitPow (UnitName "m") 1.0])+ ,([UnitPow (UnitVar ("simple1_a5", "simple1_a5")) 1.0,UnitPow (UnitAlias "accel") (-1.0)],[])+ ,([UnitPow (UnitVar ("simple1_t4", "simple1_t4")) 1.0],[UnitPow (UnitName "s") 1.0])+ ,([UnitPow (UnitVar ("simple1_v3", "simple1_v3")) 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-1.0)])+ ,([UnitPow (UnitVar ("simple1_x1", "simple1_x1")) 1.0],[UnitPow (UnitName "m") 1.0])+ ,([UnitPow (UnitVar ("simple1_y2", "simple1_y2")) 1.0],[UnitPow (UnitName "m") 1.0]) ,([UnitPow (UnitParamPosUse ("simple1_sqr6",0,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",0,1)) (-1.0)],[]) ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",1,1)) (-1.0)],[]) ,([UnitPow (UnitParamPosUse ("simple1_sqr6",1,0)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",2,1)) (-1.0)],[]) ,([UnitPow (UnitParamPosUse ("simple1_mul7",0,1)) 1.0,UnitPow (UnitParamPosUse ("simple1_mul7",1,1)) (-1.0),UnitPow (UnitParamPosUse ("simple1_mul7",2,1)) (-1.0)],[]) ,([UnitPow (UnitAlias "accel") 1.0],[UnitPow (UnitName "m") 1.0,UnitPow (UnitName "s") (-2.0)])] -testCons3 = [ ConEq (UnitVar "a") (UnitVar "e")- , ConEq (UnitVar "a") (UnitMul (UnitVar "b") (UnitMul (UnitVar "c") (UnitVar "d")))- , ConEq (UnitVar "d") (UnitName "m") ]+testCons3 = [ ConEq (UnitVar ("a", "a")) (UnitVar ("e", "e"))+ , ConEq (UnitVar ("a", "a")) (UnitMul (UnitVar ("b", "b")) (UnitMul (UnitVar ("c", "c")) (UnitVar ("d", "d"))))+ , ConEq (UnitVar ("d", "d")) (UnitName "m") ] -testCons3_shifted = [([UnitPow (UnitVar "a") 1.0,UnitPow (UnitVar "e") (-1.0)],[])- ,([UnitPow (UnitVar "a") 1.0,UnitPow (UnitVar "b") (-1.0),UnitPow (UnitVar "c") (-1.0),UnitPow (UnitVar "d") (-1.0)],[])- ,([UnitPow (UnitVar "d") 1.0],[UnitPow (UnitName "m") 1.0])]+testCons3_shifted = [([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("e", "e")) (-1.0)],[])+ ,([UnitPow (UnitVar ("a", "a")) 1.0,UnitPow (UnitVar ("b", "b")) (-1.0),UnitPow (UnitVar ("c", "c")) (-1.0),UnitPow (UnitVar ("d", "d")) (-1.0)],[])+ ,([UnitPow (UnitVar ("d", "d")) 1.0],[UnitPow (UnitName "m") 1.0])] -testCons4 = [ConEq (UnitVar "simple2_a11") (UnitParamPosUse ("simple2_sqr3",0,0))- ,ConEq (UnitVar "simple2_a22") (UnitParamPosUse ("simple2_sqr3",1,0))- ,ConEq (UnitVar "simple2_a11") (UnitVar "simple2_a11")- ,ConEq (UnitVar "simple2_a22") (UnitVar "simple2_a22")+testCons4 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse ("simple2_sqr3",0,0))+ ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitParamPosUse ("simple2_sqr3",1,0))+ ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11"))+ ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitVar ("simple2_a22", "simple2_a22")) ,ConEq (UnitParamPosUse ("simple2_sqr3",0,0)) (UnitMul (UnitParamPosUse ("simple2_sqr3",1,0)) (UnitParamPosUse ("simple2_sqr3",1,0)))] -testCons5 = [ConEq (UnitVar "simple2_a11") (UnitParamPosUse ("simple2_sqr3",0,0))+testCons5 = [ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitParamPosUse ("simple2_sqr3",0,0)) ,ConEq (UnitAlias "accel") (UnitParamPosUse ("simple2_sqr3",1,0))- ,ConEq (UnitVar "simple2_a11") (UnitVar "simple2_a11")- ,ConEq (UnitVar "simple2_a22") (UnitAlias "accel")+ ,ConEq (UnitVar ("simple2_a11", "simple2_a11")) (UnitVar ("simple2_a11", "simple2_a11"))+ ,ConEq (UnitVar ("simple2_a22", "simple2_a22")) (UnitAlias "accel") ,ConEq (UnitParamPosUse ("simple2_sqr3",0,0)) (UnitMul (UnitParamPosUse ("simple2_sqr3",1,0)) (UnitParamPosUse ("simple2_sqr3",1,0))) ,ConEq (UnitAlias "accel") (UnitMul (UnitName "m") (UnitPow (UnitName "s") (-2.0)))] -testCons5_infer = [("simple2_a11",UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0)))- ,("simple2_a22",UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))]+testCons5_infer = [(("simple2_a11", "simple2_a11"),UnitMul (UnitPow (UnitName "m") 2.0) (UnitPow (UnitName "s") (-4.0)))+ ,(("simple2_a22", "simple2_a22"),UnitMul (UnitPow (UnitName "m") 1.0) (UnitPow (UnitName "s") (-2.0)))]++--------------------------------------------------++litTest1 = flip fortranParser "litTest1.f90" . B.pack $ unlines+ [ "program main"+ , " != unit(a) :: x"+ , " real :: x, j, k"+ , ""+ , " j = 1 + 1"+ , " k = j * j"+ , " x = x + k"+ , " x = x * j ! inconsistent"+ , "end program main" ]++squarePoly1 = flip fortranParser "squarePoly1.f90" . B.pack $ unlines+ [ "! Demonstrates parametric polymorphism through functions-calling-functions."+ , "program squarePoly"+ , " implicit none"+ , " real :: x"+ , " real :: y"+ , " != unit(m) :: a"+ , " real :: a"+ , " != unit(s) :: b"+ , " real :: b"+ , " x = squareP(a)"+ , " y = squareP(b)"+ , " contains"+ , " real function square(n)"+ , " real :: n"+ , " square = n * n"+ , " end function"+ , " real function squareP(m)"+ , " real :: m"+ , " squareP = square(m)"+ , " end function"+ , "end program" ]++recursive1 = flip fortranParser "recursive1.f90" . B.pack $ unlines+ [ "program main"+ , " != unit(m) :: y"+ , " integer :: x = 5, y = 2, z"+ , " z = recur(x,y)"+ , " print *, y"+ , "contains"+ , " real recursive function recur(n, b) result(r)"+ , " integer :: n, b"+ , " if (n .EQ. 0) then"+ , " r = b"+ , " else"+ , " r = b + recur(n - 1, b)"+ , " end if"+ , " end function recur"+ , "end program main" ]++recursive2 = flip fortranParser "recursive2.f90" . B.pack $ unlines+ [ "program main"+ , " != unit(m) :: y"+ , " integer :: x = 5, y = 2, z"+ , " z = recur(x,y)"+ , " print *, y"+ , "contains"+ , " real recursive function recur(n, b) result(r)"+ , " integer :: n, b"+ , " if (n .EQ. 0) then"+ , " r = b"+ , " else"+ , " r = b * recur(n - 1, b) ! inconsistent"+ , " end if"+ , " end function recur"+ , "end program main" ]
tests/Camfort/Transformation/CommonSpec.hs view
@@ -14,29 +14,32 @@ data Example = Example FilePath FilePath examples =- [ Example "toArgs.f90" "toArgs.expected.f90"- , Example "toArgs2.f90" "toArgs2.expected.f90"- ]+ [ Example "common.f90" "common.expected.f90" ] -readExpected :: FilePath -> IO String-readExpected filename = do+readSample :: FilePath -> IO String+readSample filename = do let path = samplesBase </> filename readFile path -readActual :: FilePath -> IO String-readActual argumentFilename = do- let argumentPath = samplesBase </> argumentFilename- let outFile = argumentPath `addExtension` "out"- commonToArgs argumentPath [] outFile ()- actual <- readFile outFile- removeFile outFile- return actual+removeSample filename = do+ let path = samplesBase </> filename+ removeFile path spec :: Spec spec =- describe "Issue #9" $- context "lalala" $ do- expected <- runIO $ readExpected "toArgs.expected.f90"- actual <- runIO $ readActual "toArgs.f90"+ describe "Common block integration test" $+ context "common.f90 into common.expect.f90 and foo.f90" $ do+ expected <- runIO $ readSample "common.expected.f90"+ expectedMod <- runIO $ readSample "cmn.expected.f90"++ let outFile = samplesBase </> "common.f90.out"+ runIO $ common (samplesBase </> "common.f90") [] outFile ()++ actual <- runIO $ readSample "common.f90.out"+ actualMod <- runIO $ readSample "cmn.f90"+ runIO $ removeSample "common.f90.out"+ runIO $ removeSample "cmn.f90" it "it eliminates common statement" $- actual `shouldBe` expected+ actual `shouldBe` expected+ it "it produces a correct module file" $+ actualMod `shouldBe` expectedMod
tests/Camfort/Transformation/EquivalenceElimSpec.hs view
@@ -54,15 +54,13 @@ it "it eliminates equivalence statements" $ actual `shouldBe` expected ----- report <- runIO $ doRefactor (mapM refactorEquivalences) (samplesBase </> "equiv.f90") [] "equiv.expected.f90"+ let rfun = mapM refactorEquivalences+ let infile = samplesBase </> "equiv.f90"+ report <- runIO $ doRefactor rfun infile [] "equiv.expected.f90" it "report is as expected" $ report `shouldBe` expectedReport - expectedReport =- "equiv.f90\- \6:2 removed equivalence\- \14:2 addded copy: y = transfer(x,y) due to refactored equivalence\- \15:2 addded copy: z(2) = transfer(x,z(2)) due to refactored equivalence\- \o.f90\- \17:0 removed dead code"+ "6:3: removed equivalence \n\+ \14:3: added copy due to refactored equivalence\n\+ \15:3: added copy due to refactored equivalence\n"
+ tests/Camfort/Transformation/samples/common.f90 view
@@ -0,0 +1,10 @@+subroutine test(a,b, c)++integer :: c1, c2, c3+COMMON /cmn/ c1, c2, c3++real :: a, b, c++print *, a, b, c++end subroutine test
+ tests/Camfort/Transformation/samples/equiv.f90 view
@@ -0,0 +1,20 @@+program wrt + implicit none+ integer :: x = 97+ character :: y+ character :: z(20)+ equivalence (x, y, z(2))++ z(1) = "c"++ write (*,'(i8,A)') x, y+++ write (*,'(i8,A,A,A)') x, y, z(1), z(2)++ x = 97 + 98 * (2**8)++ write (*,'(i8,A,A,A,A)') x, y, z(1), z(2), z(3)+++end program wrt