uuagc 0.9.51 → 0.9.52
raw patch · 22 files changed
+337/−413 lines, 22 filesdep ~uuagcPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: uuagc
API changes (from Hackage documentation)
Files
- src-ag/LOAG/Order.ag +4/−4
- src-generated/AbstractSyntax.hs +1/−1
- src-generated/Code.hs +1/−1
- src-generated/CodeSyntax.hs +1/−1
- src-generated/ConcreteSyntax.hs +1/−1
- src-generated/DeclBlocks.hs +1/−1
- src-generated/ErrorMessages.hs +1/−1
- src-generated/ExecutionPlan.hs +1/−1
- src-generated/Expression.hs +1/−1
- src-generated/HsToken.hs +1/−1
- src-generated/Interfaces.hs +1/−1
- src-generated/LOAG/Order.hs +177/−165
- src-generated/LOAG/Rep.hs +1/−1
- src-generated/Macro.hs +1/−1
- src-generated/Patterns.hs +1/−1
- src-generated/VisagePatterns.hs +1/−1
- src-generated/VisageSyntax.hs +1/−1
- src/LOAG/AOAG.hs +102/−109
- src/LOAG/Common.hs +3/−0
- src/LOAG/Graphs.hs +34/−40
- src/LOAG/Result.hs +0/−77
- uuagc.cabal +2/−3
src-ag/LOAG/Order.ag view
@@ -295,10 +295,10 @@ writeSTRef introed (Set.insert child intros) let occ = (ps,"inst") >.< (child, AnyDir) preds = Set.toList $ setConcatMap rep $ - findWithErr lfp "woot4" occ+ lfp Map.! occ rep :: MyOccurrence -> Set.Set MyOccurrence rep occ | isLoc occ = Set.insert occ $ - setConcatMap rep $ findWithErr lfp "woot3" occ+ setConcatMap rep $ lfp Map.! occ | otherwise = Set.singleton occ rest <- forM preds (visit ref introed ruleref vnrsref)@@ -311,8 +311,8 @@ where cvisit= ChildVisit (identifier child) ntid visnr child = snd $ argsOf o ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt - visnr = (\x-> findWithErr' visMap (show (inOutput,o,x)) x) (findWithErr nmpr "woot3" (nt <.> attr o))- nt = findWithErr fty "woot" (ps,child)+ visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o))+ nt = fty Map.! (ps,child) } ATTR Nonterminals Nonterminal [
src-generated/AbstractSyntax.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/AbstractSyntax.ag)+-- UUAGC 0.9.51.1 (src-ag/AbstractSyntax.ag) module AbstractSyntax where {-# LINE 2 "src-ag/AbstractSyntax.ag" #-}
src-generated/Code.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/Code.ag)+-- UUAGC 0.9.51.1 (src-ag/Code.ag) module Code where {-# LINE 2 "src-ag/Code.ag" #-}
src-generated/CodeSyntax.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/CodeSyntax.ag)+-- UUAGC 0.9.51.1 (src-ag/CodeSyntax.ag) module CodeSyntax where {-# LINE 2 "src-ag/CodeSyntax.ag" #-}
src-generated/ConcreteSyntax.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/ConcreteSyntax.ag)+-- UUAGC 0.9.51.1 (src-ag/ConcreteSyntax.ag) module ConcreteSyntax where {-# LINE 2 "src-ag/ConcreteSyntax.ag" #-}
src-generated/DeclBlocks.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/DeclBlocks.ag)+-- UUAGC 0.9.51.1 (src-ag/DeclBlocks.ag) module DeclBlocks where {-# LINE 2 "src-ag/DeclBlocks.ag" #-}
src-generated/ErrorMessages.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/ErrorMessages.ag)+-- UUAGC 0.9.51.1 (src-ag/ErrorMessages.ag) module ErrorMessages where {-# LINE 2 "src-ag/ErrorMessages.ag" #-}
src-generated/ExecutionPlan.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/ExecutionPlan.ag)+-- UUAGC 0.9.51.1 (src-ag/ExecutionPlan.ag) module ExecutionPlan where {-# LINE 2 "src-ag/ExecutionPlan.ag" #-}
src-generated/Expression.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/Expression.ag)+-- UUAGC 0.9.51.1 (src-ag/Expression.ag) module Expression where {-# LINE 2 "src-ag/Expression.ag" #-}
src-generated/HsToken.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/HsToken.ag)+-- UUAGC 0.9.51.1 (src-ag/HsToken.ag) module HsToken where {-# LINE 2 "src-ag/HsToken.ag" #-}
src-generated/Interfaces.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/Interfaces.ag)+-- UUAGC 0.9.51.1 (src-ag/Interfaces.ag) module Interfaces where {-# LINE 2 "src-ag/Interfaces.ag" #-}
src-generated/LOAG/Order.hs view
@@ -106,7 +106,8 @@ {-# LINE 292 "src-ag/LOAG/Prepare.ag" #-} --- | Replace the references to local attributes, by his attrs dependencies+-- | Replace the references to local attributes, by his attrs dependencies,+-- | rendering the local attributes 'transparent'. repLocRefs :: SF_P -> SF_P -> SF_P repLocRefs lfp sfp = Map.map (setConcatMap rep) sfp@@ -114,14 +115,25 @@ rep occ | isLoc occ = setConcatMap rep $ findWithErr lfp "repping locals" occ | otherwise = Set.singleton occ-{-# LINE 118 "dist/build/LOAG/Order.hs" #-} +-- | Add dependencies from a higher order child to all its attributes+addHigherOrders :: SF_P -> SF_P -> SF_P+addHigherOrders lfp sfp = + Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp+ where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence+ f mo@(MyOccurrence (p,f) _) deps =+ let ho = ((p,"inst") >.< (f,AnyDir))+ in if ho `Map.member` lfp+ then ho `Set.insert` deps+ else deps+{-# LINE 130 "dist/build/LOAG/Order.hs" #-}+ {-# LINE 42 "src-ag/LOAG/Order.ag" #-} fst' (a,_,_) = a snd' (_,b,_) = b trd' (_,_,c) = c-{-# LINE 125 "dist/build/LOAG/Order.hs" #-}+{-# LINE 137 "dist/build/LOAG/Order.hs" #-} {-# LINE 95 "src-ag/LOAG/Order.ag" #-} @@ -151,7 +163,7 @@ ppOcc pmp v = text f >|< text "." >|< fst a where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v -{-# LINE 155 "dist/build/LOAG/Order.hs" #-}+{-# LINE 167 "dist/build/LOAG/Order.hs" #-} {-# LINE 239 "src-ag/LOAG/Order.ag" #-} @@ -213,10 +225,10 @@ writeSTRef introed (Set.insert child intros) let occ = (ps,"inst") >.< (child, AnyDir) preds = Set.toList $ setConcatMap rep $ - findWithErr lfp "woot4" occ+ lfp Map.! occ rep :: MyOccurrence -> Set.Set MyOccurrence rep occ | isLoc occ = Set.insert occ $ - setConcatMap rep $ findWithErr lfp "woot3" occ+ setConcatMap rep $ lfp Map.! occ | otherwise = Set.singleton occ rest <- forM preds (visit ref introed ruleref vnrsref)@@ -229,9 +241,9 @@ where cvisit= ChildVisit (identifier child) ntid visnr child = snd $ argsOf o ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt - visnr = (\x-> findWithErr' visMap (show (inOutput,o,x)) x) (findWithErr nmpr "woot3" (nt <.> attr o))- nt = findWithErr fty "woot" (ps,child)-{-# LINE 235 "dist/build/LOAG/Order.hs" #-}+ visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o))+ nt = fty Map.! (ps,child)+{-# LINE 247 "dist/build/LOAG/Order.hs" #-} {-# LINE 356 "src-ag/LOAG/Order.ag" #-} @@ -313,7 +325,7 @@ syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss -{-# LINE 317 "dist/build/LOAG/Order.hs" #-}+{-# LINE 329 "dist/build/LOAG/Order.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper data Inh_CGrammar = Inh_CGrammar { }@@ -1093,13 +1105,13 @@ case tp_ of NT nt _ _ -> Set.singleton nt _ -> mempty- {-# LINE 1097 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1109 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule33 #-} {-# LINE 34 "src-ag/ExecutionPlanCommon.ag" #-} rule33 = \ _isHigherOrder _refNts -> {-# LINE 34 "src-ag/ExecutionPlanCommon.ag" #-} if _isHigherOrder then _refNts else mempty- {-# LINE 1103 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1115 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule34 #-} {-# LINE 35 "src-ag/ExecutionPlanCommon.ag" #-} rule34 = \ kind_ ->@@ -1107,7 +1119,7 @@ case kind_ of ChildSyntax -> False _ -> True- {-# LINE 1111 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1123 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule35 #-} {-# LINE 95 "src-ag/ExecutionPlanCommon.ag" #-} rule35 = \ ((_lhsIaroundMap) :: Map Identifier [Expression]) name_ ->@@ -1115,19 +1127,19 @@ case Map.lookup name_ _lhsIaroundMap of Nothing -> False Just as -> not (null as)- {-# LINE 1119 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1131 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule36 #-} {-# LINE 123 "src-ag/ExecutionPlanCommon.ag" #-} rule36 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier], Expression)) name_ -> {-# LINE 123 "src-ag/ExecutionPlanCommon.ag" #-} maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup name_ _lhsImergeMap- {-# LINE 1125 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1137 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule37 #-} {-# LINE 124 "src-ag/ExecutionPlanCommon.ag" #-} rule37 = \ ((_lhsImergedChildren) :: Set Identifier) name_ -> {-# LINE 124 "src-ag/ExecutionPlanCommon.ag" #-} name_ `Set.member` _lhsImergedChildren- {-# LINE 1131 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1143 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule38 #-} {-# LINE 135 "src-ag/ExecutionPlanCommon.ag" #-} rule38 = \ _hasArounds _isMerged _merges kind_ name_ tp_ ->@@ -1135,56 +1147,56 @@ case tp_ of NT _ _ _ -> EChild name_ tp_ kind_ _hasArounds _merges _isMerged _ -> ETerm name_ tp_- {-# LINE 1139 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1151 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule39 #-} {-# LINE 174 "src-ag/LOAG/Prepare.ag" #-} rule39 = \ ((_lhsIflab) :: Int) -> {-# LINE 174 "src-ag/LOAG/Prepare.ag" #-} _lhsIflab + 1- {-# LINE 1145 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1157 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule40 #-} {-# LINE 175 "src-ag/LOAG/Prepare.ag" #-} rule40 = \ tp_ -> {-# LINE 175 "src-ag/LOAG/Prepare.ag" #-} toMyTy tp_- {-# LINE 1151 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1163 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule41 #-} {-# LINE 177 "src-ag/LOAG/Prepare.ag" #-} rule41 = \ _atp ((_lhsIan) :: MyType -> MyAttributes) ((_lhsIpll) :: PLabel) name_ -> {-# LINE 177 "src-ag/LOAG/Prepare.ag" #-} map ((FieldAtt _atp _lhsIpll (getName name_)) . alab) $ _lhsIan _atp- {-# LINE 1158 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1170 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule42 #-} {-# LINE 179 "src-ag/LOAG/Prepare.ag" #-} rule42 = \ _flab -> {-# LINE 179 "src-ag/LOAG/Prepare.ag" #-} _flab- {-# LINE 1164 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1176 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule43 #-} {-# LINE 180 "src-ag/LOAG/Prepare.ag" #-} rule43 = \ name_ -> {-# LINE 180 "src-ag/LOAG/Prepare.ag" #-} getName name_- {-# LINE 1170 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1182 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule44 #-} {-# LINE 181 "src-ag/LOAG/Prepare.ag" #-} rule44 = \ _ident ((_lhsIpll) :: PLabel) -> {-# LINE 181 "src-ag/LOAG/Prepare.ag" #-} (_lhsIpll, _ident )- {-# LINE 1176 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1188 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule45 #-} {-# LINE 182 "src-ag/LOAG/Prepare.ag" #-} rule45 = \ _atp _label ((_lhsIain) :: MyType -> MyAttributes) -> {-# LINE 182 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIain _atp- {-# LINE 1182 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1194 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule46 #-} {-# LINE 183 "src-ag/LOAG/Prepare.ag" #-} rule46 = \ _atp _label ((_lhsIasn) :: MyType -> MyAttributes) -> {-# LINE 183 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIasn _atp- {-# LINE 1188 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1200 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule47 #-} {-# LINE 184 "src-ag/LOAG/Prepare.ag" #-} rule47 = \ _foccsI _foccsS _label ->@@ -1192,7 +1204,7 @@ if Set.null _foccsI && Set.null _foccsS then Map.empty else Map.singleton _label (_foccsS ,_foccsI )- {-# LINE 1196 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1208 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule48 #-} {-# LINE 187 "src-ag/LOAG/Prepare.ag" #-} rule48 = \ _ident ((_lhsIpll) :: PLabel) kind_ ->@@ -1200,19 +1212,19 @@ case kind_ of ChildAttr -> Map.singleton _lhsIpll (Set.singleton _ident ) _ -> Map.empty- {-# LINE 1204 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1216 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule49 #-} {-# LINE 190 "src-ag/LOAG/Prepare.ag" #-} rule49 = \ _atp ((_lhsIpll) :: PLabel) name_ -> {-# LINE 190 "src-ag/LOAG/Prepare.ag" #-} Map.singleton (_lhsIpll, getName name_) _atp- {-# LINE 1210 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1222 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule50 #-} {-# LINE 223 "src-ag/LOAG/Prepare.ag" #-} rule50 = \ name_ -> {-# LINE 223 "src-ag/LOAG/Prepare.ag" #-} Set.singleton $ getName name_- {-# LINE 1216 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1228 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule51 #-} rule51 = \ ((_fattsIap) :: A_P) -> _fattsIap@@ -1594,56 +1606,56 @@ rule120 = \ ((_lhsIflab) :: Int) -> {-# LINE 161 "src-ag/LOAG/Prepare.ag" #-} _lhsIflab + 1- {-# LINE 1598 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1610 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule121 #-} {-# LINE 162 "src-ag/LOAG/Prepare.ag" #-} rule121 = \ ((_lhsIpll) :: PLabel) -> {-# LINE 162 "src-ag/LOAG/Prepare.ag" #-} fst _lhsIpll- {-# LINE 1604 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1616 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule122 #-} {-# LINE 164 "src-ag/LOAG/Prepare.ag" #-} rule122 = \ _atp ((_lhsIan) :: MyType -> MyAttributes) ((_lhsIpll) :: PLabel) -> {-# LINE 164 "src-ag/LOAG/Prepare.ag" #-} map ((FieldAtt _atp _lhsIpll "lhs") . alab) $ _lhsIan _atp- {-# LINE 1611 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1623 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule123 #-} {-# LINE 166 "src-ag/LOAG/Prepare.ag" #-} rule123 = \ _flab -> {-# LINE 166 "src-ag/LOAG/Prepare.ag" #-} _flab- {-# LINE 1617 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1629 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule124 #-} {-# LINE 167 "src-ag/LOAG/Prepare.ag" #-} rule124 = \ ((_lhsIpll) :: PLabel) -> {-# LINE 167 "src-ag/LOAG/Prepare.ag" #-} (_lhsIpll, "lhs")- {-# LINE 1623 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1635 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule125 #-} {-# LINE 168 "src-ag/LOAG/Prepare.ag" #-} rule125 = \ _atp _label ((_lhsIain) :: MyType -> MyAttributes) -> {-# LINE 168 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIain _atp- {-# LINE 1629 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1641 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule126 #-} {-# LINE 169 "src-ag/LOAG/Prepare.ag" #-} rule126 = \ _atp _label ((_lhsIasn) :: MyType -> MyAttributes) -> {-# LINE 169 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIasn _atp- {-# LINE 1635 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1647 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule127 #-} {-# LINE 170 "src-ag/LOAG/Prepare.ag" #-} rule127 = \ _foccsI _foccsS _label -> {-# LINE 170 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _label (_foccsI , _foccsS )- {-# LINE 1641 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1653 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule128 #-} {-# LINE 171 "src-ag/LOAG/Prepare.ag" #-} rule128 = \ _label ((_lhsIdty) :: MyType) -> {-# LINE 171 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _label _lhsIdty- {-# LINE 1647 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1659 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule129 #-} rule129 = \ ((_fattsIap) :: A_P) -> _fattsIap@@ -1760,25 +1772,25 @@ rule148 = \ tks_ -> {-# LINE 273 "src-ag/LOAG/Prepare.ag" #-} HsTokensRoot tks_- {-# LINE 1764 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1776 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule149 #-} {-# LINE 274 "src-ag/LOAG/Prepare.ag" #-} rule149 = \ ((_lhsIpll) :: PLabel) -> {-# LINE 274 "src-ag/LOAG/Prepare.ag" #-} _lhsIpll- {-# LINE 1770 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1782 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule150 #-} {-# LINE 275 "src-ag/LOAG/Prepare.ag" #-} rule150 = \ ((_lhsIpts) :: Set.Set (FLabel)) -> {-# LINE 275 "src-ag/LOAG/Prepare.ag" #-} _lhsIpts- {-# LINE 1776 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1788 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule151 #-} {-# LINE 276 "src-ag/LOAG/Prepare.ag" #-} rule151 = \ ((_tokensIused) :: Set.Set MyOccurrence) -> {-# LINE 276 "src-ag/LOAG/Prepare.ag" #-} _tokensIused- {-# LINE 1782 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1794 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule152 #-} rule152 = \ pos_ tks_ -> Expression pos_ tks_@@ -1866,61 +1878,61 @@ rule156 = \ ((_lhsIolab) :: Int) -> {-# LINE 193 "src-ag/LOAG/Prepare.ag" #-} _lhsIolab + 1- {-# LINE 1870 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1882 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule157 #-} {-# LINE 194 "src-ag/LOAG/Prepare.ag" #-} rule157 = \ _att ((_lhsInmprf) :: NMP_R) -> {-# LINE 194 "src-ag/LOAG/Prepare.ag" #-} findWithErr _lhsInmprf "getting attr label" _att- {-# LINE 1876 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1888 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule158 #-} {-# LINE 195 "src-ag/LOAG/Prepare.ag" #-} rule158 = \ a_ t_ -> {-# LINE 195 "src-ag/LOAG/Prepare.ag" #-} t_ <.> a_- {-# LINE 1882 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1894 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule159 #-} {-# LINE 196 "src-ag/LOAG/Prepare.ag" #-} rule159 = \ a_ f_ p_ -> {-# LINE 196 "src-ag/LOAG/Prepare.ag" #-} (p_, f_) >.< a_- {-# LINE 1888 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1900 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule160 #-} {-# LINE 197 "src-ag/LOAG/Prepare.ag" #-} rule160 = \ _occ _olab -> {-# LINE 197 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _olab _occ- {-# LINE 1894 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1906 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule161 #-} {-# LINE 198 "src-ag/LOAG/Prepare.ag" #-} rule161 = \ _occ _olab -> {-# LINE 198 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _occ _olab- {-# LINE 1900 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1912 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule162 #-} {-# LINE 199 "src-ag/LOAG/Prepare.ag" #-} rule162 = \ _alab _olab -> {-# LINE 199 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _alab [_olab ]- {-# LINE 1906 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1918 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule163 #-} {-# LINE 200 "src-ag/LOAG/Prepare.ag" #-} rule163 = \ _alab _olab -> {-# LINE 200 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _olab _alab- {-# LINE 1912 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1924 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule164 #-} {-# LINE 201 "src-ag/LOAG/Prepare.ag" #-} rule164 = \ _occ p_ -> {-# LINE 201 "src-ag/LOAG/Prepare.ag" #-} Map.singleton p_ [_occ ]- {-# LINE 1918 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1930 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule165 #-} {-# LINE 202 "src-ag/LOAG/Prepare.ag" #-} rule165 = \ ((_lhsIflab) :: Int) _olab -> {-# LINE 202 "src-ag/LOAG/Prepare.ag" #-} [(_olab , _lhsIflab)]- {-# LINE 1924 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 1936 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule166 #-} rule166 = \ (_ :: ()) -> Map.empty@@ -2252,49 +2264,49 @@ rule205 = \ ((_nontsIntDeps) :: Map NontermIdent (Set NontermIdent)) -> {-# LINE 40 "src-ag/ExecutionPlanCommon.ag" #-} closeMap _nontsIntDeps- {-# LINE 2256 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2268 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule206 #-} {-# LINE 41 "src-ag/ExecutionPlanCommon.ag" #-} rule206 = \ ((_nontsIntHoDeps) :: Map NontermIdent (Set NontermIdent)) -> {-# LINE 41 "src-ag/ExecutionPlanCommon.ag" #-} closeMap _nontsIntHoDeps- {-# LINE 2262 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2274 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule207 #-} {-# LINE 42 "src-ag/ExecutionPlanCommon.ag" #-} rule207 = \ _closedHoNtDeps -> {-# LINE 42 "src-ag/ExecutionPlanCommon.ag" #-} revDeps _closedHoNtDeps- {-# LINE 2268 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2280 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule208 #-} {-# LINE 51 "src-ag/ExecutionPlanCommon.ag" #-} rule208 = \ contextMap_ -> {-# LINE 51 "src-ag/ExecutionPlanCommon.ag" #-} contextMap_- {-# LINE 2274 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2286 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule209 #-} {-# LINE 92 "src-ag/ExecutionPlanCommon.ag" #-} rule209 = \ aroundsMap_ -> {-# LINE 92 "src-ag/ExecutionPlanCommon.ag" #-} aroundsMap_- {-# LINE 2280 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2292 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule210 #-} {-# LINE 117 "src-ag/ExecutionPlanCommon.ag" #-} rule210 = \ mergeMap_ -> {-# LINE 117 "src-ag/ExecutionPlanCommon.ag" #-} mergeMap_- {-# LINE 2286 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2298 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule211 #-} {-# LINE 9 "src-ag/ExecutionPlanPre.ag" #-} rule211 = \ (_ :: ()) -> {-# LINE 9 "src-ag/ExecutionPlanPre.ag" #-} 0- {-# LINE 2292 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2304 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule212 #-} {-# LINE 38 "src-ag/LOAG/Prepare.ag" #-} rule212 = \ ((_nontsIpmp) :: PMP) -> {-# LINE 38 "src-ag/LOAG/Prepare.ag" #-} if Map.null _nontsIpmp then 1 else fst $ Map.findMin _nontsIpmp- {-# LINE 2298 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2310 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule213 #-} {-# LINE 40 "src-ag/LOAG/Prepare.ag" #-} rule213 = \ _ain _an _asn _initO _nmp _nmpr ((_nontsIap) :: A_P) ((_nontsIfieldMap) :: FMap) ((_nontsIfsInP) :: FsInP) ((_nontsIfty) :: FTY) ((_nontsIgen) :: Map Int Int) ((_nontsIinss) :: Map Int [Int]) ((_nontsIofld) :: [(Int, Int)]) ((_nontsIpmp) :: PMP) ((_nontsIpmpr) :: PMP_R) ((_nontsIps) :: [PLabel]) _sfp ->@@ -2308,145 +2320,145 @@ Map.toList $ _nontsIinss) (A.array (_initO , _initO + length _nontsIofld) $ _nontsIofld) _nontsIfty _nontsIfieldMap _nontsIfsInP- {-# LINE 2312 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2324 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule214 #-} {-# LINE 49 "src-ag/LOAG/Prepare.ag" #-} rule214 = \ _atts -> {-# LINE 49 "src-ag/LOAG/Prepare.ag" #-} Map.fromList $ zip [1..] _atts- {-# LINE 2318 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2330 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule215 #-} {-# LINE 50 "src-ag/LOAG/Prepare.ag" #-} rule215 = \ _atts -> {-# LINE 50 "src-ag/LOAG/Prepare.ag" #-} Map.fromList $ zip _atts [1..]- {-# LINE 2324 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2336 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule216 #-} {-# LINE 51 "src-ag/LOAG/Prepare.ag" #-} rule216 = \ _ain _asn -> {-# LINE 51 "src-ag/LOAG/Prepare.ag" #-} Map.unionWith (++) _ain _asn- {-# LINE 2330 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2342 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule217 #-} {-# LINE 52 "src-ag/LOAG/Prepare.ag" #-} rule217 = \ ((_nontsIinhs) :: AI_N) -> {-# LINE 52 "src-ag/LOAG/Prepare.ag" #-} _nontsIinhs- {-# LINE 2336 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2348 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule218 #-} {-# LINE 53 "src-ag/LOAG/Prepare.ag" #-} rule218 = \ ((_nontsIsyns) :: AS_N) -> {-# LINE 53 "src-ag/LOAG/Prepare.ag" #-} _nontsIsyns- {-# LINE 2342 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2354 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule219 #-} {-# LINE 54 "src-ag/LOAG/Prepare.ag" #-} rule219 = \ _an -> {-# LINE 54 "src-ag/LOAG/Prepare.ag" #-} concat $ Map.elems _an- {-# LINE 2348 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2360 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule220 #-} {-# LINE 55 "src-ag/LOAG/Prepare.ag" #-} rule220 = \ ((_nontsIap) :: A_P) -> {-# LINE 55 "src-ag/LOAG/Prepare.ag" #-} concat $ Map.elems _nontsIap- {-# LINE 2354 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2366 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule221 #-} {-# LINE 56 "src-ag/LOAG/Prepare.ag" #-} rule221 = \ manualAttrOrderMap_ -> {-# LINE 56 "src-ag/LOAG/Prepare.ag" #-} manualAttrOrderMap_- {-# LINE 2360 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2372 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule222 #-} {-# LINE 87 "src-ag/LOAG/Prepare.ag" #-} rule222 = \ _ain -> {-# LINE 87 "src-ag/LOAG/Prepare.ag" #-} map2F _ain- {-# LINE 2366 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2378 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule223 #-} {-# LINE 88 "src-ag/LOAG/Prepare.ag" #-} rule223 = \ _asn -> {-# LINE 88 "src-ag/LOAG/Prepare.ag" #-} map2F _asn- {-# LINE 2372 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2384 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule224 #-} {-# LINE 89 "src-ag/LOAG/Prepare.ag" #-} rule224 = \ ((_nontsIpmp) :: PMP) -> {-# LINE 89 "src-ag/LOAG/Prepare.ag" #-} _nontsIpmp- {-# LINE 2378 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2390 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule225 #-} {-# LINE 90 "src-ag/LOAG/Prepare.ag" #-} rule225 = \ ((_nontsIpmpr) :: PMP_R) -> {-# LINE 90 "src-ag/LOAG/Prepare.ag" #-} _nontsIpmpr- {-# LINE 2384 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2396 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule226 #-} {-# LINE 91 "src-ag/LOAG/Prepare.ag" #-} rule226 = \ ((_nontsIlfp) :: SF_P) -> {-# LINE 91 "src-ag/LOAG/Prepare.ag" #-} _nontsIlfp- {-# LINE 2390 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2402 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule227 #-} {-# LINE 92 "src-ag/LOAG/Prepare.ag" #-} rule227 = \ ((_nontsIhoMap) :: HOMap) -> {-# LINE 92 "src-ag/LOAG/Prepare.ag" #-} _nontsIhoMap- {-# LINE 2396 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2408 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule228 #-} {-# LINE 93 "src-ag/LOAG/Prepare.ag" #-} rule228 = \ ((_nontsIfty) :: FTY) -> {-# LINE 93 "src-ag/LOAG/Prepare.ag" #-} _nontsIfty- {-# LINE 2402 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2414 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule229 #-} {-# LINE 94 "src-ag/LOAG/Prepare.ag" #-} rule229 = \ ((_nontsIfty) :: FTY) -> {-# LINE 94 "src-ag/LOAG/Prepare.ag" #-} _nontsIfty- {-# LINE 2408 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2420 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule230 #-} {-# LINE 103 "src-ag/LOAG/Prepare.ag" #-} rule230 = \ ((_nontsIps) :: [PLabel]) -> {-# LINE 103 "src-ag/LOAG/Prepare.ag" #-} _nontsIps- {-# LINE 2414 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2426 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule231 #-} {-# LINE 150 "src-ag/LOAG/Prepare.ag" #-} rule231 = \ _an -> {-# LINE 150 "src-ag/LOAG/Prepare.ag" #-} map2F _an- {-# LINE 2420 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2432 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule232 #-} {-# LINE 151 "src-ag/LOAG/Prepare.ag" #-} rule232 = \ _nmpr -> {-# LINE 151 "src-ag/LOAG/Prepare.ag" #-} _nmpr- {-# LINE 2426 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2438 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule233 #-} {-# LINE 152 "src-ag/LOAG/Prepare.ag" #-} rule233 = \ _nmp -> {-# LINE 152 "src-ag/LOAG/Prepare.ag" #-} if Map.null _nmp then 0 else (fst $ Map.findMax _nmp )- {-# LINE 2432 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2444 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule234 #-} {-# LINE 153 "src-ag/LOAG/Prepare.ag" #-} rule234 = \ (_ :: ()) -> {-# LINE 153 "src-ag/LOAG/Prepare.ag" #-} 0- {-# LINE 2438 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2450 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule235 #-} {-# LINE 207 "src-ag/LOAG/Prepare.ag" #-} rule235 = \ ((_nontsIlfp) :: SF_P) ((_nontsIsfp) :: SF_P) -> {-# LINE 207 "src-ag/LOAG/Prepare.ag" #-}- repLocRefs _nontsIlfp _nontsIsfp- {-# LINE 2444 "dist/build/LOAG/Order.hs"#-}+ repLocRefs _nontsIlfp $ addHigherOrders _nontsIlfp _nontsIsfp+ {-# LINE 2456 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule236 #-} {-# LINE 54 "src-ag/LOAG/Order.ag" #-} rule236 = \ _schedRes -> {-# LINE 54 "src-ag/LOAG/Order.ag" #-} either Seq.singleton (const Seq.empty) _schedRes- {-# LINE 2450 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2462 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule237 #-} {-# LINE 55 "src-ag/LOAG/Order.ag" #-} rule237 = \ ((_lhsIoptions) :: Options) ((_nontsIpmp) :: PMP) _schedRes ->@@ -2454,25 +2466,25 @@ case either (const []) trd' _schedRes of [] -> Nothing ads -> Just $ ppAds _lhsIoptions _nontsIpmp ads- {-# LINE 2458 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2470 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule238 #-} {-# LINE 58 "src-ag/LOAG/Order.ag" #-} rule238 = \ ((_nontsIenonts) :: ENonterminals) derivings_ typeSyns_ wrappers_ -> {-# LINE 58 "src-ag/LOAG/Order.ag" #-} ExecutionPlan _nontsIenonts typeSyns_ wrappers_ derivings_- {-# LINE 2464 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2476 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule239 #-} {-# LINE 60 "src-ag/LOAG/Order.ag" #-} rule239 = \ _schedRes -> {-# LINE 60 "src-ag/LOAG/Order.ag" #-} either (const Map.empty) snd' _schedRes- {-# LINE 2470 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2482 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule240 #-} {-# LINE 61 "src-ag/LOAG/Order.ag" #-} rule240 = \ _schedRes -> {-# LINE 61 "src-ag/LOAG/Order.ag" #-} either (error "no tdp") (fromJust.fst') _schedRes- {-# LINE 2476 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2488 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule241 #-} {-# LINE 63 "src-ag/LOAG/Order.ag" #-} rule241 = \ _ag ((_lhsIoptions) :: Options) _loagRes ((_nontsIads) :: [Edge]) _self ((_smfIself) :: LOAGRep) ->@@ -2482,38 +2494,38 @@ then AOAG.schedule _smfIself _self _ag _nontsIads else _loagRes else Right (Nothing,Map.empty,[])- {-# LINE 2486 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2498 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule242 #-} {-# LINE 68 "src-ag/LOAG/Order.ag" #-} rule242 = \ _ag ((_lhsIoptions) :: Options) -> {-# LINE 68 "src-ag/LOAG/Order.ag" #-} let putStrLn s = when (verbose _lhsIoptions) (IO.putStrLn s) in Right $ unsafePerformIO $ scheduleLOAG _ag putStrLn _lhsIoptions- {-# LINE 2493 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2505 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule243 #-} {-# LINE 70 "src-ag/LOAG/Order.ag" #-} rule243 = \ _self ((_smfIself) :: LOAGRep) -> {-# LINE 70 "src-ag/LOAG/Order.ag" #-} repToAg _smfIself _self- {-# LINE 2499 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2511 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule244 #-} {-# LINE 72 "src-ag/LOAG/Order.ag" #-} rule244 = \ _schedRes -> {-# LINE 72 "src-ag/LOAG/Order.ag" #-} either (const []) trd' _schedRes- {-# LINE 2505 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2517 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule245 #-} {-# LINE 133 "src-ag/LOAG/Order.ag" #-} rule245 = \ ((_nontsIvisMap) :: IMap.IntMap Int) -> {-# LINE 133 "src-ag/LOAG/Order.ag" #-} _nontsIvisMap- {-# LINE 2511 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2523 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule246 #-} {-# LINE 134 "src-ag/LOAG/Order.ag" #-} rule246 = \ (_ :: ()) -> {-# LINE 134 "src-ag/LOAG/Order.ag" #-} 0- {-# LINE 2517 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2529 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule247 #-} rule247 = \ ((_nontsIinhmap) :: Map.Map NontermIdent Attributes) -> _nontsIinhmap@@ -2603,7 +2615,7 @@ True -> Set.empty False -> Set.singleton $ (_lhsIpll, getName _LOC) >.< (getName var_, drhs _LOC)- {-# LINE 2607 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2619 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule258 #-} rule258 = \ pos_ rdesc_ var_ -> AGLocal var_ pos_ rdesc_@@ -2631,7 +2643,7 @@ {-# LINE 289 "src-ag/LOAG/Prepare.ag" #-} Set.singleton $ (_lhsIpll, getName field_) >.< (getName attr_, drhs field_)- {-# LINE 2635 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 2647 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule261 #-} rule261 = \ attr_ field_ pos_ rdesc_ -> AGField field_ attr_ pos_ rdesc_@@ -3026,51 +3038,51 @@ rule294 = \ ((_lhsInmp) :: NMP) inhAttr_ -> {-# LINE 225 "src-ag/LOAG/Order.ag" #-} Map.keysSet$ Map.unions $ map (vertexToAttr _lhsInmp) inhAttr_- {-# LINE 3030 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3042 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule295 #-} {-# LINE 226 "src-ag/LOAG/Order.ag" #-} rule295 = \ ((_lhsInmp) :: NMP) synAttr_ -> {-# LINE 226 "src-ag/LOAG/Order.ag" #-} Map.keysSet$ Map.unions $ map (vertexToAttr _lhsInmp) synAttr_- {-# LINE 3036 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3048 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule296 #-} {-# LINE 227 "src-ag/LOAG/Order.ag" #-} rule296 = \ inhOccs_ -> {-# LINE 227 "src-ag/LOAG/Order.ag" #-} maybe (error "segment not instantiated") id inhOccs_- {-# LINE 3042 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3054 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule297 #-} {-# LINE 228 "src-ag/LOAG/Order.ag" #-} rule297 = \ synOccs_ -> {-# LINE 228 "src-ag/LOAG/Order.ag" #-} maybe (error "segment not instantiated") id synOccs_- {-# LINE 3048 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3060 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule298 #-} {-# LINE 229 "src-ag/LOAG/Order.ag" #-} rule298 = \ visnr_ -> {-# LINE 229 "src-ag/LOAG/Order.ag" #-} visnr_- {-# LINE 3054 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3066 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule299 #-} {-# LINE 230 "src-ag/LOAG/Order.ag" #-} rule299 = \ ((_lhsIoptions) :: Options) -> {-# LINE 230 "src-ag/LOAG/Order.ag" #-} if monadic _lhsIoptions then VisitMonadic else VisitPure True- {-# LINE 3060 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3072 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule300 #-} {-# LINE 231 "src-ag/LOAG/Order.ag" #-} rule300 = \ _inhs _kind ((_lhsIvisitnum) :: Int) _steps _syns -> {-# LINE 231 "src-ag/LOAG/Order.ag" #-} Visit _lhsIvisitnum _lhsIvisitnum (_lhsIvisitnum+1) _inhs _syns _steps _kind- {-# LINE 3067 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3079 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule301 #-} {-# LINE 233 "src-ag/LOAG/Order.ag" #-} rule301 = \ ((_lhsIoptions) :: Options) _vss -> {-# LINE 233 "src-ag/LOAG/Order.ag" #-} if monadic _lhsIoptions then [Sim _vss ] else [PureGroup _vss True]- {-# LINE 3074 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3086 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule302 #-} {-# LINE 235 "src-ag/LOAG/Order.ag" #-} rule302 = \ ((_lhsIdone) :: (Set.Set MyOccurrence, Set.Set FLabel@@ -3079,7 +3091,7 @@ (runST $ getVss _lhsIdone _lhsIps _lhsItdp _synsO _lhsIlfpf _lhsInmprf _lhsIpmpf _lhsIpmprf _lhsIfty _lhsIvisMapf _lhsIruleMap _lhsIhoMapf)- {-# LINE 3083 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3095 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule303 #-} rule303 = \ inhAttr_ inhOccs_ synAttr_ synOccs_ visnr_ -> MySegment visnr_ inhAttr_ synAttr_ inhOccs_ synOccs_@@ -3184,14 +3196,14 @@ , Set.Set Identifier, Set.Set (FLabel,Int))) -> {-# LINE 220 "src-ag/LOAG/Order.ag" #-} _lhsIdone- {-# LINE 3188 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3200 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule308 #-} {-# LINE 221 "src-ag/LOAG/Order.ag" #-} rule308 = \ ((_hdIdone) :: (Set.Set MyOccurrence, Set.Set FLabel ,Set.Set Identifier, Set.Set (FLabel,Int))) -> {-# LINE 221 "src-ag/LOAG/Order.ag" #-} _hdIdone- {-# LINE 3195 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3207 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule309 #-} rule309 = \ ((_hdIevisits) :: Visit) ((_tlIevisits) :: Visits) -> _hdIevisits : _tlIevisits@@ -3478,43 +3490,43 @@ rule347 = \ ((_prodsIrefNts) :: Set NontermIdent) nt_ -> {-# LINE 16 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ _prodsIrefNts- {-# LINE 3482 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3494 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule348 #-} {-# LINE 17 "src-ag/ExecutionPlanCommon.ag" #-} rule348 = \ ((_prodsIrefHoNts) :: Set NontermIdent) nt_ -> {-# LINE 17 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ _prodsIrefHoNts- {-# LINE 3488 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3500 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule349 #-} {-# LINE 19 "src-ag/ExecutionPlanCommon.ag" #-} rule349 = \ ((_lhsIclosedNtDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 19 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedNtDeps- {-# LINE 3494 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3506 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule350 #-} {-# LINE 20 "src-ag/ExecutionPlanCommon.ag" #-} rule350 = \ ((_lhsIclosedHoNtDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 20 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedHoNtDeps- {-# LINE 3500 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3512 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule351 #-} {-# LINE 21 "src-ag/ExecutionPlanCommon.ag" #-} rule351 = \ ((_lhsIclosedHoNtRevDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 21 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedHoNtRevDeps- {-# LINE 3506 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3518 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule352 #-} {-# LINE 23 "src-ag/ExecutionPlanCommon.ag" #-} rule352 = \ _closedNtDeps nt_ -> {-# LINE 23 "src-ag/ExecutionPlanCommon.ag" #-} nt_ `Set.member` _closedNtDeps- {-# LINE 3512 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3524 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule353 #-} {-# LINE 24 "src-ag/ExecutionPlanCommon.ag" #-} rule353 = \ _closedHoNtDeps nt_ -> {-# LINE 24 "src-ag/ExecutionPlanCommon.ag" #-} nt_ `Set.member` _closedHoNtDeps- {-# LINE 3518 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3530 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule354 #-} {-# LINE 25 "src-ag/ExecutionPlanCommon.ag" #-} rule354 = \ _closedHoNtDeps _closedHoNtRevDeps _nontrivAcyc ->@@ -3523,57 +3535,57 @@ , hoNtRevDeps = _closedHoNtRevDeps , hoAcyclic = _nontrivAcyc }- {-# LINE 3527 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3539 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule355 #-} {-# LINE 54 "src-ag/ExecutionPlanCommon.ag" #-} rule355 = \ ((_lhsIclassContexts) :: ContextMap) nt_ -> {-# LINE 54 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault [] nt_ _lhsIclassContexts- {-# LINE 3533 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3545 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule356 #-} {-# LINE 88 "src-ag/ExecutionPlanCommon.ag" #-} rule356 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) nt_ -> {-# LINE 88 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIaroundMap- {-# LINE 3539 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3551 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule357 #-} {-# LINE 113 "src-ag/ExecutionPlanCommon.ag" #-} rule357 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) nt_ -> {-# LINE 113 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty nt_ _lhsImergeMap- {-# LINE 3545 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3557 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule358 #-} {-# LINE 149 "src-ag/ExecutionPlanCommon.ag" #-} rule358 = \ inh_ nt_ -> {-# LINE 149 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ inh_- {-# LINE 3551 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3563 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule359 #-} {-# LINE 150 "src-ag/ExecutionPlanCommon.ag" #-} rule359 = \ nt_ syn_ -> {-# LINE 150 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ syn_- {-# LINE 3557 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3569 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule360 #-} {-# LINE 159 "src-ag/ExecutionPlanCommon.ag" #-} rule360 = \ ((_prodsIlocalSigMap) :: Map.Map ConstructorIdent (Map.Map Identifier Type)) nt_ -> {-# LINE 159 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ _prodsIlocalSigMap- {-# LINE 3563 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3575 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule361 #-} {-# LINE 65 "src-ag/LOAG/Prepare.ag" #-} rule361 = \ inh_ nt_ -> {-# LINE 65 "src-ag/LOAG/Prepare.ag" #-} let dty = TyData (getName nt_) in Map.singleton dty (toMyAttr Inh dty inh_)- {-# LINE 3570 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3582 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule362 #-} {-# LINE 67 "src-ag/LOAG/Prepare.ag" #-} rule362 = \ nt_ syn_ -> {-# LINE 67 "src-ag/LOAG/Prepare.ag" #-} let dty = TyData (getName nt_) in Map.singleton dty (toMyAttr Syn dty syn_)- {-# LINE 3577 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3589 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule363 #-} {-# LINE 69 "src-ag/LOAG/Prepare.ag" #-} rule363 = \ ((_lhsIaugM) :: Map.Map Identifier (Map.Map Identifier (Set.Set Dependency))) nt_ ->@@ -3581,51 +3593,51 @@ case Map.lookup nt_ _lhsIaugM of Nothing -> Map.empty Just a -> a- {-# LINE 3585 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3597 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule364 #-} {-# LINE 131 "src-ag/LOAG/Prepare.ag" #-} rule364 = \ nt_ -> {-# LINE 131 "src-ag/LOAG/Prepare.ag" #-} TyData (getName nt_)- {-# LINE 3591 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3603 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule365 #-} {-# LINE 82 "src-ag/LOAG/Order.ag" #-} rule365 = \ ((_prodsIfdps) :: Map.Map ConstructorIdent (Set Dependency)) nt_ -> {-# LINE 82 "src-ag/LOAG/Order.ag" #-} Map.singleton nt_ _prodsIfdps- {-# LINE 3597 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3609 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule366 #-} {-# LINE 138 "src-ag/LOAG/Order.ag" #-} rule366 = \ ((_lhsIvisitnum) :: Int) -> {-# LINE 138 "src-ag/LOAG/Order.ag" #-} _lhsIvisitnum- {-# LINE 3603 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3615 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule367 #-} {-# LINE 139 "src-ag/LOAG/Order.ag" #-} rule367 = \ _initial _segments -> {-# LINE 139 "src-ag/LOAG/Order.ag" #-} zipWith const [_initial ..] _segments- {-# LINE 3609 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3621 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule368 #-} {-# LINE 140 "src-ag/LOAG/Order.ag" #-} rule368 = \ _vnums -> {-# LINE 140 "src-ag/LOAG/Order.ag" #-} _vnums- {-# LINE 3615 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3627 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule369 #-} {-# LINE 141 "src-ag/LOAG/Order.ag" #-} rule369 = \ _initial _vnums -> {-# LINE 141 "src-ag/LOAG/Order.ag" #-} Map.fromList $ (_initial + length _vnums, NoneVis) : [(v, OneVis v) | v <- _vnums ]- {-# LINE 3622 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3634 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule370 #-} {-# LINE 143 "src-ag/LOAG/Order.ag" #-} rule370 = \ _initial _vnums -> {-# LINE 143 "src-ag/LOAG/Order.ag" #-} Map.fromList $ (_initial , NoneVis) : [(v+1, OneVis v) | v <- _vnums ]- {-# LINE 3629 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3641 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule371 #-} {-# LINE 145 "src-ag/LOAG/Order.ag" #-} rule371 = \ _initial _mysegments ->@@ -3633,7 +3645,7 @@ let op vnr (MySegment visnr ins syns _ _) = IMap.fromList $ zip syns (repeat vnr) in IMap.unions $ zipWith op [_initial ..] _mysegments- {-# LINE 3637 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3649 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule372 #-} {-# LINE 148 "src-ag/LOAG/Order.ag" #-} rule372 = \ _classContexts _hoInfo _initial _initialVisit _nextVis _prevVis ((_prodsIeprods) :: EProductions) _recursive nt_ params_ ->@@ -3649,14 +3661,14 @@ _prodsIeprods _recursive _hoInfo ]- {-# LINE 3653 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3665 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule373 #-} {-# LINE 322 "src-ag/LOAG/Order.ag" #-} rule373 = \ ((_lhsIsched) :: InterfaceRes) nt_ -> {-# LINE 322 "src-ag/LOAG/Order.ag" #-} findWithErr _lhsIsched "could not const. interfaces" (getName nt_)- {-# LINE 3660 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3672 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule374 #-} {-# LINE 324 "src-ag/LOAG/Order.ag" #-} rule374 = \ _assigned ((_lhsIsched) :: InterfaceRes) ->@@ -3665,7 +3677,7 @@ then 0 else let mx = fst $ IMap.findMax _assigned in if even mx then mx else mx + 1- {-# LINE 3669 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3681 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule375 #-} {-# LINE 329 "src-ag/LOAG/Order.ag" #-} rule375 = \ _assigned _mx ->@@ -3675,7 +3687,7 @@ (maybe [] id $ IMap.lookup (i-1) _assigned ) Nothing Nothing) [_mx ,_mx -2 .. 2]- {-# LINE 3679 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3691 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule376 #-} {-# LINE 335 "src-ag/LOAG/Order.ag" #-} rule376 = \ ((_lhsInmp) :: NMP) _mysegments ->@@ -3684,7 +3696,7 @@ CSegment (Map.unions $ map (vertexToAttr _lhsInmp) is) (Map.unions $ map (vertexToAttr _lhsInmp) ss)) _mysegments- {-# LINE 3688 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 3700 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule377 #-} rule377 = \ ((_prodsIads) :: [Edge]) -> _prodsIads@@ -4544,7 +4556,7 @@ let isLocal = (field_ == _LOC || field_ == _INST) in [(getName field_, (getName attr_, dlhs field_), isLocal)] ++ _patIafs- {-# LINE 4548 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4560 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule552 #-} rule552 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy@@ -4879,31 +4891,31 @@ rule576 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) con_ -> {-# LINE 89 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty con_ _lhsIaroundMap- {-# LINE 4883 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4895 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule577 #-} {-# LINE 114 "src-ag/ExecutionPlanCommon.ag" #-} rule577 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) con_ -> {-# LINE 114 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty con_ _lhsImergeMap- {-# LINE 4889 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4901 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule578 #-} {-# LINE 120 "src-ag/ExecutionPlanCommon.ag" #-} rule578 = \ _mergeMap -> {-# LINE 120 "src-ag/ExecutionPlanCommon.ag" #-} Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems _mergeMap ]- {-# LINE 4895 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4907 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule579 #-} {-# LINE 160 "src-ag/ExecutionPlanCommon.ag" #-} rule579 = \ ((_typeSigsIlocalSigMap) :: Map Identifier Type) con_ -> {-# LINE 160 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton con_ _typeSigsIlocalSigMap- {-# LINE 4901 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4913 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule580 #-} {-# LINE 115 "src-ag/LOAG/Prepare.ag" #-} rule580 = \ ((_lhsIdty) :: MyType) con_ -> {-# LINE 115 "src-ag/LOAG/Prepare.ag" #-} (_lhsIdty,getName con_)- {-# LINE 4907 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4919 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule581 #-} {-# LINE 117 "src-ag/LOAG/Prepare.ag" #-} rule581 = \ ((_childrenIpmpr) :: PMP_R) ((_lhsIaugM) :: Map.Map Identifier (Set.Set Dependency)) _pll con_ ->@@ -4911,37 +4923,37 @@ case Map.lookup con_ _lhsIaugM of Nothing -> [] Just a -> Set.toList $ Set.map (depToEdge _childrenIpmpr _pll ) a- {-# LINE 4915 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4927 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule582 #-} {-# LINE 120 "src-ag/LOAG/Prepare.ag" #-} rule582 = \ ((_lhsIdty) :: MyType) -> {-# LINE 120 "src-ag/LOAG/Prepare.ag" #-} _lhsIdty- {-# LINE 4921 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4933 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule583 #-} {-# LINE 214 "src-ag/LOAG/Prepare.ag" #-} rule583 = \ ((_lhsIdty) :: MyType) con_ -> {-# LINE 214 "src-ag/LOAG/Prepare.ag" #-} (_lhsIdty,getName con_)- {-# LINE 4927 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4939 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule584 #-} {-# LINE 215 "src-ag/LOAG/Prepare.ag" #-} rule584 = \ _pll -> {-# LINE 215 "src-ag/LOAG/Prepare.ag" #-} _pll- {-# LINE 4933 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4945 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule585 #-} {-# LINE 216 "src-ag/LOAG/Prepare.ag" #-} rule585 = \ ((_childrenIpts) :: Set.Set FLabel) -> {-# LINE 216 "src-ag/LOAG/Prepare.ag" #-} _childrenIpts- {-# LINE 4939 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4951 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule586 #-} {-# LINE 217 "src-ag/LOAG/Prepare.ag" #-} rule586 = \ ((_childrenIfieldMap) :: FMap) _pll -> {-# LINE 217 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _pll $ Map.keys _childrenIfieldMap- {-# LINE 4945 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4957 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule587 #-} {-# LINE 89 "src-ag/LOAG/Order.ag" #-} rule587 = \ ((_lhsIdty) :: MyType) ((_lhsIpmpf) :: PMP) ((_lhsIres_ads) :: [Edge]) con_ ->@@ -4952,19 +4964,19 @@ | otherwise = ds in Map.singleton con_ $ foldr op Set.empty _lhsIres_ads- {-# LINE 4956 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4968 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule588 #-} {-# LINE 167 "src-ag/LOAG/Order.ag" #-} rule588 = \ ((_rulesIruleMap) :: Map.Map MyOccurrence Identifier) -> {-# LINE 167 "src-ag/LOAG/Order.ag" #-} _rulesIruleMap- {-# LINE 4962 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4974 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule589 #-} {-# LINE 168 "src-ag/LOAG/Order.ag" #-} rule589 = \ (_ :: ()) -> {-# LINE 168 "src-ag/LOAG/Order.ag" #-} (Set.empty, Set.empty, Set.empty, Set.empty)- {-# LINE 4968 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4980 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule590 #-} {-# LINE 169 "src-ag/LOAG/Order.ag" #-} rule590 = \ ((_childrenIself) :: Children) ->@@ -4973,7 +4985,7 @@ | kind == ChildAttr = Nothing | otherwise = Just $ ChildIntro nm in catMaybes $ map intro _childrenIself- {-# LINE 4977 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 4989 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule591 #-} {-# LINE 174 "src-ag/LOAG/Order.ag" #-} rule591 = \ ((_childrenIechilds) :: EChildren) _intros ((_rulesIerules) :: ERules) ((_segsIevisits) :: Visits) con_ constraints_ params_ ->@@ -4990,7 +5002,7 @@ _rulesIerules _childrenIechilds visits ]- {-# LINE 4994 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5006 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule592 #-} {-# LINE 346 "src-ag/LOAG/Order.ag" #-} rule592 = \ ((_lhsImysegments) :: MySegments) ((_lhsInmp) :: NMP) ((_lhsIpmprf) :: PMP_R) _ps ->@@ -5004,7 +5016,7 @@ handAllOut (_ps ,"lhs") $ map (_lhsInmp Map.!) syns) ) _lhsImysegments- {-# LINE 5008 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5020 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule593 #-} rule593 = \ ((_childrenIap) :: A_P) -> _childrenIap@@ -5324,13 +5336,13 @@ rule649 = \ ((_lhsIvisitnum) :: Int) -> {-# LINE 192 "src-ag/LOAG/Order.ag" #-} _lhsIvisitnum- {-# LINE 5328 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5340 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule650 #-} {-# LINE 193 "src-ag/LOAG/Order.ag" #-} rule650 = \ ((_hdIvisitnum) :: Int) -> {-# LINE 193 "src-ag/LOAG/Order.ag" #-} _hdIvisitnum- {-# LINE 5334 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5346 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule651 #-} rule651 = \ ((_hdIads) :: [Edge]) ((_tlIads) :: [Edge]) -> ((++) _hdIads _tlIads)@@ -5772,31 +5784,31 @@ explicit_ pure_ mbError_- {-# LINE 5776 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5788 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule752 #-} {-# LINE 12 "src-ag/ExecutionPlanPre.ag" #-} rule752 = \ ((_lhsIrulenumber) :: Int) -> {-# LINE 12 "src-ag/ExecutionPlanPre.ag" #-} _lhsIrulenumber + 1- {-# LINE 5782 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5794 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule753 #-} {-# LINE 13 "src-ag/ExecutionPlanPre.ag" #-} rule753 = \ ((_lhsIrulenumber) :: Int) mbName_ -> {-# LINE 13 "src-ag/ExecutionPlanPre.ag" #-} maybe (identifier $ "rule" ++ show _lhsIrulenumber) id mbName_- {-# LINE 5788 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5800 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule754 #-} {-# LINE 230 "src-ag/LOAG/Prepare.ag" #-} rule754 = \ ((_rhsIused) :: Set.Set MyOccurrence) -> {-# LINE 230 "src-ag/LOAG/Prepare.ag" #-} Set.filter (\(MyOccurrence (_,f) _) -> f == "loc") _rhsIused- {-# LINE 5794 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5806 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule755 #-} {-# LINE 231 "src-ag/LOAG/Prepare.ag" #-} rule755 = \ _usedLocals -> {-# LINE 231 "src-ag/LOAG/Prepare.ag" #-} not $ Set.null _usedLocals- {-# LINE 5800 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5812 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule756 #-} {-# LINE 233 "src-ag/LOAG/Prepare.ag" #-} rule756 = \ ((_lhsIlfpf) :: SF_P) ((_lhsIpll) :: PLabel) ((_patternIafs) :: [(FLabel, ALabel, Bool)]) ((_rhsIused) :: Set.Set MyOccurrence) _rulename _usedLocals _usesLocals ->@@ -5820,7 +5832,7 @@ (Set.singleton att) m) lr _rhsIused) else (sfpins,rm,l,lr)) (Map.empty,Map.empty,Map.empty,Map.empty) _patternIafs- {-# LINE 5824 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 5836 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule757 #-} rule757 = \ ((_rhsIused) :: Set.Set MyOccurrence) -> _rhsIused@@ -6146,7 +6158,7 @@ rule795 = \ name_ tp_ -> {-# LINE 161 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton name_ tp_- {-# LINE 6150 "dist/build/LOAG/Order.hs"#-}+ {-# LINE 6162 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule796 #-} rule796 = \ name_ tp_ -> TypeSig name_ tp_
src-generated/LOAG/Rep.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/LOAG/Rep.ag)+-- UUAGC 0.9.51.1 (src-ag/LOAG/Rep.ag) module LOAG.Rep where import CommonTypes
src-generated/Macro.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/Macro.ag)+-- UUAGC 0.9.51.1 (src-ag/Macro.ag) module Macro where {-# LINE 4 "src-ag/Macro.ag" #-}
src-generated/Patterns.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/Patterns.ag)+-- UUAGC 0.9.51.1 (src-ag/Patterns.ag) module Patterns where {-# LINE 2 "src-ag/Patterns.ag" #-}
src-generated/VisagePatterns.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/VisagePatterns.ag)+-- UUAGC 0.9.51.1 (src-ag/VisagePatterns.ag) module VisagePatterns where {-# LINE 2 "src-ag/VisagePatterns.ag" #-}
src-generated/VisageSyntax.hs view
@@ -1,6 +1,6 @@ --- UUAGC 0.9.51 (src-ag/VisageSyntax.ag)+-- UUAGC 0.9.51.1 (src-ag/VisageSyntax.ag) module VisageSyntax where {-# LINE 2 "src-ag/VisageSyntax.ag" #-}
src/LOAG/AOAG.hs view
@@ -5,7 +5,6 @@ import LOAG.Common import LOAG.Graphs import LOAG.Rep-import LOAG.Result import AbstractSyntax import CommonTypes@@ -13,7 +12,6 @@ import Control.Monad (forM, forM_, MonadPlus(..), when, unless) import Control.Monad.ST import Control.Monad.Error (ErrorT(..))-import Control.Monad.Trans (lift, MonadTrans(..)) import Control.Monad.State (MonadState(..)) import Data.Maybe (fromMaybe, catMaybes, fromJust, isNothing) import Data.List (elemIndex, foldl', delete, (\\), insert, nub)@@ -39,43 +37,24 @@ } default_settings = Settings 999 False -type AOAG s a = ResultT (ST s) a-runAOAG :: (forall s. AOAG s a) -> Either Err.Error a-runAOAG l = - case runST (runResult l) of- Give res -> Right res- Cycle e c T1 -> Left $ t1err- Cycle e c T2 -> Left $ t2err- Cycle e c (T3 _) -> Left $ t3err- Limit -> Left $ lerr- NotLOAG -> Left $ naoag- where t1err = Err.CustomError False noPos $ text "Type 1 cycle"- t2err = Err.CustomError False noPos $ text "Type 2 cycle"- t3err = Err.CustomError False noPos $ text "Type 3 cycle"- lerr = Err.CustomError False noPos $ text "Limit reached!"- naoag = Err.CustomError False noPos $ text "Not arranged orderly..."+type AOAG s a = ST s a+ -- | Catch a type 3 cycle-error made by a given constructor -- | two alternatives are given to proceed-catchType3 :: (Monad m) => - ResultT m a -- The monad to catch from- -- If the catch is made- -> (Edge -> Cycle -> [Edge] -> ResultT m a)- -> ResultT m a -catchType3 mt3 alt = Result $ do- let runM = runResult mt3- mt3a <- runM- case mt3a of- Cycle e c (T3 comp) -> runResult (alt e c comp)- otherwise -> runM- type ADS = [Edge]-type AOAGRes = LOAGRes+type AOAGRes = Either Error LOAGRes -- | Calculate a total order if the semantics given -- originate from a linearly-ordered AG-schedule :: LOAGRep -> Grammar -> Ag -> [Edge] -> Either Error AOAGRes++type2error,limiterror,aoagerror :: Error+type2error = Err.CustomError False noPos $ text "Type 2 cycle"+limiterror = Err.CustomError False noPos $ text "Limit reached"+aoagerror = Err.CustomError False noPos $ text "Not an LOAG/AOAG"++schedule :: LOAGRep -> Grammar -> Ag -> [Edge] -> AOAGRes schedule sem gram@(Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) ag@(Ag bounds_s bounds_p de nts) ads - = runAOAG $ aoag default_settings ads+ = runST $ aoag default_settings ads where -- get the maps from semantics and translate them to functions nmp = (nmp_LOAGRep_LOAGRep sem) @@ -113,23 +92,26 @@ run :: AOAG s AOAGRes run = induced ads >>= detect - detect (dp,idp,ids@(idsf,idst)) = do+ detect (Left err) = return $ Left err+ detect (Right (dp,idp,ids@(idsf,idst))) = do -- Attribute -> TimeSlot- schedA <- lift (mapArray (const Nothing) idsf)+ schedA <- mapArray (const Nothing) idsf -- map TimeSlot -> [Attribute]- schedS <- lift (newSTRef $ + schedS <- newSTRef $ foldr (\(Nonterminal nt _ _ _ _) -> M.insert (getName nt) - (IM.singleton 1 [])) M.empty dats)+ (IM.singleton 1 [])) M.empty dats fr_ids <- freeze_graph ids- threads <- lift (completing fr_ids (schedA, schedS) nts)+ threads <- completing fr_ids (schedA, schedS) nts let (ivd, comp) = fetchEdges fr_ids threads nts- m_edp dp init_ads ivd comp (schedA, schedS) `catchType3` - find_ads dp idp ids (schedA, schedS)+ eRoC <- m_edp dp init_ads ivd comp (schedA, schedS)+ case eRoC of+ Left res -> return $ Right res+ Right (e,c,T3 cs) -> find_ads dp idp ids (schedA, schedS) e c cs find_ads :: Graph s -> Graph s -> Graph s -> SchedRef s -> - Edge -> Cycle -> [Edge] -> AOAG s AOAGRes + Edge -> Cycle -> [Edge] -> AOAG s AOAGRes find_ads dp idp ids sched e cycle comp = do- pruner <- lift (newSTRef 999) + pruner <- newSTRef 999 explore dp idp ids sched init_ads pruner e cycle comp explore :: Graph s -> Graph s -> Graph s -> SchedRef s -> @@ -141,12 +123,11 @@ explore' :: Graph s -> Graph s -> Graph s -> SchedRef s -> [Edge] -> [Edge] -> STRef s Int -> AOAG s AOAGRes- explore' _ _ _ _ _ [] _ = Result $ return NotLOAG- explore' dp idp ids sched@(schedA,schedS) ads (fd:cs) pruner - = Result $ do+ explore' _ _ _ _ _ [] _ = return $ Left aoagerror+ explore' dp idp ids sched@(schedA,schedS) ads (fd:cs) pruner = do p_val <- readSTRef pruner if length ads >= p_val -1- then return Limit+ then return $ Left limiterror else do idpf_clone <- mapArray id (fst idp) idpt_clone <- mapArray id (snd idp)@@ -159,131 +140,143 @@ schedS_c <- newSTRef schedS_v let sched_c = (schedA_c, schedS_c) - let runM = runResult $ reschedule dp idp ids sched + let runM = reschedule dp idp ids sched (fd:ads) fd pruner let backtrack = explore' dp idp_c ids_c sched_c ads cs pruner maoag <- runM- case maoag of- Cycle e c T2 -> runResult backtrack- NotLOAG -> runResult backtrack- Limit -> runResult backtrack- Cycle e c (T3 comp) -> error "Uncaught type 3"- Cycle e c T1 -> error "Type 1 error"- Give (tdp1,inf1,ads1) -> + case maoag of + Left _ -> backtrack+ Right (tdp1,inf1,ads1) -> if LOAG.AOAG.min_ads cfg then do writeSTRef pruner (length ads1)- maoag' <- runResult backtrack+ maoag' <- backtrack case maoag' of- Give (tdp2,inf2,ads2)- -> return $ Give (tdp2,inf2,ads2)- otherwise -> return $ Give (tdp1,inf1,ads1)- else return $ Give (tdp1,inf1,ads1)+ Right (tdp2,inf2,ads2)+ -> return $ Right (tdp2,inf2,ads2)+ otherwise -> return $ Right (tdp1,inf1,ads1)+ else return $ Right (tdp1,inf1,ads1) -- step 1, 2 and 3- induced :: [Edge] -> AOAG s (Graph s, Graph s, Graph s)+ induced :: [Edge] -> AOAG s (Either Error (Graph s, Graph s, Graph s)) induced ads = do- dpf <- lift (newArray bounds_p IS.empty)- dpt <- lift (newArray bounds_p IS.empty)- idpf <- lift (newArray bounds_p IS.empty)- idpt <- lift (newArray bounds_p IS.empty)- idsf <- lift (newArray bounds_s IS.empty)- idst <- lift (newArray bounds_s IS.empty)+ dpf <- newArray bounds_p IS.empty+ dpt <- newArray bounds_p IS.empty+ idpf <- newArray bounds_p IS.empty+ idpt <- newArray bounds_p IS.empty+ idsf <- newArray bounds_s IS.empty+ idst <- newArray bounds_s IS.empty let ids = (idsf,idst) let idp = (idpf,idpt) let dp = (dpf ,dpt) inducing dp idp ids (de ++ ads) inducing :: Graph s -> Graph s -> Graph s -> [Edge] - -> AOAG s (Graph s, Graph s, Graph s)+ -> AOAG s (Either Error (Graph s, Graph s, Graph s)) inducing dp idp ids es = do- mapM_ (addD dp idp ids) es- return (dp, idp, ids)- addD :: Graph s -> Graph s -> Graph s -> Edge -> AOAG s [Edge]+ res <- adds (addD dp idp ids) [] es+ case res of + Left _ -> return $ Left $ type2error+ Right _ -> return $ Right (dp, idp, ids)+ addD :: Graph s -> Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge]) addD dp' idp' ids' e = do resd <- e `insErt` dp' resdp <- e `inserT` idp' case resdp of - Right es -> do - addedExtras <- mapM (addN idp' ids') (e:es)- return $ concat addedExtras- Left c -> throwCycle e c T2+ Right es -> adds (addN idp' ids') [] (e:es)+ Left c -> return $ Left $ type2error - addI :: Graph s -> Graph s -> Edge -> AOAG s [Edge]+ addI :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge]) addI idp' ids' e = do exists <- member e idp' if not exists then do res <- e `inserT` idp' case res of- Right es -> do- addedExtras <- mapM (addN idp' ids') es- return (concat addedExtras) - Left c -> throwCycle e c T2- else return []- addN :: Graph s -> Graph s -> Edge -> AOAG s [Edge]+ Right es -> adds (addN idp' ids') [] es+ Left c -> return $ Left $ type2error+ else return $ Right []++ adds f acc [] = return $ Right acc+ adds f acc (e:es) = do+ mes <- f e+ case mes of + Left err -> return $ Left err+ Right news -> adds f (acc++news) es++ addN :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge]) addN idp' ids' e = do if (siblings e) then do let s_edge = genEdge e exists <- member s_edge ids' if not exists then do _ <- inserT s_edge ids'- addedEx <- mapM (addI idp' ids') (instEdge s_edge)- return (s_edge : concat addedEx)- else return []- else return []+ let es = instEdge s_edge+ addedEx <- adds (addI idp' ids') [] es+ case addedEx of+ Right news -> return $ Right (s_edge : news)+ Left err -> return $ Left err+ else return $ Right []+ else return $ Right [] -- step 6, 7 m_edp :: Graph s -> [Edge] -> [Edge] -> [Edge] -> SchedRef s ->- AOAG s AOAGRes + AOAG s (Either LOAGRes (Edge,Cycle,CType)) m_edp (dpf, dpt) ads ivd comp sched = do- edpf <- lift (mapArray id dpf)- edpt <- lift (mapArray id dpt)+ edpf <- mapArray id dpf+ edpt <- mapArray id dpt mc <- addEDs (edpf,edpt) (concatMap instEdge ivd) case mc of- Just (e, c) -> throwCycle e c (T3 $ concatMap instEdge comp)+ Just (e, c) -> return $ Right (e,c,T3 $ concatMap instEdge comp) Nothing -> do - tdp <- lift (freeze edpt)- infs <- lift (readSTRef (snd sched))- return $ (Just tdp,infs,ads)+ tdp <- freeze edpt+ infs <- readSTRef (snd sched)+ return $ Left (Just tdp,infs,ads) reschedule :: Graph s -> Graph s -> Graph s -> SchedRef s -> [Edge] -> Edge -> STRef s Int -> AOAG s AOAGRes reschedule dp idp ids sched@(_,threadRef) ads e pruner = do extra <- addN idp ids e- forM_ extra $ swap_ivd ids sched- fr_ids <- freeze_graph ids- threads <- lift (readSTRef threadRef)- let (ivd, comp) = fetchEdges fr_ids threads nts - m_edp dp ads ivd comp sched `catchType3` - explore dp idp ids sched ads pruner+ case extra of + Left err -> return $ Left err+ Right extra -> do+ forM_ extra $ swap_ivd ids sched+ fr_ids <- freeze_graph ids+ threads <- readSTRef threadRef+ let (ivd, comp) = fetchEdges fr_ids threads nts + eRoC <- m_edp dp ads ivd comp sched+ case eRoC of+ Left res -> return $ Right res + Right (e,c,(T3 cs)) -> explore dp idp ids sched ads pruner e c cs where swap_ivd :: Graph s -> SchedRef s -> Edge -> AOAG s () swap_ivd ids@(idsf, idst) sr@(schedA, schedS) (f,t) = do --the edge should point from higher to lower timeslot- assigned <- lift (freeze schedA)+ assigned <- freeze schedA let oldf = maybe (error "unassigned f") id $ assigned A.! f oldt = maybe (error "unassigned t") id $ assigned A.! t dirf = snd $ alab $ nmp M.! f dirt = snd $ alab $ nmp M.! t newf | oldf < oldt = oldt + (if dirf /= dirt then 1 else 0) | otherwise = oldf- nt = show $ typeOf $ findWithErr nmp "m_edp" f+ nt = show $ typeOf $ nmp M.! f -- the edge was pointing in wrong direction so we moved -- the attribute to a new interaction, now some of its -- predecessors/ancestors might need to be moved too unless (oldf == newf) $ do- lift (writeArray schedA f (Just newf))- lift (modifySTRef schedS - (M.adjust (IM.update (Just . delete f) oldf) nt))- lift (modifySTRef schedS - (M.adjust(IM.alter(Just. maybe [f] (insert f))newf)nt))- predsf <- lift (readArray idst f)- succsf <- lift (readArray idsf f)- mapM_ (swap_ivd ids sr) (- (map (flip (,) f) $ IS.toList predsf) ++ - (map ((,) f) $ IS.toList succsf))+ writeArray schedA f (Just newf)+ modifySTRef schedS + (M.adjust (IM.update (Just . delete f) oldf) nt)+ modifySTRef schedS + (M.adjust(IM.alter(Just. maybe [f] (insert f))newf)nt)+ predsf <- readArray idst f+ succsf <- readArray idsf f+ let rest = (map (flip (,) f) $ IS.toList predsf) ++ + (map ((,) f) $ IS.toList succsf)+ in mapM_ (swap_ivd ids sr) rest+ +
src/LOAG/Common.hs view
@@ -107,6 +107,9 @@ type TDPGraph = (IM.IntMap Vertices, IM.IntMap Vertices) type InterfaceRes = M.Map String (IM.IntMap [Vertex]) type HOMap = M.Map PLabel (S.Set FLabel) +data CType = T1 | T2 + | T3 [Edge] -- completing edges from which to select candidates+ deriving (Show) findWithErr :: (Ord k, Show k, Show a) => M.Map k a -> String -> k -> a findWithErr m err k = maybe (error err) id $ M.lookup k m
src/LOAG/Graphs.hs view
@@ -1,6 +1,5 @@ module LOAG.Graphs where -import Control.Monad.Trans (lift, MonadTrans(..)) import Control.Monad (forM, forM_) import Control.Monad.ST import Control.Monad.State@@ -34,8 +33,7 @@ -- | Functions for changing the state within AOAG -- | possibly catching errors from creating cycles -addEDs :: (MonadTrans m, MonadState s (m (ST s))) => Graph s -> - [Edge] -> (m (ST s)) (Maybe (Edge, Cycle))+addEDs :: Graph s -> [Edge] -> (ST s) (Maybe (Edge, Cycle)) addEDs _ [] = return Nothing addEDs edp (e:es) = do res <- e `inserT` edp@@ -45,26 +43,23 @@ -- | Draws an edge from one node to another, by adding the latter to the -- node set of the first-insErt :: (MonadTrans m, MonadState s (m (ST s))) => Edge -> Graph s -> - (m (ST s)) ()+insErt :: Edge -> Graph s -> (ST s) () insErt (f, t) g@(ft,tf) = do - ts <- lift (readArray ft f)- fs <- lift (readArray tf t)- lift (writeArray ft f (t `IS.insert` ts))- lift (writeArray tf t (f `IS.insert` fs))+ ts <- readArray ft f+ fs <- readArray tf t+ writeArray ft f (t `IS.insert` ts)+ writeArray tf t (f `IS.insert` fs) -removE :: (MonadTrans m, MonadState s (m (ST s))) => Edge -> Graph s -> - (m (ST s)) ()+removE :: Edge -> Graph s -> (ST s) () removE e@(f,t) g@(ft,tf) = do - ts <- lift (readArray ft f)- fs <- lift (readArray tf t)- lift (writeArray ft f (t `IS.delete` ts))- lift (writeArray tf t (f `IS.delete` fs))+ ts <- readArray ft f+ fs <- readArray tf t+ writeArray ft f (t `IS.delete` ts)+ writeArray tf t (f `IS.delete` fs) -- | Revert an edge in the graph-revErt :: (MonadTrans m, MonadState s (m (ST s))) => Edge -> Graph s -> - (m (ST s)) ()+revErt :: Edge -> Graph s -> (ST s) () revErt e g = do present <- member e g when present $ removE e g >> insErt (swap e) g@@ -76,8 +71,7 @@ -- | (graph, edges) if not. Where graph is the new Graph and -- | edges represent the edges that were required for transitively -- | closing the graph.-inserT :: (MonadTrans m, MonadState s (m (ST s))) => Edge -> Graph s -> - (m (ST s)) (Either Cycle [Edge])+inserT :: Edge -> Graph s -> (ST s) (Either Cycle [Edge]) inserT e@(f, t) g@(gft,gtf) | f == t = return $ Left $ IS.singleton f | otherwise = do@@ -85,24 +79,27 @@ if present then (return $ Right []) else do- pointsToF <- lift (readArray gtf f)- pointsToT <- lift (readArray gtf t)- tPointsTo <- lift (readArray gft t)+ rs <- readArray gtf f+ us <- readArray gft t+ pointsToF <- readArray gtf f+ pointsToT <- readArray gtf t+ tPointsTo <- readArray gft t let new2t = pointsToF IS.\\ pointsToT -- extras from f connects all new nodes pointing to f with t let extraF = IS.foldl' (\acc tf -> (tf,t) : acc) [] new2t -- extras of t connects all nodes that will be pointing to t -- in the new graph, with all the nodes t points to in the -- current graph- all2tPointsTo <- lift (newSTRef [])+ all2tPointsTo <- newSTRef [] forM_ (IS.toList tPointsTo) $ \ft -> do- current <- lift (readSTRef all2tPointsTo)- existing <- lift (readArray gtf ft)+ current <- readSTRef all2tPointsTo+ existing <- readArray gtf ft let new4ft = map (flip (,) ft) $ IS.toList $ + -- removing existing here matters a lot (f `IS.insert` pointsToF) IS.\\ existing- lift (writeSTRef all2tPointsTo $ current ++ new4ft)+ writeSTRef all2tPointsTo $ current ++ new4ft - extraT <- lift (readSTRef all2tPointsTo) + extraT <- readSTRef all2tPointsTo -- the extras consists of extras from f and extras from t -- both these extra sets dont contain edges if they are already -- present in the old graph@@ -121,12 +118,11 @@ -- given that there is a cycle,all elements of this cycle are being -- pointed at by f. However, not all elements that f points to are -- part of the cycle. Only those that point back to f.- getCycle :: (MonadTrans m, MonadState s (m (ST s))) => - STArray s Vertex Vertices -> (m (ST s)) Cycle+ getCycle :: STArray s Vertex Vertices -> (ST s) Cycle getCycle gft = do- ts <- lift (readArray gft f)+ ts <- readArray gft f mnodes <- forM (IS.toList ts) $ \t' -> do- fs' <- lift (readArray gft t')+ fs' <- readArray gft t' if f `IS.member` fs' then return $ Just t' else return $ Nothing@@ -134,10 +130,9 @@ -- | Check if a certain edge is part of a graph which means that, -- | the receiving node must be in the node set of the sending-member :: (MonadTrans m, MonadState s (m (ST s))) => Edge -> Graph s -> - (m (ST s)) Bool+member :: Edge -> Graph s -> (ST s) Bool member (f, t) (ft, tf) = do- ts <- lift (readArray ft f)+ ts <- readArray ft f return $ IS.member t ts -- | Check whether an edge is part of a frozen graph@@ -147,15 +142,14 @@ -- | Flatten a graph, meaning that we transform this graph to -- | a set of Edges by combining a sending node with all the -- | receiving nodes in its node set-flatten :: (MonadTrans m, MonadState s (m (ST s))) => Graph s -> (m (ST s)) Edges +flatten :: Graph s -> (ST s) Edges flatten (gft, _) = do- list <- lift (getAssocs gft)+ list <- getAssocs gft return $ S.fromList $ concatMap (\(f, ts) -> map ((,) f) $ IS.toList ts) list -freeze_graph :: (MonadTrans m, MonadState s (m (ST s))) => - Graph s -> (m (ST s)) FrGraph+freeze_graph :: Graph s -> (ST s) FrGraph freeze_graph (mf, mt) = do- fr_f <- lift (freeze mf)- fr_t <- lift (freeze mt)+ fr_f <- freeze mf+ fr_t <- freeze mt return (fr_f, fr_t)
− src/LOAG/Result.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}---- Module for containing results in LOAG tests-module LOAG.Result where--import Control.Applicative-import Control.Monad (liftM, ap, MonadPlus(..))-import Control.Monad.Trans (lift, MonadTrans(..))-import Control.Monad.State (MonadState(..))-import Control.Monad.ST-import ErrorMessages as Err--import LOAG.Graphs--type LOAG s a = ResultT (ST s) a--data Result a = Give a - -- the edge that caused the cyclep of ctype - | Cycle Edge Cycle CType- | Limit- | NotLOAG- deriving (Show) --fromGive :: Result a -> a-fromGive (Give a) = a-fromGive _ = error "fromGive"--data CType = T1 | T2 - | T3 [Edge] -- completing edges from which to select candidates- deriving (Show)--- | Inspired by ErrorT-newtype ResultT m a = Result { runResult :: m (Result a) }--instance Monad m => Functor (ResultT m) where- fmap = liftM--instance Monad m => Applicative (ResultT m) where- pure = return- (<*>) = ap--instance (Monad m) => Monad (ResultT m) where- return = Result . return . Give- (>>=) rt f = Result $ do- ma <- runResult rt- case ma of - Give a -> runResult (f a)- Cycle e c t -> return $ Cycle e c t - Limit -> return $ Limit- NotLOAG -> return $ NotLOAG--instance MonadTrans ResultT where- lift m = Result $ m >>= return . Give-instance MonadState s (ResultT (ST s)) where- get = get- put = put--instance Monad m => Alternative (ResultT m) where- (<|>) = mplus- empty = mzero--instance (Monad m) => MonadPlus (ResultT m) where- mzero = Result $ return NotLOAG- mplus a b = Result $ do- ma <- runResult a - case ma of- Give a -> return $ Give a- f -> do mb <- runResult b- case mb of - Give b -> return $ Give b- _ -> return f---- | Return an error (from detecting a cycle) in the ResultT monad-throwCycle :: (Monad m) => Edge -> Cycle -> CType -> ResultT m a-throwCycle e c t = Result $ return $ Cycle e c t--throwNotLOAG :: (Monad m) => ResultT m a-throwNotLOAG = Result $ return NotLOAG
uuagc.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.8 build-type: Custom name: uuagc-version: 0.9.51+version: 0.9.52 license: BSD3 license-file: LICENSE maintainer: Jeroen Bransen <J.Bransen@uu.nl>@@ -35,7 +35,7 @@ build-depends: uuagc-cabal >= 1.0.2.0 build-depends: base >= 4, base < 5 -- Self dependency, depend on library below- build-depends: uuagc == 0.9.51+ build-depends: uuagc == 0.9.52 main-is: Main.hs hs-source-dirs: src-main @@ -115,6 +115,5 @@ , LOAG.Graphs , LOAG.Order , LOAG.Rep- , LOAG.Result if flag(with-loag) other-modules: LOAG.Solver.MiniSat, LOAG.Optimise