diff --git a/src-ag/LOAG/Order.ag b/src-ag/LOAG/Order.ag --- a/src-ag/LOAG/Order.ag +++ b/src-ag/LOAG/Order.ag @@ -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 [ diff --git a/src-generated/AbstractSyntax.hs b/src-generated/AbstractSyntax.hs --- a/src-generated/AbstractSyntax.hs +++ b/src-generated/AbstractSyntax.hs @@ -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" #-} diff --git a/src-generated/Code.hs b/src-generated/Code.hs --- a/src-generated/Code.hs +++ b/src-generated/Code.hs @@ -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" #-} diff --git a/src-generated/CodeSyntax.hs b/src-generated/CodeSyntax.hs --- a/src-generated/CodeSyntax.hs +++ b/src-generated/CodeSyntax.hs @@ -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" #-} diff --git a/src-generated/ConcreteSyntax.hs b/src-generated/ConcreteSyntax.hs --- a/src-generated/ConcreteSyntax.hs +++ b/src-generated/ConcreteSyntax.hs @@ -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" #-} diff --git a/src-generated/DeclBlocks.hs b/src-generated/DeclBlocks.hs --- a/src-generated/DeclBlocks.hs +++ b/src-generated/DeclBlocks.hs @@ -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" #-} diff --git a/src-generated/ErrorMessages.hs b/src-generated/ErrorMessages.hs --- a/src-generated/ErrorMessages.hs +++ b/src-generated/ErrorMessages.hs @@ -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" #-} diff --git a/src-generated/ExecutionPlan.hs b/src-generated/ExecutionPlan.hs --- a/src-generated/ExecutionPlan.hs +++ b/src-generated/ExecutionPlan.hs @@ -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" #-} diff --git a/src-generated/Expression.hs b/src-generated/Expression.hs --- a/src-generated/Expression.hs +++ b/src-generated/Expression.hs @@ -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" #-} diff --git a/src-generated/HsToken.hs b/src-generated/HsToken.hs --- a/src-generated/HsToken.hs +++ b/src-generated/HsToken.hs @@ -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" #-} diff --git a/src-generated/Interfaces.hs b/src-generated/Interfaces.hs --- a/src-generated/Interfaces.hs +++ b/src-generated/Interfaces.hs @@ -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" #-} diff --git a/src-generated/LOAG/Order.hs b/src-generated/LOAG/Order.hs --- a/src-generated/LOAG/Order.hs +++ b/src-generated/LOAG/Order.hs @@ -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_ diff --git a/src-generated/LOAG/Rep.hs b/src-generated/LOAG/Rep.hs --- a/src-generated/LOAG/Rep.hs +++ b/src-generated/LOAG/Rep.hs @@ -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 diff --git a/src-generated/Macro.hs b/src-generated/Macro.hs --- a/src-generated/Macro.hs +++ b/src-generated/Macro.hs @@ -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" #-} diff --git a/src-generated/Patterns.hs b/src-generated/Patterns.hs --- a/src-generated/Patterns.hs +++ b/src-generated/Patterns.hs @@ -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" #-} diff --git a/src-generated/VisagePatterns.hs b/src-generated/VisagePatterns.hs --- a/src-generated/VisagePatterns.hs +++ b/src-generated/VisagePatterns.hs @@ -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" #-} diff --git a/src-generated/VisageSyntax.hs b/src-generated/VisageSyntax.hs --- a/src-generated/VisageSyntax.hs +++ b/src-generated/VisageSyntax.hs @@ -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" #-} diff --git a/src/LOAG/AOAG.hs b/src/LOAG/AOAG.hs --- a/src/LOAG/AOAG.hs +++ b/src/LOAG/AOAG.hs @@ -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 + + diff --git a/src/LOAG/Common.hs b/src/LOAG/Common.hs --- a/src/LOAG/Common.hs +++ b/src/LOAG/Common.hs @@ -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 diff --git a/src/LOAG/Graphs.hs b/src/LOAG/Graphs.hs --- a/src/LOAG/Graphs.hs +++ b/src/LOAG/Graphs.hs @@ -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) diff --git a/src/LOAG/Result.hs b/src/LOAG/Result.hs deleted file mode 100644 --- a/src/LOAG/Result.hs +++ /dev/null @@ -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 diff --git a/uuagc.cabal b/uuagc.cabal --- a/uuagc.cabal +++ b/uuagc.cabal @@ -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 @@ -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